diff --git a/.env b/.env index df18a04..d1cc3a0 100644 --- a/.env +++ b/.env @@ -1,7 +1,7 @@ # development settings CONFIGURATION_FILE=./app-configuration.json PRINT_CONFIGURATION=yes -SOURCE_FILE=./data/raw/input3.rds +SOURCE_FILE=./data/raw/input4.rds OUTPUT_FILE=./data/output/output.rds ERROR_FILE=./data/output/error.log APP_ARTIFACTS_DIR=./data/output/ diff --git a/.gitignore b/.gitignore index 2063430..aaebeb4 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,4 @@ .DS_Store data/output/** !data/output/.keep +*.keep diff --git a/RFunction.R b/RFunction.R index e535c72..de2656e 100644 --- a/RFunction.R +++ b/RFunction.R @@ -7,279 +7,259 @@ library(magic) library(geosphere) library(lubridate) -rFunction <-function(data, threshold=NULL, window=72, yaxs_limit=1000){ - - data <- data |> mutate(location_long = sf::st_coordinates(data)[,1], - location_lat = sf::st_coordinates(data)[,2], - trackID = mt_track_id(data), - distance = mt_distance(data)) - - #data$distance <- mt_distance(data, units="m") # like this units will always be in meters, please adjust to the units you see most fit - class(data$distance) <-"numeric" - data_df <-as.data.frame(data) - names(data_df) <- gsub("[.]", "_", names(data_df)) - # uid <-unique(data_df$individual_local_identifier) - uid <-unique(data$trackID) - - ### Function for plotting the individual speed - plot_speed <-function(dat, dat_outp, yul=yaxs_limit) - { - yr <- year(dat$timestamp[1]) - plot(dat$timestamp, dat$speed, main= paste(uid[i], yr, sep = "_"), cex=0.4, ylim=c(0,yul), - ylab= expression(paste("Distance /", Delta, "t")), xlab= "Time", col= "grey40") - lines(dat$timestamp, dat$speed,col= "grey30", main= paste(uid[i], yr, sep = "_")) - lines(dat$timestamp, dat$rollm, col ="brown4", lwd=1.5, main= paste(uid[i], yr, sep = "_")) - #legend('topright', legend = rp, bty = 'n') - abline(h= ifelse(is.null(threshold), mean(dat$speed, na.rm=T), threshold), lty=3, lwd=2, col= "coral") - 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") - } + +### Function for plotting the individual speed +plot_speed <- function(dat, dat_outp, yul, track_id, threshold) { + yr <- year(dat$timestamp[1]) + + plot(dat$timestamp, dat$speed, + main = paste(track_id, yr, sep = "_"), cex = 0.4, ylim = c(0, yul), + ylab = expression(paste("Distance /", Delta, "t")), xlab = "Time", col = "grey40" + ) + + lines(dat$timestamp, dat$speed, col = "grey30", main = paste(track_id, yr, sep = "_")) + lines(dat$timestamp, dat$rollm, col = "brown4", lwd = 1.5, main = paste(track_id, yr, sep = "_")) + abline(h = ifelse(is.null(threshold), mean(dat$speed, na.rm = T), threshold), lty = 3, lwd = 2, col = "coral") + + 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") } - - ### Function for plotting the individual location - plot_loc <-function(dat, dat_outp) - { - yr <- year(dat$timestamp[1]) - plot(dat$location_long, dat$location_lat, main= paste(uid[i], yr, sep = "_"), - xlab= "Longitude", ylab= "Latitude", cex=0.4) - lines(dat$location_long, dat$location_lat, main= paste(uid[i], yr, sep = "_"), - xlab= "Longitude", ylab= "Latitude") - for(i in 1: nrow(dat_outp)) - {points(dat_outp$V8,dat_outp$V9, pch=4, cex=3, col= "green4") - points(dat_outp$V8,dat_outp$V9, pch=19, cex=1.5, col= "royalblue") +} + +### Function for plotting the individual location +plot_loc <- function(dat, dat_outp, track_id) { + yr <- year(dat$timestamp[1]) + + plot(dat$location_long, dat$location_lat, + main = paste(track_id, yr, sep = "_"), + xlab = "Longitude", ylab = "Latitude", cex = 0.4 + ) + lines(dat$location_long, dat$location_lat, + main = paste(track_id, yr, sep = "_"), + xlab = "Longitude", ylab = "Latitude" + ) + for (i in 1:nrow(dat_outp)) { + points(dat_outp$V8, dat_outp$V9, pch = 4, cex = 3, col = "green4") + points(dat_outp$V8, dat_outp$V9, pch = 19, cex = 1.5, col = "royalblue") } - } - - ### plot the net-squared displacement along with the identified parturition time - plot_nsd <-function(dat, dat_outp) - { - yr <- year(dat$timestamp[1]) - plot(dat$timestamp, dat$nsd, type="l",main= paste(uid[i], yr, sep = "_"), - ylab= "Net squared displacement (km)", xlab= "Time") - lines(dat$timestamp, dat$rollnsd, col ="brown4", lwd=1) - 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") - - } +} + +### plot the net-squared displacement along with the identified parturition time +plot_nsd <- function(dat, dat_outp, track_id) { + yr <- year(dat$timestamp[1]) + + plot(dat$timestamp, dat$nsd, + type = "l", main = paste(track_id, yr, sep = "_"), + ylab = "Net squared displacement (km)", xlab = "Time" + ) + lines(dat$timestamp, dat$rollnsd, col = "brown4", lwd = 1) + + 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") } - - #dat_output <-as.data.frame(uid) ## Save the different individuals - #plot.new() - dat_updt <-list() - dat_fin_output <-list() - - #pdf("Parturition_velney.pdf", width = 8, height = 12) - pdf(paste0(Sys.getenv(x = "APP_ARTIFACTS_DIR", "/tmp/"), - paste("Parturition_vel",window,".pdf")), width = 8, height = 12) - par(mfrow=c(4,3), mar=c(4,4,3,1)) - - ## if no values are specified as threshold then use the mean as the threshold - if(is.null(threshold)){ - for(i in 1:length(uid)) - { - data_temp1 <-subset(data_df, data_df$trackID ==uid[i]) - tint <-as.numeric(as.POSIXct(max(data_temp1$timestamp)) - as.POSIXct(min(data_temp1$timestamp)), units="hours") - if(dim(data_temp1)[1]>10 & tint > window) ## To filter individuals with very few relocations - { - ## calculates the difference between consecutive timestamp - data_temp <-data_temp1 %>% - mutate(timediff = as.numeric(as.POSIXct(data_temp1$timestamp)- as.POSIXct(lag(data_temp1$timestamp)), units = "hours")) - # the shift is used to move the first NA in time difference to the last position so that - # it matches with the distance column for actual speed calculation - data_temp$timediff <- magic::shift(data_temp$timediff, -1) - data_temp<-subset(data_temp, timediff !=0) - # Calculating the nsd using geosphere package to support the identified parturition - data_temp$nsd <- distVincentyEllipsoid(cbind(data_temp$location_long,data_temp$location_lat), - cbind(data_temp$location_long[1],data_temp$location_lat[1]))/1000 - - data_temp <-data_temp %>% mutate(speed = distance/as.numeric(timediff)) %>% - mutate(rollm =rollapply(speed, window/median(as.numeric(timediff), na.rm=T), mean, na.rm=T, fill=NA), - rollnsd = rollapply(nsd, window/median(as.numeric(timediff), na.rm=T), mean, na.rm=T, fill=NA)) - ##moving average to be calculated over the window time - - ### Input condition for the clustering - ### used a mean criteria here can also be used a user specified cutoff - data_temp$cnd <- ifelse((data_temp$speed) < mean(data_temp$rollm, na.rm=T) & !is.na(data_temp$speed),1,0) - +} + + +rFunction <- function(data, threshold = NULL, window = 72, yaxs_limit = 1000) { + original_track_id_column <- mt_track_id_column(data) + track_attribute_data <- mt_track_data(data) + + data_df <- data |> + mutate( + location_long = sf::st_coordinates(data)[, 1], + location_lat = sf::st_coordinates(data)[, 2], + trackID = mt_track_id(data), + distance = as.numeric(mt_distance(data)) + ) |> + as.data.frame() + + track_ids <- unique(data_df$trackID) + + dat_updt <- list() + dat_fin_output <- list() + + app_artifacts_base_path <- Sys.getenv(x = "APP_ARTIFACTS_DIR", "/tmp/") + + pdf(paste0( + app_artifacts_base_path, + paste("Parturition_vel", window, ".pdf") + ), width = 8, height = 12) + + par(mfrow = c(4, 3), mar = c(4, 4, 3, 1)) + + + for (i in 1:length(track_ids)) { + track_id <- track_ids[i] + + animal_id <- track_attribute_data |> + filter( + !!rlang::sym(original_track_id_column) == track_id + ) |> + dplyr::select(individual_local_identifier) |> + first() + + track_data <- data_df |> + filter(trackID == track_id) + + tint <- as.numeric( + as.POSIXct(max(track_data$timestamp)) - as.POSIXct(min(track_data$timestamp)), + units = "hours" + ) + + if (nrow(track_data) > 10 & tint > window) { ## To filter individuals with very few relocations + data_temp <- tryCatch( + track_data |> + mutate( + # calculate the difference between consecutive timestamps + # the shift is used to move the first NA in time difference to the last position so that + # it matches with the distance column for actual speed calculation + timediff = magic::shift( + as.numeric(as.POSIXct(track_data$timestamp) - as.POSIXct(lag(track_data$timestamp)), + units = "hours" + ), -1 + ) + ) |> + filter( + timediff != 0 + ) |> + mutate( + # Calculating the nsd using geosphere package to support the identified parturition + nsd = distVincentyEllipsoid( + cbind(location_long, location_lat), + cbind(first(location_long), first(location_lat)) + ) / 1000, + + # moving average to be calculated over the window time + speed = distance / as.numeric(timediff), + rollm = rollmean(speed, + window / median(as.numeric(timediff), na.rm = T), + fill = NA + ), + rollnsd = rollmean(nsd, + window / median(as.numeric(timediff), na.rm = T), + fill = NA + ) + ), + error = function(e) { + if (grepl("rollmean", e$message)) { + logger.error(stringr::str_interp( + "App failed because the window of ${window} is less than median difference in time between locations for track ${track_id} and animal ${animal_id}. Please increase your window size." + )) + } + } + ) + + if (is.null(data_temp)) { + return() + } + + + # user-passed threshold or default to mean rollm + working_threshold <- if (!is.null(threshold)) threshold else mean(data_temp$rollm, na.rm = T) + + ### Input condition for the clustering + data_temp$cnd <- ifelse((data_temp$speed) < working_threshold & !is.na(data_temp$speed), 1, 0) + ### Count the sequence length and print the maximum length time - data_temp$run <-sequence(rle(data_temp$cnd)$lengths) + data_temp$run <- sequence(rle(data_temp$cnd)$lengths) data_temp$run_positive <- as.numeric(ifelse(data_temp$cnd == 0, 0, data_temp$run)) - cutoff<- floor(window/median(as.numeric(data_temp$timediff), na.rm=T)) data_temp$crun <- abs(data_temp$run_positive - lag(data_temp$run_positive)) - data_temp$crun[nrow(data_temp)] <-data_temp$run_positive[nrow(data_temp)-1] + data_temp$crun[nrow(data_temp)] <- data_temp$run_positive[nrow(data_temp) - 1] data_temp$case <- NA - - - nrun<- ifelse(is.na(tabulate(data_temp$run_positive)[cutoff+1]),1, - tabulate(data_temp$run_positive)[cutoff+1]) - dat_output <-data.frame() - - for(j in 1:nrun){ - dat_output[j,1] <- uid[i] - dat_output[i,2] <- unique(data_temp$trackID) #ERROR - # if (any(names(data_temp)=="local_identifier")) #need to account for the fact that not all data sets have the variable local_identifier or individual_local_identifier - # { - # dat_output[j,2] <- unique(data_temp$local_identifier) - # } else if (any(names(data_temp)=="individual_local_identifier")) - # { - # dat_output[j,2] <- unique(data_temp$individual_local_identifier) - # } else - # { - # logger.info("There is no standard variable for animal ID in your data set, therefore trackId is used.") - # dat_output[j,2] <- unique(data_temp$trackId) - # } - nrun_ind <- which(data_temp$crun >= cutoff-1) - ### Added the extra value as the rolling mean will show a earlier time compard to + + cutoff <- floor(window / median(as.numeric(data_temp$timediff), na.rm = T)) + + nrun <- ifelse(is.na(tabulate(data_temp$run_positive)[cutoff + 1]), 1, + tabulate(data_temp$run_positive)[cutoff + 1] + ) + + dat_output <- data.frame() + + for (j in 1:nrun) { + dat_output[j, 1] <- track_id + dat_output[j, 2] <- animal_id + + nrun_ind <- which(data_temp$crun >= cutoff - 1) + + ### Added the extra value as the rolling mean will show a earlier time compared to ### the actual parturition time - index.start <- ifelse(length(nrun_ind)==0,NA,nrun_ind[j]-data_temp$run_positive[nrun_ind[j]-1]) - index.end <- ifelse(length(nrun_ind)==0,NA,nrun_ind[j]) - + index_start <- ifelse(length(nrun_ind) == 0, NA, nrun_ind[j] - data_temp$run_positive[nrun_ind[j] - 1]) + index_end <- ifelse(length(nrun_ind) == 0, NA, nrun_ind[j]) + ### Include a column for locations that satisfy the clustering scheme - - if(!is.na(index.start)){data_temp$case[index.start:index.end] <- 1} - - dat_output[j,3] <- ifelse(length(nrun_ind)==0,NA,data_temp$run_positive[nrun_ind[j]-1]) - dat_output[j,4] <- mean(data_temp$rollm, na.rm=T) - dat_output[j,5] <- as.POSIXct(ifelse(length(nrun_ind)==0,NA,data_temp$timestamp[index.start]), origin = "1970-01-01") - dat_output[j,6] <- as.POSIXct(ifelse(length(nrun_ind)==0,NA,data_temp$timestamp[index.end]), origin = "1970-01-01") - dat_output[j,7] <- nrun - if(!is.na(dat_output[j,4])){ - dat_output[j,8] <- ifelse(length(nrun_ind)==0,NA,mean(data_temp$location_long[index.start:index.end], na.rm=T)) ##Change the start - dat_output[j,9] <- ifelse(length(nrun_ind)==0,NA,mean(data_temp$location_lat[index.start:index.end], na.rm=T)) - } else - { - dat_output[j, 8:9]<-NA + if (!is.na(index_start)) { + data_temp$case[index_start:index_end] <- 1 } - } - - 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) - plot_loc(data_temp, dat_output) - plot_nsd(data_temp, dat_output) - - } - } - } - else - { - for(i in 1:length(uid)) - { - data_temp1 <-subset(data_df, data_df$trackID==uid[i]) - tint <-as.numeric(as.POSIXct(max(data_temp1$timestamp)) - as.POSIXct(min(data_temp1$timestamp)), units="hours") - if(dim(data_temp1)[1]>10 & tint > window) ## To filter individuals with very few relocations - { - ## calculates the difference between consecutive timestamp - data_temp <-data_temp1 %>% - mutate(timediff = as.numeric(as.POSIXct(data_temp1$timestamp)- as.POSIXct(lag(data_temp1$timestamp)), units = "hours")) - # the shift is used to move the first NA in time difference to the last position so that - # it matches with the distance column for actual speed calculation - data_temp$timediff <- magic::shift(data_temp$timediff, -1) - data_temp<-subset(data_temp, timediff !=0) - # Calculating the nsd using geosphere package to support the identified parturition - data_temp$nsd <- distVincentyEllipsoid(cbind(data_temp$location_long,data_temp$location_lat), - cbind(data_temp$location_long[1],data_temp$location_lat[1]))/1000 - - data_temp <-data_temp %>% mutate(speed = distance/as.numeric(timediff)) %>% - mutate(rollm =rollapply(speed, window/median(as.numeric(timediff), na.rm=T), mean, na.rm=T, fill=NA)) - ##moving average to be calculated over the window time - - ### Input condition for the clustering - ### used a mean criteria here can also be used a user specified cutoff - data_temp$cnd <- ifelse((data_temp$speed) < threshold & !is.na(data_temp$speed),1,0) - - ### Count the sequence length and print the maximum length time - data_temp$run <-sequence(rle(data_temp$cnd)$lengths) - data_temp$run_positive <- as.numeric(ifelse(data_temp$cnd == 0, 0, data_temp$run)) - cutoff<- floor(window/median(as.numeric(data_temp$timediff), na.rm=T)) - data_temp$crun <- abs(data_temp$run_positive - lag(data_temp$run_positive)) - data_temp$crun[nrow(data_temp)] <-data_temp$run_positive[nrow(data_temp)-1] - data_temp$case <- NA - - nrun<- ifelse(is.na(tabulate(data_temp$run_positive)[cutoff+1]),1, - tabulate(data_temp$run_positive)[cutoff+1]) - dat_output <-data.frame() - - for(j in 1:nrun){ - dat_output[j,1] <- uid[i] - dat_output[j,2] <- unique(data_temp$trackID) #ERROR - # if (any(names(data_temp)=="local_identifier")) #need to account for the fact that not all data sets have the variable local_identifier or individual_local_identifier - # { - # dat_output[j,2] <- unique(data_temp$local_identifier) - # } else if (any(names(data_temp)=="individual_local_identifier")) - # { - # dat_output[j,2] <- unique(data_temp$individual_local_identifier) - # } else - # { - # logger.info("There is no standard variable for animal ID in your data set, therefore trackId is used.") - # dat_output[j,2] <- unique(data_temp$trackId) - # } - nrun_ind <- which(data_temp$crun >= cutoff) - ### Added the extra value as the rolling mean will show a earlier time compard to - ### the actual parturition time - index.start <- ifelse(length(nrun_ind)==0,NA,nrun_ind[j]-data_temp$run_positive[nrun_ind[j]-1]) - index.end <- ifelse(length(nrun_ind)==0,NA,nrun_ind[j]) - - ### Include a column for locations that satisfy the clustering scheme - - if(!is.na(index.start)){data_temp$case[index.start:index.end] <- 1} - - dat_output[j,3] <- ifelse(length(nrun_ind)==0,NA,data_temp$run_positive[nrun_ind[j]-1]) - dat_output[j,4] <- threshold #mean(data_temp$rollm, na.rm=T) - dat_output[j,5] <- as.POSIXct(ifelse(length(nrun_ind)==0,NA,data_temp$timestamp[index.start]), origin = "1970-01-01") - dat_output[j,6] <- as.POSIXct(ifelse(length(nrun_ind)==0,NA,data_temp$timestamp[index.end]), origin = "1970-01-01") - dat_output[j,7] <- nrun - if(!is.na(dat_output[j,4])){ - dat_output[j,8] <- ifelse(length(nrun_ind)==0,NA,mean(data_temp$location_long[index.start:index.end], na.rm=T)) ##Change the start - dat_output[j,9] <- ifelse(length(nrun_ind)==0,NA,mean(data_temp$location_lat[index.start:index.end], na.rm=T)) - } else - { - dat_output[j, 8:9]<-NA - } + + dat_output[j, 3] <- ifelse(length(nrun_ind) == 0, NA, data_temp$run_positive[nrun_ind[j] - 1]) + dat_output[j, 4] <- working_threshold + dat_output[j, 5] <- as.POSIXct(ifelse(length(nrun_ind) == 0, NA, data_temp$timestamp[index_start]), origin = "1970-01-01") + dat_output[j, 6] <- as.POSIXct(ifelse(length(nrun_ind) == 0, NA, data_temp$timestamp[index_end]), origin = "1970-01-01") + dat_output[j, 7] <- nrun + + if (!is.na(dat_output[j, 4])) { + dat_output[j, 8] <- ifelse(length(nrun_ind) == 0, NA, mean(data_temp$location_long[index_start:index_end], na.rm = T)) ## Change the start + dat_output[j, 9] <- ifelse(length(nrun_ind) == 0, NA, mean(data_temp$location_lat[index_start:index_end], na.rm = T)) + } else { + dat_output[j, 8:9] <- NA } - - 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) - plot_loc(data_temp, dat_output) - plot_nsd(data_temp, dat_output) - - } + + 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, + track_id = track_id, threshold = working_threshold + ) + plot_loc(data_temp, dat_output, track_id = track_id) + plot_nsd(data_temp, dat_output, track_id = track_id) } - } + dev.off() - - dat_final <-do.call(rbind,dat_updt) - dat_final$case[is.na(dat_final$case)]<-0 + + 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) - names(dat_final_output) <-c("Track_id", "Individual_id", "Number_of_max_reloc","Threshold_speed(m/h)", - "Start_date", "End_date", "Numbers_of\ndetected_events","location_long", "location_lat") - - names(dat_final) <- make.names(names(dat_final),allow_=FALSE) - - ### Drop NA columns - dat_final_output <- dat_final_output |> drop_na(Start_date) - - write.csv(dat_final_output, file= paste0(Sys.getenv(x = "APP_ARTIFACTS_DIR", "/tmp/"), - paste("Parturition_output",window,".csv"))) - #write.csv(dat_final_output,"Parturition_output2510.csv") - - ###Converting the data.frame output into move-stack object - data_move <- mt_as_move2(dat_final, coords = c("location.long", "location.lat"), - time_column = "timestamp", crs = 4326, - track_id_column = "trackID") - + names(dat_final_output) <- c( + "track_id", "individual_id", "number_of_max_reloc", + "threshold_speed_meters_per_hour", "start_date", "end_date", + "num_detected_events", "location_long", "location_lat" + ) + + # drop NA columns + dat_final_output <- dat_final_output |> + drop_na(Start_date) + + # write app artefact + write.csv(dat_final_output, file = paste0( + app_artifacts_base_path, + paste("Parturition_output", window, ".csv") + )) + + # convert the data.frame output into move2 object + dat_final <- left_join( + dat_final, + track_attribute_data, + join_by(trackID == !!original_track_id_column) + ) |> + dplyr::select(!one_of(!!original_track_id_column)) |> + rename( + !!original_track_id_column := trackID + ) + + + data_move <- mt_as_move2(dat_final, + coords = c("location_long", "location_lat"), + time_column = "timestamp", crs = 4326, + track_id_column = original_track_id_column, + track_attributes = names(track_attribute_data) + ) + return(data_move) - - } diff --git a/app-configuration.json b/app-configuration.json new file mode 100644 index 0000000..9e26dfe --- /dev/null +++ b/app-configuration.json @@ -0,0 +1 @@ +{} \ No newline at end of file diff --git a/data/raw/README.txt b/data/raw/README.txt new file mode 100644 index 0000000..c41e351 --- /dev/null +++ b/data/raw/README.txt @@ -0,0 +1,37 @@ +Set of input data to test apps. + +*Content* +- input1: 1 goat, median fix rate = 30mins, tracking duration 7.5 month, gps, local movement +- input2: 3 storks, median fix rate = 1sec, tracking duration 2 weeks, gps, local movement +- input3: 1 stork, median fix rate = 1h | 1day | 1 week, tracking duration 11.5 years, argos, includes migration +- input4: 3 geese, median fix rate = 1h | 4h, tracking duration 1.5 years, gps, includes migration + +*I/O types* +- all data sets are provided as 'move2_loc' +- input1 & input2 are also provided as 'telemetry.list' + +*Projection* +- for 'move2_loc', data are provided in "lat/long" (EPSG:4326) and projected to "Mollweide" (ESRI:54009) in order to test your app accordingly for not projected and projected data. If your app does not allow projected data or only can deal with projected data, document and either build a automatic transformation in the app or make it fail with an informative error message. The app "Change projection" can be refered to for the user to change the projection of the data acordingly previous to your app. + +- the 'telemetry.list' examples are in a "aeqd" projection with 0,0 in the center of the track, as this is a common projection used within the ctmm library + + +*File names* +input1_move2loc_LatLon.rds +input1_move2loc_Mollweide.rds + +input2_move2loc_LatLon.rds +input2_move2loc_Mollweide.rds + +input3_move2loc_LatLon.rds +input3_move2loc_Mollweide.rds + +input4_move2loc_LatLon.rds +input4_move2loc_Mollweide.rds + + +input1_telemetrylist_aeqd.rds +input2_telemetrylist_aeqd.rds + + + diff --git a/data/raw/stork_argos_movebank_output.rds b/data/raw/stork_argos_movebank_output.rds new file mode 100644 index 0000000..ae7994f Binary files /dev/null and b/data/raw/stork_argos_movebank_output.rds differ diff --git a/tests/testthat/data/input3.rds b/tests/testthat/data/input3.rds new file mode 100644 index 0000000..7c0024a Binary files /dev/null and b/tests/testthat/data/input3.rds differ diff --git a/tests/testthat/data/input3_move1.rds b/tests/testthat/data/input3_move1.rds deleted file mode 100644 index ebc6807..0000000 Binary files a/tests/testthat/data/input3_move1.rds and /dev/null differ diff --git a/tests/testthat/data/input3_move2.rds b/tests/testthat/data/input3_move2.rds index f32c7d3..7bf1f61 100644 Binary files a/tests/testthat/data/input3_move2.rds and b/tests/testthat/data/input3_move2.rds differ diff --git a/tests/testthat/data/input3_move2loc_LatLon.rds b/tests/testthat/data/input3_move2loc_LatLon.rds new file mode 100644 index 0000000..a77ceae Binary files /dev/null and b/tests/testthat/data/input3_move2loc_LatLon.rds differ diff --git a/tests/testthat/data/output/.keep b/tests/testthat/data/output/.keep new file mode 100644 index 0000000..e69de29 diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 2c10dc3..1a22bb1 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -1,4 +1,5 @@ test_data <- function(test_file) { test_data_root_dir <- test_path("data") readRDS(file = file.path(test_data_root_dir, test_file)) -} \ No newline at end of file +} + diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 1b76100..be40607 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1,6 +1,9 @@ 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("LOCAL_APP_FILES_DIR" = "../../data/local_app_files") +Sys.setenv("USER_APP_FILE_HOME_DIR" = "../../data/auxiliary/user-files") + +clearRecentOutput() # the system under test (sut) -source(file.path("..", "..", "./RFunction.R")) \ No newline at end of file +source(file.path("..", "..", "./RFunction.R")) diff --git a/tests/testthat/test_RFunction.R b/tests/testthat/test_RFunction.R new file mode 100644 index 0000000..6164643 --- /dev/null +++ b/tests/testthat/test_RFunction.R @@ -0,0 +1,39 @@ +source(here("tests/testthat/helper.R")) + +test_data <- test_data("input3_move2loc_LatLon.rds") + + +test_that("function executes with user-passed threshold", { + actual <- rFunction(data = test_data, threshold = 6, window = 756) + expected_count <- 3164 + expect_equal(nrow(actual), expected_count) +}) + + +test_that("function executes with default threshold", { + actual <- rFunction(data = test_data, window = 756) + expected_count <- 3164 + expect_equal(nrow(actual), expected_count) +}) + + +test_that("function returns nothing and errors with bad window", { + actual <- rFunction(data = test_data) + expect_null(actual) +}) + + +test_that("function preserves input track attributes", { + actual <- rFunction(data = test_data, window = 756) + actual_track_data_attributes <- sort(names(mt_track_data(actual))) + expected_track_data_attirbutes <- sort(names(mt_track_data(test_data))) + expect_equal(actual_track_data_attributes, expected_track_data_attirbutes) +}) + + +test_that("function preserves input track id column", { + actual <- rFunction(data = test_data, window = 756) + actual_track_id_column <- attr(actual, "track_id") + expected_track_id_column <- attr(test_data, "track_id") + expect_equal(actual_track_id_column, expected_track_id_column) +}) diff --git a/tests/testthat/testthat.R b/tests/testthat/testthat.R index 90fa8ed..f825f8e 100644 --- a/tests/testthat/testthat.R +++ b/tests/testthat/testthat.R @@ -1 +1,2 @@ -library(testthat) \ No newline at end of file +library(testthat) +library(here) \ No newline at end of file