final fixes for new tag project name variables;

fixed case when QC returns an error for tags where shortest in-water distance between detections can not be calculated Merge branch 'staging' # Conflicts: # DESCRIPTION
IMOS-AnimalTracking · Jan 7, 2025 · d6dc111 · d6dc111
2 parents f73b1cb + 89120c3
commit d6dc111
Show file tree

Hide file tree

Showing 7 changed files with 54 additions and 18 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: remora
 Title: Rapid Extraction of Marine Observations for Roving Animals
-Version: 0.8-04
-Date: 2024-01-06
+Version: 0.8-05
+Date: 2024-01-07
 Authors@R: 
     c(person(given = "Fabrice",
            family = "Jaine",

diff --git a/NAMESPACE b/NAMESPACE
@@ -140,6 +140,7 @@ importFrom(stats,time)
 importFrom(stringr,str_split)
 importFrom(terra,"crs<-")
 importFrom(terra,"time<-")
+importFrom(terra,allNA)
 importFrom(terra,crds)
 importFrom(terra,crop)
 importFrom(terra,crs)

diff --git a/R/getDataQC.R b/R/getDataQC.R
@@ -28,7 +28,11 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
   ## detections
   if(is.null(det)) stop("\033[31;1mCan not run QC without a detections file!\033[0m\n")
 
-  if("tagging_project_name" %in% names(read.csv(det))) {
+  ## account for old & new tag project name variables: tagging_project_name (old);
+  ##  tag_deployment_project_name (new)
+  tpdet.log <- "tagging_project_name" %in% names(read.csv(det))
+
+  if(tpdet.log) {
     det.cols <- cols(
       detection_datetime = "T",
       detection_corrected_datetime = "T",
@@ -64,6 +68,7 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
       transmitter_id = "c",
       tag_id = "i",
       transmitter_deployment_id = "i",
+      tag_device_project_name = "c",
       tag_deployment_project_name = "c",
       species_common_name = "c",
       species_scientific_name = "c",
@@ -92,7 +97,7 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
                                           col_types = det.cols,
                                         na = c("","null","NA")
                                         ))
-
+  
   ## drop any unnamed columns, up to a possible 20 of them...
   if(any(paste0("X",1:20) %in% names(det_data))) {
     drops <- paste0("X",1:20)[paste0("X",1:20) %in% names(det_data)]
@@ -118,7 +123,11 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
 
   ## tag deployment metadata
   if(!is.null(tmeta)) {
-    if("tagging_project_name" %in% names(read.csv(tmeta))) {
+    ## account for old & new tag project name variables: tagging_project_name (old);
+    ##  tag_deployment_project_name (new)
+    tpmeta.log <- "tagging_project_name" %in% names(read.csv(tmeta))
+
+    if(tpmeta.log) {
       tmeta.cols <- cols(
         transmitter_id = "c",
         transmitter_serial_number = "i",
@@ -151,6 +160,7 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
       tmeta.cols <- cols(
         transmitter_id = "c",
         transmitter_serial_number = "i",
+        tag_device_project_name = "c",
         tag_deployment_project_name = "c",
         transmitter_type = "c",
         transmitter_sensor_type = "c",
@@ -175,16 +185,23 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
         transmitter_recovery_longitude = "d",
         .default = "d"
       )
-
     }
+
     tag_meta <- suppressWarnings(read_csv(tmeta,
                                           col_types = tmeta.cols,
                                           na = c("","null","NA")
                                           ))
-    ## retain only the metadata for the current tagging_project_name
-    tag_meta <- tag_meta |> 
-      filter(tagging_project_name %in% unique(det_data$tagging_project_name))
+
+    ## retain only the metadata for the current tagging_project_name/tag_deployment_project_name
+    if(tpmeta.log) {
+      tag_meta <- tag_meta |> 
+        filter(tagging_project_name %in% unique(det_data$tagging_project_name))
+    } else {
+      tag_meta <- tag_meta |> 
+        filter(tag_deployment_project_name %in% unique(det_data$tag_deployment_project_name))
+    }
 
+
     ## drop any unnamed columns, up to a possible 20 of them...
     if(any(paste0("X",1:20) %in% names(tag_meta))) {
       drops <- paste0("X",1:20)[paste0("X",1:20) %in% names(tag_meta)]
@@ -319,6 +336,8 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
   if(!is.null(rec_meta)) {
   ## merge detections with receiver metadata - to get receiver_depth,
   ##    but merge everything & keep detections data version of common variables
+
+    ## coerce old tag project name variable to new variable in detections data
     if("tagging_project_name" %in% names(det_data)) {
       id.r <- which(names(det_data) == "tagging_project_name")
       names(det_data)[id.r] <- "tag_deployment_project_name"
@@ -396,14 +415,15 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
   }
 
   if(!is.null(tag_meta)) {
+    ## coerce old tag project name variable to new variable in tag metadata
     if("tagging_project_name" %in% names(tag_meta)) {
       id.t <- which(names(tag_meta) == "tagging_project_name")
       names(tag_meta)[id.t] <- "tag_deployment_project_name"
     }
 
     dd <- left_join(dd,
                     tag_meta,
-                    by = c("transmitter_id", "transmitter_deployment_id")) %>%
+                    by = c("transmitter_id", "transmitter_deployment_id")) |>
       select(
         -transmitter_serial_number.y,
         -tag_deployment_project_name.y,
@@ -419,6 +439,12 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
         -animal_sex.y,
         -embargo_date.x)
 
+    if("tag_device_project_name.x" %in% names(dd)) {
+      dd <- dd |> 
+        rename(tag_device_project_name = tag_device_project_name.x) |>
+        select(-tag_device_project_name.y)
+    }
+
 ## deal with any cases where deploy lon/lat is missing in detections but not metadata
     if(any(is.na(dd$transmitter_deployment_longitude.x)) |
        any(is.na(dd$transmitter_deployment_latitude.x))) {
@@ -481,12 +507,12 @@ get_data <- function(det=NULL, rmeta=NULL, tmeta=NULL, meas=NULL, logfile) {
     }
   }
 
-  ## ensure tagging_project_name variable is returned if exists in input data
+  ## ensure old tagging_project_name variable is returned if exists in input data
   if(exists("id.r")) {
     id <- which(names(dd) == "tag_deployment_project_name")
     names(dd)[id] <- "tagging_project_name"
   }
-  ## ensure tagging_project_name variable is returned if exists in input tag_metadata
+  ## ensure old tagging_project_name variable is returned if exists in input tag_metadata
   if(exists("id.t")) {
     id <- which(names(dd) == "tag_deployment_project_name")
     names(dd)[id] <- "tagging_project_name"

diff --git a/R/grabQC.R b/R/grabQC.R
@@ -88,8 +88,8 @@ grabQC <-
       tag_id_vars <- c("transmitter_id","tag_id","transmitter_deployment_id","tagging_project_name")
       tag_meta_vars <- c("transmitter_id","transmitter_serial_number","tagging_project_name")
     } else {
-      tag_id_vars <- c("transmitter_id","tag_id","transmitter_deployment_id","tag_deployment_project_name") 
-      tag_meta_vars <- c("transmitter_id","transmitter_serial_number","tag_deployment_project_name")
+      tag_id_vars <- c("transmitter_id","tag_id","transmitter_deployment_id","tag_device_project_name","tag_deployment_project_name") 
+      tag_meta_vars <- c("transmitter_id","transmitter_serial_number","tag_device_project_name","tag_deployment_project_name")
     }
 
   out <- switch(what,

diff --git a/R/qc.R b/R/qc.R
@@ -94,7 +94,7 @@ qc <- function(x, Lcheck = TRUE, logfile) {
   ## check for missing transmitter deployment coordinates
   if(any(is.na(x$transmitter_deployment_longitude),
          is.na(x$transmitter_deployment_latitude))) {
-    browser()
+
     ## write to logfile
     write(paste0(x$filename[1],
                  ":  transmitter_deployment_longitude &/or latitude are missing; file not QC'd"),
@@ -279,7 +279,7 @@ qc <- function(x, Lcheck = TRUE, logfile) {
 	x <- x %>%
 	  rename(receiver_deployment_longitude = longitude,
 	         receiver_deployment_latitude = latitude)
-
+	
 	return(bind_cols(x, temporal_outcome))
 
 }
diff --git a/R/runQC.R b/R/runQC.R
@@ -143,8 +143,9 @@ runQC <- function(x,
     warning(paste(nfail, "tag detection file(s) could not be QC'd"),
             call. = FALSE, immediate. = TRUE)
     xfail <- all_data[fails]
+    idx.fails <- which(fails)
     lapply(1:length(xfail), function(i) {
-      write(paste0(xfail[[i]]$filename[1], ":  QC error: ", QC_result[[i]]),
+      write(paste0(xfail[[i]]$filename[1], ":  QC error: ", QC_result[[idx.fails[i]]]),
             file = logfile,
             append = TRUE
       )

diff --git a/R/shortest_dist2_qc.R b/R/shortest_dist2_qc.R
@@ -15,7 +15,7 @@
 ##'
 ##' @return a 1-column matrix of shortest distances
 ##'
-##' @importFrom terra rast extract crop ext crds values
+##' @importFrom terra rast extract crop ext crds values allNA
 ##' @importFrom gdistance costDistance
 ##' @importFrom sf st_as_sf st_distance st_coordinates
 ##' @importFrom geodist geodist
@@ -107,6 +107,14 @@ shortest_dist2 <- function(position, inst, raster = NULL, tr) {
                        max(pts[, 1]) + 2,
                        min(pts[, 2]) - 2,
                        max(pts[, 2]) + 2)))
+        if(all(values(allNA(Aust_sub)))) {
+          Aust_sub <-
+            try(crop(raster,
+                     ext(min(pts[, 1]) - 4,
+                         max(pts[, 1]) + 4,
+                         min(pts[, 2]) - 4,
+                         max(pts[, 2]) + 4)))
+        }
         if (inherits(Aust_sub, "try-error")) {
           stop("detection locations outside extent of land raster")
         }