Merge pull request #111 from inbo/sove-bug-110

Multiple deployments, same location: remove bugs camera operation matrix

R/get_cam_op.R

@@ -90,11 +90,6 @@ get_cam_op <- function(datapkg,
       operational[days_operations == start_day] <- daily_effort_start
       operational[days_operations == end_day] <- daily_effort_end
       operational <- dplyr::as_tibble(operational)
-      # the 0s should actually be NAs meaning "camera(s) not set up". Notice
-      # that in the actual stadium of camera trap dp exchange format, 0s as
-      # returned by camtrapR::cameraOperation()` meaning "camera(s) not
-      # operational", will never occur.
-      operational <- dplyr::na_if(operational, y = 0)
       names(operational) <- x
       return(operational)
     })
@@ -114,12 +109,17 @@ get_cam_op <- function(datapkg,
         names(deployment_operational) %in% deploys_id]
       dep_op <- dplyr::bind_cols(dep_dfs)
       # sum daily effort along all deployments at same location
-      dep_op <- dplyr::as_tibble(rowSums(dep_op[, names(dep_op)]))
+      dep_op <- dplyr::as_tibble(rowSums(dep_op[, names(dep_op)], na.rm = TRUE))
       # set locations as station id
       names(dep_op) <- loc_name
       if (use_prefix == TRUE) {
         names(dep_op) <- paste0("Station", names(dep_op))
       }
+      # the 0s should actually be NAs meaning "camera(s) not set up". Notice
+      # that in the actual stadium of camera trap dp exchange format, 0s as
+      # returned by camtrapR::cameraOperation()` meaning "camera(s) not
+      # operational", will never occur.
+      dep_op <- dplyr::na_if(dep_op, y = 0)
       dep_op[[names(dep_op)]] <- as.numeric(dep_op[[names(dep_op)]])
       return(dep_op)
     })

tests/testthat/test-get_cam_op.R

@@ -83,7 +83,55 @@ test_that("daily effort is > 0 and < 1 for partial active days (start/end)", {
   expect_true(cam_op_matrix[4, end] < 1)
 })
 
+test_that(
+  "effort is > 1 for locations with multiple deployments active at same time", {
+  mica1 <- mica
+  mica1$deployments$start[2] <- lubridate::as_datetime("2020-07-30 21:00:00")
+  mica1$deployments$end[2] <- lubridate::as_datetime("2020-08-07 21:00:00")
+  mica1$deployments$locationName[2] <- mica1$deployments$locationName[1]
+  cam_op_matrix <- get_cam_op(mica1)
+
+  first_full_day_two_deps <- as.character(as.Date(mica1$deployments$start[2]) +
+                                            lubridate::ddays(1))
+  last_full_day_two_deps <- as.character(as.Date(mica1$deployments$end[2]) -
+                                           lubridate::ddays(1))
+  # as many rows as locations
+  expect_true(
+    nrow(cam_op_matrix) == length(unique(mica1$deployments$locationName))
+  )
+  expect_true(cam_op_matrix[1, first_full_day_two_deps] > 1)
+  expect_true(cam_op_matrix[1, last_full_day_two_deps] > 1)
+})
+
+test_that(
+  "0<effort<=1 for locations with multiple deployments not simultaneously active", {
+    mica1 <- mica
+    mica1$deployments$locationName[2] <- mica1$deployments$locationName[1]
+    cam_op_matrix1 <- get_cam_op(mica1)
+    cam_op_matrix <- get_cam_op(mica)
+    start_date1 <- as.character(as.Date(mica$deployments$start[1]))
+    start_date2 <- as.character(as.Date(mica$deployments$start[2]))
+    end_date1 <- as.character(as.Date(mica$deployments$end[1]))
+    end_date2 <- as.character(as.Date(mica$deployments$end[2]))
+    col_idx_start1 <- which(colnames(cam_op_matrix1) == start_date1)
+    col_idx_end1 <- which(colnames(cam_op_matrix1) == end_date1)
+    col_idx_start2 <- which(colnames(cam_op_matrix1) == start_date2)
+    col_idx_end2 <- which(colnames(cam_op_matrix1) == end_date2)
+
+    # all values are greater than 0 (not allowed at the moment) and less or
+    # equal 1
+    expect_true(all(cam_op_matrix1[1, ] <= 1, na.rm = TRUE))
+
+    # the non NAs values are exactly the same as the ones in the matrix with two
+    # deployments apart
+    expect_true(all(cam_op_matrix1[1, col_idx_start1: col_idx_end1] ==
+          cam_op_matrix[1, col_idx_start1: col_idx_end1]))
+    expect_true(all(cam_op_matrix1[1, col_idx_start2: col_idx_end2] ==
+                      cam_op_matrix[2, col_idx_start2: col_idx_end2]))
+  })
+
 test_that("filtering predicates are allowed and work well", {
   filtered_cam_op_matrix <- get_cam_op(mica, pred_lt("longitude", 4.0))
   expect_equal(rownames(filtered_cam_op_matrix), "Mica Viane")
 })
+