Fix file upload

Author: jevansbio

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: seatrackR
 Title: Interface functions for the Seatrack database
-Version: 0.0.3.8
+Version: 0.0.3.92
 Authors@R: c(person(given = "Jens", 
                     family = "Åström", 
                     email = "jens.astrom@nina.no", 

R/getPositions.R

@@ -9,6 +9,7 @@
 #' The available choices can be seen in the column `species_name_eng` in the result from the function `getSpecies()`.
 #' @param colony Character string. Option to limit selection to one or a set of colonies. Default is NULL. The available
 #' choices can be seen in the column `colony_int_name` in the result from the function `getColonies()`.
+#' @param age_deployment_class Character string. Option to limit selection to one or a set of age classes. Default is NULL.
 #' @param dataResponsible Character string. Option to limit selection to one or a set of names of data responsible persons. Note that this
 #' must conform to the name nomenclature used in the postable. Default is NULL. The available
 #' choices can be seen in the column `name` in the result from the function `getNames()`.
@@ -53,6 +54,7 @@
 getPositions <- function(datatype = "GLS",
                          species = NULL,
                          colony = NULL,
+                         age_deployment_class = NULL,
                          dataResponsible = NULL,
                          ringnumber = NULL,
                          year = NULL,
@@ -65,6 +67,7 @@ getPositions <- function(datatype = "GLS",
 
   selectSpecies <- species
   selectColony <- colony
+  selectAge <- age_deployment_class
 
   datatype <- match.arg(datatype,
     choices = c("GLS", "IRMA", "GPS")
@@ -91,6 +94,15 @@ getPositions <- function(datatype = "GLS",
     res <- res |> filter(colony %in% selectColony)
   }
 
+  if (!is.null(selectAge)) {
+    res <- res |>
+      mutate(
+        age_deployment_class = ifelse(!is.na(age_deployment) & tolower(age_deployment) %in% c("pullus", "chick", "pull", "juvenile"), "C", "A")
+      ) %>%
+      filter(age_deployment_class %in% selectAge) %>%
+      select(-age_deployment_class)
+  }
+
   if (!is.null(dataResponsible)) {
     res <- res |> filter(data_responsible %in% dataResponsible)
   }
@@ -111,7 +123,7 @@ getPositions <- function(datatype = "GLS",
     res <- res |> filter(individ_id %in% individId)
   }
 
-  if (!limit == F) {
+  if (!limit == FALSE) {
     res <- res |> head(limit)
   }
 

R/uploadFiles.R

@@ -32,57 +32,70 @@ uploadFiles <- function(files = NULL,
   current_roles <- current_roles[, 1]
 
 
-  if (!("admin" %in% current_roles || "seatrack_writer" %in% current_roles)) stop("Connected user needs to be part of seatrack_writer or admin group")
-
-  if (!tibble::is_tibble(files)) files <- tibble::as_tibble(files)
+  if (!("admin" %in% current_roles || "seatrack_writer" %in% current_roles)) {
+    stop("Connected user needs to be part of seatrack_writer or admin group")
+  }
 
   fileArchive <- listFileArchive()
-
-  if (any(files$value %in% fileArchive$filesInArchive$filename) & overwrite == F) {
-    stop(paste("At least one file already exists in the file archive, use overwrite = True to overwrite"))
+  if(overwrite == FALSE){
+    to_upload <- files[!basename(files) %in% fileArchive$filesInArchive$filename]
+    print(paste(length(files) - length(to_upload) , "files already exist in the file archive and will not be uploaded, use overwrite = TRUE to overwrite"))
   } else {
-    url <- .getFtpUrl()
+    to_upload <- files
+  }
+  print(paste(length(to_upload), "files to upload"))
+  if(length(to_upload) == 0) {
+    return(invisible())
+  }
+  url <- .getFtpUrl()
 
-    writeFile <- function(x,
+  for(x in to_upload) {
+    result <- writeFile(x = x, url = url, originFolder = originFolder)
+    if(result == TRUE) {
+      print(paste("Successfully uploaded file: ", x))
+    } else {
+      print(paste("Failed to upload file: ", x))
+    }
+  }
+}
+
+
+writeFile <- function(x,
                           url,
                           originFolder = originFolder,
                           ...) {
       if (!is.null(originFolder)) {
-        filename <- paste0(originFolder, "/", x)
+        filename <- file.path(originFolder, x)
       } else {
         filename <- paste(x)
       }
 
       if (!file.exists(filename)) {
         warning(paste("Cannot find file: ", filename))
-        return(paste0("File not uploaded: ", filename))
-      } else {
-        tmp <- strsplit(url$url, "//")
-        getUrl <- paste0(tmp[[1]][1], "//", url$pwd, "@", tmp[[1]][2], "/", x)
+        return(FALSE)
+      } 
+        
+      tmp <- strsplit(url$url, "//")
+      getUrl <- paste0(tmp[[1]][1], "//", url$pwd, "@", tmp[[1]][2], "/", basename(x))
 
-        getHandle <- httr::handle(getUrl)
-        filePkg <- httr::upload_file(filename)
+      getHandle <- httr::handle(getUrl)
+      filePkg <- httr::upload_file(filename)
 
-        mess <- lapply(getUrl, factory(function(x) {
-          RCurl::ftpUpload(
-            what = filename,
-            to = getUrl,
-            asText = FALSE,
-            use.ssl = TRUE,
-            ssl.verifypeer = FALSE,
-            sslversion = 6L,
-            ...
-          )
-        }))
+      mess <- lapply(getUrl, factory(function(x) {
+        RCurl::ftpUpload(
+          what = filename,
+          to = getUrl,
+          asText = FALSE,
+          use.ssl = TRUE,
+          ssl.verifypeer = FALSE,
+          sslversion = 6L
+        )
+      }))
 
-        if (any(grepl("OK", attr(mess[[1]][[1]], "names")))) {
-          return(paste0("File uploaded: ", x))
-        }
+      if (any(grepl("OK", attr(mess[[1]][[1]], "names")))) {
+        return(TRUE)
+      }else{
+        return(FALSE)
       }
+      
     }
-
-    apply(files, 1, function(x) writeFile(x = x, url = url, originFolder = originFolder))
-
-    ## Handle messages like in download, not finished
-  }
-}

R/writeRecordings.R

@@ -6,10 +6,7 @@
 #' @param activityData A named vector or data frame that fits the activity_raw table in schema recordings
 #' @param temperatureData A named vector or data frame that fits the temperature_raw table in schema recordings
 #' @param accelerationData A named vector or data frame that fits the acceleration_raw table in schema recordings
-#' @param append Logical, default True. If True, the line(s) is appended to the end of the table.
-#' @param overwrite Logical, default False. WARNING!! If True, the function overwrites the current content of the logger_info table.
-#'
-#' @return Data frame.
+
 #' @export
 #' @examples
 #' \dontrun{
@@ -20,11 +17,12 @@
 writeRecordings <- function(lightData = NULL,
                             activityData = NULL,
                             temperatureData = NULL,
-                            accelerationData = NULL,
-                            append = T,
-                            overwrite = FALSE) {
+                            accelerationData = NULL
+                            ) {
   checkCon()
-
+  # Hardcoding these, we don't want to accidentally overwrite data, and we want to make sure that we append to the tables instead of overwriting them
+  append <- TRUE
+  overwrite <- FALSE
   if (!is.null(lightData)) {
     DBI::dbWithTransaction(
       con,

scaffolding.R

@@ -3,3 +3,10 @@ library(formatR)
 library(badger)
 library(styler)
 library(NinaR)
+install_cellar <- function(path = ".") {
+    cellar <- renv:::renv_paths_cellar()
+    if (!dir.exists(cellar)) {
+        dir.create(cellar)
+    }
+    pkgbuild::build(path, dest_path = cellar)
+}