diff --git a/RFunction.R b/RFunction.R index effbd37..1909273 100644 --- a/RFunction.R +++ b/RFunction.R @@ -21,12 +21,13 @@ plot_speed <- function(dat, dat_outp, yul, track_id, threshold) { abline(h = ifelse(is.null(threshold), mean(dat$speed, na.rm = T), threshold), lty = 3, lwd = 2, col = "coral") # Show known calving event if provided by user - if(!is.null(dat_outp$known_birthdate)){ + if (!is.null(dat_outp$known_birthdate)) { for (i in 1:nrow(dat_outp)) { abline(v = dat_outp$known_birthdate, lty = 1, lwd = 2, col = alpha("grey50", 0.5)) - }} + } + } - # Show start and end of identified calving events + # Show start and end of identified calving events for (i in 1:nrow(dat_outp)) { abline(v = dat_outp$V5, lty = 2, lwd = 1.5, col = "green4") abline(v = dat_outp$V6, lty = 4, lwd = 1.5, col = "royalblue") @@ -62,11 +63,12 @@ plot_nsd <- function(dat, dat_outp, track_id) { lines(dat$timestamp, dat$rollnsd, col = "brown4", lwd = 1) # Show known calving event if provided by user - if(!is.null(dat_outp$known_birthdate)){ + if (!is.null(dat_outp$known_birthdate)) { for (i in 1:nrow(dat_outp)) { abline(v = dat_outp$known_birthdate, lty = 1, lwd = 2, col = alpha("grey50", 0.5)) - }} - + } + } + # Show start and end of identified calving events for (i in 1:nrow(dat_outp)) { abline(v = dat_outp$V5, lty = 2, lwd = 1.5, col = "green4") @@ -94,10 +96,12 @@ rFunction <- function(data, threshold = NULL, window = 72, events_file = NULL, y app_artifacts_base_path <- Sys.getenv(x = "APP_ARTIFACTS_DIR", "/tmp/") - pdf(paste0( + pdf_path <- paste0( app_artifacts_base_path, paste("Parturition_vel", window, "h.pdf", sep = "") - ), width = 8, height = 12) + ) + + pdf(pdf_path, width = 8, height = 12) par(mfrow = c(4, 3), mar = c(4, 4, 3, 1)) @@ -164,7 +168,11 @@ rFunction <- function(data, threshold = NULL, window = 72, events_file = NULL, y ) if (is.null(data_temp)) { - return() + dev.off() + if (file.exists(pdf_path)) { # delete pdf if we failed to run parturition for all animals + file.remove(pdf_path) + } + return(NULL) } @@ -221,23 +229,28 @@ rFunction <- function(data, threshold = NULL, window = 72, events_file = NULL, y # Read the local known calving events file, if provided known_calving_file <- getAuxiliaryFilePath("events_file") - if(!is.null(known_calving_file)){ - known_calving <- read.csv((getAuxiliaryFilePath("events_file")), - header = T, colClasses="character", - na.strings = c("NA","n/a","NaN","")) - known_calving$known_birthdate <- as.POSIXct(known_calving$birthdate, tz="UTC", - format="%Y-%m-%d", origin = "1970-01-01") - known_calving <- known_calving %>% select("track_id","known_birthdate") - - # Add known calving event to output if present - dat_output <- merge(dat_output, known_calving, by.x = 1, by.y = "track_id", - all.x = TRUE, all.y = FALSE, sort = FALSE) + if (!is.null(known_calving_file)) { + known_calving <- read.csv((getAuxiliaryFilePath("events_file")), + header = T, colClasses = "character", + na.strings = c("NA", "n/a", "NaN", "") + ) + known_calving$known_birthdate <- as.POSIXct(known_calving$birthdate, + tz = "UTC", + format = "%Y-%m-%d", origin = "1970-01-01" + ) + known_calving <- known_calving %>% select("track_id", "known_birthdate") + + # Add known calving event to output if present + dat_output <- merge(dat_output, known_calving, + by.x = 1, by.y = "track_id", + all.x = TRUE, all.y = FALSE, sort = FALSE + ) } - + dat_updt[[i]] <- data_temp ### append data for multiple individuals - + dat_fin_output[[i]] <- dat_output - + # plot the figures plot_speed(data_temp, dat_output, yul = yaxs_limit, @@ -253,30 +266,32 @@ rFunction <- function(data, threshold = NULL, window = 72, events_file = NULL, y dat_final <- do.call(rbind, dat_updt) dat_final$case[is.na(dat_final$case)] <- 0 dat_final_output <- do.call(rbind, dat_fin_output) - if(!is.null(known_calving_file)){ - names(dat_final_output) <- c( - "track_id", "individual_local_identifier", "number_max_reloc", - "threshold_speed_meters_per_hour", "start_date", "end_date", - "number_detected_events", "location_long", "location_lat", - "known_birthdate" - ) + if (!is.null(known_calving_file)) { + names(dat_final_output) <- c( + "track_id", "individual_local_identifier", "number_max_reloc", + "threshold_speed_meters_per_hour", "start_date", "end_date", + "number_detected_events", "location_long", "location_lat", + "known_birthdate" + ) } else { - names(dat_final_output) <- c( - "track_id", "individual_local_identifier", "number_max_reloc", - "threshold_speed_meters_per_hour", "start_date", "end_date", - "number_detected_events", "location_long", "location_lat" - ) + names(dat_final_output) <- c( + "track_id", "individual_local_identifier", "number_max_reloc", + "threshold_speed_meters_per_hour", "start_date", "end_date", + "number_detected_events", "location_long", "location_lat" + ) } - + # drop NA columns dat_final_output <- dat_final_output |> drop_na(start_date) - + # format dates consistently - dat_final_output$start_date <- format(as.POSIXct(dat_final_output$start_date, tz="UTC"), - format="%Y-%m-%d %H:%M:%S") - dat_final_output$end_date <- format(as.POSIXct(dat_final_output$end_date, tz="UTC"), - format="%Y-%m-%d %H:%M:%S") + dat_final_output$start_date <- format(as.POSIXct(dat_final_output$start_date, tz = "UTC"), + format = "%Y-%m-%d %H:%M:%S" + ) + dat_final_output$end_date <- format(as.POSIXct(dat_final_output$end_date, tz = "UTC"), + format = "%Y-%m-%d %H:%M:%S" + ) # write app artefact write.csv(dat_final_output, file = paste0( @@ -288,14 +303,14 @@ rFunction <- function(data, threshold = NULL, window = 72, events_file = NULL, y dat_final <- left_join( dat_final, track_attribute_data, - join_by(trackID == !!original_track_id_column) + join_by(trackID == !!original_track_id_column), + suffix = c(".join_artefact_left", ".join_artefact_right") ) |> - dplyr::select(!one_of(!!original_track_id_column)) |> - rename( - !!original_track_id_column := trackID - ) - - + dplyr::select(-contains(".join_artefact_right")) # drop duplicate columns + + # rename duplicate columns + colnames(dat_final) <- gsub(".join_artefact_left", "", colnames(dat_final)) + data_move <- mt_as_move2(dat_final, coords = c("location_long", "location_lat"), time_column = "timestamp", crs = 4326, diff --git a/copilot-sdk.R b/copilot-sdk.R index c07b26c..9aad370 100644 --- a/copilot-sdk.R +++ b/copilot-sdk.R @@ -1,49 +1,49 @@ -################## -## input/output ## adjust! -################## -## Provided testing datasets in `./data/raw`: -## "input1_pigeons.rds", "input2_geese.rds", "input3_stork.rds", "input4_goat.rds" -## for own data: file saved as a .rds containing a object of class MoveStack -inputFileName = "./data/raw/Yahatinda_move2.rds" - -## optionally change the output file name -unlink("./data/output/", recursive = TRUE) # delete "output" folder if it exists, to have a clean start for every run -dir.create("./data/output/") # create a new output folder -outputFileName = "./data/output/output.rds" - -########################## -## Arguments/parameters ## adjust! -########################## -# There is no need to define the parameter "data", as the input data will be automatically assigned to it. -# The name of the field in the vector must be exactly the same as in the r function signature -# Example: -# rFunction = function(data, username, department) -# The parameter must look like: -# args[["username"]] = "my_username" -# args[["department"]] = "my_department" - -args <- list() # if your function has no arguments, this line still needs to be active -# Add all your arguments of your r-function here - -args[["threshold"]] <- NULL -args[["window"]] <- 72 -args[["yaxs_limit"]]<-1000 - -############################## -## source, setup & simulate ## leave as is! -############################## -# this file is the home of your app code and will be bundled into the final app on MoveApps -source("RFunction.R") - -# setup your environment -Sys.setenv( - SOURCE_FILE = inputFileName, - OUTPUT_FILE = outputFileName, - ERROR_FILE="./data/output/error.log", - APP_ARTIFACTS_DIR ="./data/output/artifacts", - LOCAL_APP_FILES_DIR = "./data/local_app_files" -) - -# simulate running your app on MoveApps -source("src/moveapps.R") -simulateMoveAppsRun(args) +################## +## input/output ## adjust! +################## +## Provided testing datasets in `./data/raw`: +## "input1_pigeons.rds", "input2_geese.rds", "input3_stork.rds", "input4_goat.rds" +## for own data: file saved as a .rds containing a object of class MoveStack +inputFileName = "./data/raw/input_issue_20.rds" + +## optionally change the output file name +unlink("./data/output/", recursive = TRUE) # delete "output" folder if it exists, to have a clean start for every run +dir.create("./data/output/") # create a new output folder +outputFileName = "./data/output/output.rds" + +########################## +## Arguments/parameters ## adjust! +########################## +# There is no need to define the parameter "data", as the input data will be automatically assigned to it. +# The name of the field in the vector must be exactly the same as in the r function signature +# Example: +# rFunction = function(data, username, department) +# The parameter must look like: +# args[["username"]] = "my_username" +# args[["department"]] = "my_department" + +args <- list() # if your function has no arguments, this line still needs to be active +# Add all your arguments of your r-function here + +args[["threshold"]] <- NULL +args[["window"]] <- 72 +args[["yaxs_limit"]]<-1000 + +############################## +## source, setup & simulate ## leave as is! +############################## +# this file is the home of your app code and will be bundled into the final app on MoveApps +source("RFunction.R") + +# setup your environment +Sys.setenv( + SOURCE_FILE = inputFileName, + OUTPUT_FILE = outputFileName, + ERROR_FILE="./data/output/error.log", + APP_ARTIFACTS_DIR ="./data/output/artifacts", + LOCAL_APP_FILES_DIR = "./data/local_app_files" +) + +# simulate running your app on MoveApps +source("src/moveapps.R") +simulateMoveAppsRun(args) diff --git a/data/output/.keep b/data/output/.keep deleted file mode 100644 index e69de29..0000000 diff --git a/data/raw/input_issue_20.rds b/data/raw/input_issue_20.rds new file mode 100644 index 0000000..547740c Binary files /dev/null and b/data/raw/input_issue_20.rds differ diff --git a/tests/testthat/.plot.png b/tests/testthat/.plot.png deleted file mode 100644 index ad370b8..0000000 Binary files a/tests/testthat/.plot.png and /dev/null differ diff --git a/tests/testthat/data/input_issue_20.rds b/tests/testthat/data/input_issue_20.rds new file mode 100644 index 0000000..547740c Binary files /dev/null and b/tests/testthat/data/input_issue_20.rds differ diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index be40607..6c515a7 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,9 +1,9 @@ +library(here) +setwd(here("tests/testthat")) source(file.path("..", "..", "src", "common", "logger.R")) -source(file.path("..", "..", "src", "common", "runtime_configuration.R")) source(file.path("..", "..", "src", "io", "app_files.R")) source(file.path("..", "..", "src", "io", "io_handler.R")) -Sys.setenv("USER_APP_FILE_HOME_DIR" = "../../data/auxiliary/user-files") - -clearRecentOutput() +Sys.setenv("LOCAL_APP_FILES_DIR" = "../../data/local_app_files") # the system under test (sut) source(file.path("..", "..", "./RFunction.R")) +setwd(here()) \ No newline at end of file diff --git a/tests/testthat/test_RFunction.R b/tests/testthat/test_RFunction.R index 6164643..3b2f5dc 100644 --- a/tests/testthat/test_RFunction.R +++ b/tests/testthat/test_RFunction.R @@ -20,6 +20,7 @@ test_that("function executes with default threshold", { test_that("function returns nothing and errors with bad window", { actual <- rFunction(data = test_data) expect_null(actual) + expect_false(file.exists()) }) @@ -37,3 +38,12 @@ test_that("function preserves input track id column", { expected_track_id_column <- attr(test_data, "track_id") expect_equal(actual_track_id_column, expected_track_id_column) }) + + +test_data <- test_data("input_issue_20.rds") + +test_that("function doesn't duplicate columns in output", { + actual <- rFunction(data = test_data, threshold = 6, window = 756) + expect_contains(colnames(mt_track_data(actual)), c("individual_local_identifier")) + expect_contains(colnames(actual), c("trackID", "individual_local_identifier_year")) +})