diff --git a/R/CJS.R b/R/CJS.R index 4fe2fce..803f481 100644 --- a/R/CJS.R +++ b/R/CJS.R @@ -165,20 +165,20 @@ breakMatricesByArray <- function(m, arrays, type = c("peers", "all"), verbose = recipient <- list() for (i in 1:length(arrays)) { if ((type == "peers" & !is.null(arrays[[i]]$after.peers)) | (type == "all" & !is.null(arrays[[i]]$all.after))) { - + # find out relevant arrays if (type == "peers") a.regex <- paste0("^", c(names(arrays)[i], arrays[[i]]$after.peers), "$", collapse = "|") else a.regex <- paste0("^", c(names(arrays)[i], arrays[[i]]$all.after), "$", collapse = "|") - + # grab only relevant arrays aux <- lapply(m, function(m_i) m_i[, which(grepl(a.regex, colnames(m_i))), drop = FALSE]) - + # Failsafe in case some tags are released at one of the peers keep <- unlist(lapply(m, function(m_i) any(grepl(paste0("^", names(arrays)[i], "$"), colnames(m_i))))) aux <- aux[keep] - + # Failsafe in case there is only one column left keep <- unlist(lapply(aux, ncol)) > 1 aux <- aux[keep] @@ -207,7 +207,7 @@ breakMatricesByArray <- function(m, arrays, type = c("peers", "all"), verbose = own.zero.check <- unlist(lapply(aux, function(x) sum(x[, 2]) == 0)) peer.zero.check <- unlist(lapply(aux, function(x) sum(x$AnyPeer) == 0)) zero.check <- all(own.zero.check) | all(peer.zero.check) - + if (zero.check) { if (all(own.zero.check) & verbose) { appendTo(c("Screen", "Warning", "Report"), paste0("No tags passed through array ", names(arrays)[i], ". Skipping efficiency estimations for this array.")) @@ -308,7 +308,7 @@ assembleMatrices <- function(spatial, movements, status.df, arrays, paths, dotma output <- lapply(temp, function(x) { # include transmitters that were never detected x <- includeMissing(x = x, status.df = status.df) - + # sort the rows by the same order as status.df (I think these two lines are not needed, but leaving them in just in case) link <- sapply(status.df$Transmitter, function(i) grep(paste0("^", i, "$"), rownames(x))) x <- x[link, ] @@ -334,7 +334,7 @@ assembleMatrices <- function(spatial, movements, status.df, arrays, paths, dotma # If the release sites start in different arrays, trim the matrices as needed if (length(unique.release.arrays) > 1) { for(i in 1:length(aux)){ # for each matrix, find the corresponding release site. - the_release_site <- sapply(spatial$release.sites$Standard.name, function(x) grepl(paste0("\\.", x, "$"), names(aux)[i])) + the_release_site <- sapply(spatial$release.sites$Standard.name, function(x) grepl(paste0("\\.", x, "$"), names(aux)[i])) if(sum(the_release_site) > 1) # if there is more than one matching release site, stop. stop("Multiple release sites match the matrix name. Make sure that the release sites' names are not contained within the animal groups or within themselves.\n") # else, find which is the first column to keep. This is tricky for multi-branch sites... diff --git a/R/actel.R b/R/actel.R index 19f4091..1ee387b 100644 --- a/R/actel.R +++ b/R/actel.R @@ -23,10 +23,10 @@ #' deploys a set of example files following the structure described in the package #' vignettes. Namely: #' \itemize{ -#' \item biometrics.csv -#' \item deployments.csv -#' \item spatial.csv -#' \item detections/ (a folder with .csv files) +#' \item biometrics.csv +#' \item deployments.csv +#' \item spatial.csv +#' \item detections/ (a folder with .csv files) #' } #' #' Once the example dataset is created, \code{\link{exampleWorkspace}} also provides @@ -64,7 +64,7 @@ #' \code{\link{explore}}, but on top of it, it analyses the animal behaviour. #' By selecting the arrays that lead to success, you can define whether or not #' your animals survived the migration. Additional plots help you find out if some -#' animals/tags has been acting odd. Multiple options allow you to tweak the +#' animals/tags has been acting odd. Multiple options allow you to tweak the #' analysis to fit your study perfectly. #' #' diff --git a/R/check.R b/R/check.R index 7dfeeef..fcc208b 100644 --- a/R/check.R +++ b/R/check.R @@ -52,9 +52,9 @@ checkArguments <- function(dp, tz, min.total.detections, min.per.event, max.inte # Note: Checks only relevant for migration() or residency() are listed at the bottom! no.dp.args <- c("tz", "section.order", "start.time", "stop.time", "save.detections", "exclude.tags") - link <- c(!is.null(tz), + link <- c(!is.null(tz), !is.null(section.order), - !is.null(start.time), + !is.null(start.time), !is.null(stop.time), !(is.logical(save.detections) && !save.detections), !is.null(exclude.tags)) @@ -303,9 +303,9 @@ checkGUI <- function(GUI = c("needed", "always", "never"), save.tables.locally) if (!is.character(GUI)) stopAndReport("'GUI' should be one of 'needed', 'always' or 'never'.") - + GUI <- match.arg(GUI) - + if (GUI != "never" && length(suppressWarnings(packageDescription("gWidgets2tcltk"))) == 1) { appendTo(c("Screen", "Warning"), paste0("GUI is set to '", GUI, "' but package 'gWidgets2tcltk' is not available. Please install it if you intend to run GUI.\n Disabling GUI (i.e. GUI = 'never') for the current run.")) GUI <- "never" @@ -376,13 +376,13 @@ checkDupDetections <- function(input) { file.name <- paste0(file.name, ".csv") # prevent auto-overwrite if (file.exists(file.name)) { - aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), - choices = c("y", "n"), + aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), + choices = c("y", "n"), hash = "# overwrite file with same name?") if (aux == "y") overwrite <- TRUE else - overwrite <- FALSE + overwrite <- FALSE } else overwrite <- TRUE @@ -440,7 +440,7 @@ checkMinimumN <- function(movements, min.total.detections, min.per.event, tag, n #' #' @keywords internal #' -checkSpeeds <- function(movements, tag, detections, valid.movements, +checkSpeeds <- function(movements, tag, detections, valid.movements, speed.warning, speed.error, GUI, save.tables.locally, n) { appendTo("debug", "Running checkSpeeds.") the.warning <- NULL @@ -481,7 +481,7 @@ checkSpeeds <- function(movements, tag, detections, valid.movements, } # Trigger user interaction if (any(na.as.false(vm$Average.speed.m.s >= speed.error))) { # nocov start - movements <- tableInteraction(moves = movements, tag = tag, detections = detections, + movements <- tableInteraction(moves = movements, tag = tag, detections = detections, trigger = the.warning, GUI = GUI, save.tables.locally = save.tables.locally) } # nocov end return(movements) @@ -567,7 +567,7 @@ checkInactiveness <- function(movements, tag, detections, n, # Trigger user interaction if (trigger.error) { # nocov start appendTo("Screen", error.message <- paste0("M: Tag ", tag, " ", n, " has been inactive for more than ", inactive.error," days. Inactiveness started on event ", start_i, " (", as.Date(valid.moves$First.time[start_i]),").")) - movements <- tableInteraction(moves = movements, tag = tag, detections = detections, + movements <- tableInteraction(moves = movements, tag = tag, detections = detections, trigger = paste0(the.warning, "\n", error.message), GUI = GUI, save.tables.locally = save.tables.locally) } # nocov end @@ -643,8 +643,8 @@ checkImpassables <- function(movements, tag, bio, spatial, detections, dotmat, G message("Please resolve this either by invalidating events or by adjusting your 'spatial.txt' file and restarting.") if (interactive()) { # nocov start the.warning <- paste(the.warning, "\nPlease resolve this either by invalidating events or by adjusting your 'spatial.txt' file and restarting.", collapse = "\n") - movements <- tableInteraction(moves = movements, tag = tag, detections = detections, - trigger = the.warning, GUI = GUI, force = TRUE, + movements <- tableInteraction(moves = movements, tag = tag, detections = detections, + trigger = the.warning, GUI = GUI, force = TRUE, save.tables.locally = save.tables.locally) restart <- TRUE first.time <- FALSE @@ -704,7 +704,7 @@ checkLinearity <- function(secmoves, tag, spatial, arrays, GUI, save.tables.loca else appendTo(c("Screen", "Report", "Warning"), the.warning <- paste0("Inter-section backwards movements were detected for tag ", tag, " ", n, ".")) if (interactive()) { # nocov start - secmoves <- tableInteraction(moves = secmoves, tag = tag, trigger = the.warning, + secmoves <- tableInteraction(moves = secmoves, tag = tag, trigger = the.warning, GUI = GUI, force = FALSE, save.tables.locally = save.tables.locally) } # nocov end } @@ -770,7 +770,7 @@ checkFirstDetBackFromRelease <- function(movements, tag, bio, detections, arrays appendTo(c("Screen", "Report", "Warning"), the.warning <- paste0("Tag ", tag, " ", n, " was detected in an array that is not after its release site! Opening relevant data for inspection.\nExpected first array: ", release)) the.warning <- paste("Warning:", the.warning) if (interactive()) { # nocov start - movements <- tableInteraction(moves = movements, tag = tag, detections = detections, + movements <- tableInteraction(moves = movements, tag = tag, detections = detections, trigger = the.warning, GUI = GUI, save.tables.locally = save.tables.locally) } # nocov end } @@ -796,10 +796,10 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, the.warning <- NULL warning.counter <- 0 events.to.complain.about <- NULL - + release <- as.character(bio$Release.site[na.as.false(bio$Transmitter == tag)]) release <- unlist(strsplit(with(spatial, release.sites[release.sites$Standard.name == release, "Array"]), "|", fixed = TRUE)) - release.time <- bio$Release.date[na.as.false(bio$Transmitter == tag)] + release.time <- bio$Release.date[na.as.false(bio$Transmitter == tag)] if (any(movements$Valid)) { vm <- movements[(Valid)] @@ -826,17 +826,17 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, xarrays <- unlist(strsplit(p, " -> ")) xarrays <- sapply(xarrays, function(a) { # if the movement ocurred before the start - v1 <- arrays[[a]]$live$Start > release.time & + v1 <- arrays[[a]]$live$Start > release.time & arrays[[a]]$live$Start > vm$First.time[1] # or after the stop - v2 <- arrays[[a]]$live$Stop < release.time & + v2 <- arrays[[a]]$live$Stop < release.time & arrays[[a]]$live$Stop < vm$First.time[1] # then that period does not qualify v3 <- !(v1 | v2) # and if any period qualifies, then the array was up during the movememnt any(v3) }) - return(list(n = sum(xarrays) + 2, names = names(xarrays)[xarrays])) + return(list(n = sum(xarrays) + 2, names = names(xarrays)[xarrays])) # +2 because the release site and the array that picked up the animal also # count as steps, so the minimal step size is two. }) @@ -853,7 +853,7 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, if (release.steps > jump.warning) { # Trigger warning appendTo(c("Report", "Warning", "Screen"), - the.warning <- paste0("Tag ", tag, " ", n, " jumped through ", + the.warning <- paste0("Tag ", tag, " ", n, " jumped through ", ifelse(say.at.least, "at least ", ""), release.steps - 1, ifelse(release.steps > 2, " arrays ", " array "), "from release to first valid event (Release -> ", vm$Array[1], ").")) @@ -890,10 +890,10 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, xarrays <- unlist(strsplit(p, " -> ")) xarrays <- sapply(xarrays, function(a) { # if the movement ocurred before the start - v1 <- arrays[[a]]$live$Start > vm$Last.time[i] & + v1 <- arrays[[a]]$live$Start > vm$Last.time[i] & arrays[[a]]$live$Start > vm$First.time[i + 1] # or after the stop - v2 <- arrays[[a]]$live$Stop < vm$Last.time[i] & + v2 <- arrays[[a]]$live$Stop < vm$Last.time[i] & arrays[[a]]$live$Stop < vm$First.time[i + 1] # then that period does not qualify v3 <- !(v1 | v2) @@ -913,7 +913,7 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, if (warning.counter < 5) { # Trigger warning appendTo(c("Report", "Warning", "Screen"), - other.warning <- paste0("Tag ", tag, " ", n, " jumped through ", + other.warning <- paste0("Tag ", tag, " ", n, " jumped through ", ifelse(say.at.least, "at least ", ""), move.steps[i] - 1, ifelse(move.steps[i] > 2, " arrays ", " array "), "in valid events ", i, " -> ", i + 1, " (", names(move.steps)[i], ").")) @@ -932,7 +932,7 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, if (warning.counter >= 5) { message("") appendTo(c("Report", "Warning"), sub("Warning: ", "", final.warning)) - link <- createEventRanges(events.to.complain.about) + link <- createEventRanges(events.to.complain.about) appendTo(c("Screen", "Report"), event.list <- paste0(" Events that raised warnings: ", paste(link, collapse = ", "))) the.warning <- paste0(the.warning, "\n", final.warning, "\n", event.list) } @@ -940,7 +940,7 @@ checkJumpDistance <- function(movements, tag, bio, detections, spatial, arrays, } # Trigger user interaction if (interactive() && trigger.error) { # nocov start - movements <- tableInteraction(moves = movements, tag = tag, detections = detections, + movements <- tableInteraction(moves = movements, tag = tag, detections = detections, trigger = the.warning, GUI = GUI, save.tables.locally = save.tables.locally) } # nocov end } @@ -990,19 +990,19 @@ checkDeploymentStations <- function(input, spatial) { aux <- spatial[spatial$Type == "Hydrophone", ] link <- match(unique(input$Station.name), aux$Station.name) if (any(is.na(link))) { - appendTo(c("Screen", "Report", "Warning"), - paste0("The following station", ifelse(sum(is.na(link)) > 1, "s are", " is"), + appendTo(c("Screen", "Report", "Warning"), + paste0("The following station", ifelse(sum(is.na(link)) > 1, "s are", " is"), " listed in the deployments but ", - ifelse(sum(is.na(link)) > 1, "are", "is"), - " not part of the study's stations: '", - paste(unique(input$Station.name)[is.na(link)], collapse = "', '"), + ifelse(sum(is.na(link)) > 1, "are", "is"), + " not part of the study's stations: '", + paste(unique(input$Station.name)[is.na(link)], collapse = "', '"), "'\nDiscarding deployments at unknown stations.")) to.remove <- match(input$Station.name, unique(input$Station.name)[is.na(link)]) input <- input[is.na(to.remove), ] } link <- match(aux$Station.name, unique(input$Station.name)) if (any(is.na(link))) { - stopAndReport(paste0("The following station", + stopAndReport(paste0("The following station", ifelse(sum(is.na(link)) > 1, "s are", " is"), " listed in the spatial file but no receivers were ever deployed there: '", paste(aux$Station.name[is.na(link)], collapse = "', '"), @@ -1027,9 +1027,9 @@ checkUnknownReceivers <- function(input) { unknown <- is.na(input$Standard.name) if (any(unknown)) { how.many <- length(unique(input$Receiver[unknown])) - appendTo(c("Screen", "Report", "Warning"), - paste0("Detections from receiver", - ifelse(how.many > 1, "s ", " "), + appendTo(c("Screen", "Report", "Warning"), + paste0("Detections from receiver", + ifelse(how.many > 1, "s ", " "), paste(unique(input$Receiver[unknown]), collapse = ", "), " are present in the data, but ", ifelse(how.many > 1, "these receivers are", "this receiver is"), " not part of the study's stations. Double-check potential errors.")) @@ -1072,7 +1072,7 @@ checkTagsInUnknownReceivers <- function(detections.list, deployments, spatial) { receivers <- detections.list[[i]]$Receiver link <- is.na(match(receivers, deployed.receivers)) new.unknowns <- unique(detections.list[[i]]$Receiver[link]) - + if (length(new.unknowns) > 0) { appendTo(c("Screen", "Report", "Warning"), paste0("Tag ", i, " was detected in one or more receivers that are not listed in the study area (receiver(s): ", paste(new.unknowns, collapse = ", "), ")!")) if (!include.all.unknowns & !exclude.all.unknowns) { @@ -1089,7 +1089,7 @@ checkTagsInUnknownReceivers <- function(detections.list, deployments, spatial) { if (decision == "c") { include.all.unknowns <- TRUE # nocov } - + if (include.all.unknowns || decision == "b") { recipient <- includeUnknownReceiver(spatial = spatial, deployments = deployments, unknown.receivers = new.unknowns) spatial <- recipient[[1]] @@ -1104,11 +1104,11 @@ checkTagsInUnknownReceivers <- function(detections.list, deployments, spatial) { processed.unknowns <- c(processed.unknowns, as.character(new.unknowns)) included <- c(included, as.character(new.unknowns)) } - + if (decision == "e") { exclude.all.unknowns <- TRUE # nocov } - + if (exclude.all.unknowns || decision == "d") { detections.list[[i]] <- detections.list[[i]][is.na(match(receivers, new.unknowns)), ] # keep the ones that are not unknown processed.unknowns <- c(processed.unknowns, as.character(new.unknowns)) @@ -1123,7 +1123,7 @@ checkTagsInUnknownReceivers <- function(detections.list, deployments, spatial) { # append summary to spatial if (!is.null(included) | !is.null(excluded)) spatial$unknowns <- list(included = included, excluded = excluded) - + return(list(spatial = spatial, deployments = deployments, detections.list = detections.list)) } @@ -1188,17 +1188,17 @@ checkDetectionsBeforeRelease <- function(input, bio, discard.orphans = FALSE){ appendTo("Screen", paste0(" First detection time: ", input[[link[i]]]$Timestamp[1])) appendTo("Screen", paste0(" Number of detections before release: ", sum(to.remove))) appendTo("Screen", "\nPossible options:\n a) Stop and double-check the data (recommended)\n b) Discard orphan detections in this instance.\n c) Discard orphan detections for all instances.\n d) Save orphan detections to a file and re-open dialogue.") - + restart <- TRUE while (restart) { - decision <- userInput("Decision:(a/b/c/d/comment) ", + decision <- userInput("Decision:(a/b/c/d/comment) ", choices = c("a", "b", "c", "d", "comment"), - tag = bio$Transmitter[i], + tag = bio$Transmitter[i], hash = paste("# detections before release for tag", bio$Transmitter[i])) - + if (decision == "a") stopAndReport("Function stopped by user command.") # nocov - + if (decision == "b") restart <- FALSE @@ -1217,13 +1217,13 @@ checkDetectionsBeforeRelease <- function(input, bio, discard.orphans = FALSE){ file.name <- paste0(file.name, ".csv") # prevent auto-overwrite if (file.exists(file.name)) { - aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), - choices = c("y", "n"), + aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), + choices = c("y", "n"), hash = "# overwrite file with same name?") if (aux == "y") overwrite <- TRUE else - overwrite <- FALSE + overwrite <- FALSE } else overwrite <- TRUE @@ -1288,11 +1288,11 @@ checkNoDetections <- function(input, bio){ #' checkDupSignals <- function(input, bio){ appendTo("debug", "Running checkDupSignals.") - + if (any(colnames(bio) == "Code.space")) { appendTo('debug', 'Debug: Skipping checkDupSignals as there is a codespace column') } - else { + else { signals <- extractSignals(names(input)) expected <- suppressWarnings(as.numeric(unlist(strsplit(as.character(bio$Signal), "|", fixed = TRUE)))) to.check <- match(signals, expected) @@ -1301,7 +1301,7 @@ checkDupSignals <- function(input, bio){ remove_non_detected <- bind_list_with_expected[complete.cases(bind_list_with_expected), ] table_the_signals <- table(remove_non_detected[, 1], remove_non_detected[, 2]) - dupsig <- data.frame(Signal = colnames(table_the_signals)[apply(table_the_signals, + dupsig <- data.frame(Signal = colnames(table_the_signals)[apply(table_the_signals, 2, sum) > 1], Tags = NA, stringsAsFactors = FALSE) for (i in seq_len(nrow(dupsig))) { dupsig$Tags[i] <- paste(row.names(table_the_signals)[table_the_signals[, dupsig$Signal[i]] == 1], collapse = ", ") @@ -1309,19 +1309,19 @@ checkDupSignals <- function(input, bio){ rest.of.message <- NULL for (i in seq_len(nrow(dupsig))) { - rest.of.message <- paste0(rest.of.message, "\n Signal ", - dupsig$Signal[i], " was found on tags ", + rest.of.message <- paste0(rest.of.message, "\n Signal ", + dupsig$Signal[i], " was found on tags ", dupsig$Tags[i], ".") } - stopAndReport("One or more signals match more than one tag in the detections! Showing relevant signals/tags.", + stopAndReport("One or more signals match more than one tag in the detections! Showing relevant signals/tags.", rest.of.message) } } } #' warn users if they are about to run into an unfixed bug. -#' +#' #' @return No return value, called for side effects. #' #' @keywords internal @@ -1360,7 +1360,7 @@ checkIssue79 <- function(arrays, spatial) { } else { after <- NULL } - + return(rbind(before, after)) }) @@ -1374,7 +1374,7 @@ checkIssue79 <- function(arrays, spatial) { if (any(link)) { if (getOption("actel.bypass_issue_79", default = FALSE)) { - appendTo(c("Screen", "warning", "report"), "This study area seems to trigger issue 79. However, you have activated the bypass, so the analysis will continue.") + appendTo(c("Screen", "warning", "report"), "This study area seems to trigger issue 79. However, you have activated the bypass, so the analysis will continue.") } else { stopAndReport( "READ CAREFULLY diff --git a/R/distances.R b/R/distances.R index 24f2fbb..912c65e 100644 --- a/R/distances.R +++ b/R/distances.R @@ -29,7 +29,7 @@ #' length(suppressWarnings(packageDescription("gdistance"))), #' length(suppressWarnings(packageDescription("sp"))), #' length(suppressWarnings(packageDescription("terra")))) -#' +#' #' missing.packages <- sapply(aux, function(x) x == 1) #' #' if (any(missing.packages)) { @@ -121,12 +121,12 @@ shapeToRaster <- function(shape, size, spatial = "spatial.csv", } else { stop("'shape' must be a .shp file.\n", call. = FALSE) } - + # extend ranges with the buffer if (!is.null(buffer)) { OriEx <- terra::ext(shape) # terra does xmin, xmax, ymin, ymax - + if (length(buffer) == 1){ NewEx <- terra::ext(OriEx[1] - buffer, #xmin OriEx[2] + buffer, #xmax @@ -199,7 +199,7 @@ shapeToRaster <- function(shape, size, spatial = "spatial.csv", message(paste("M: Chosen pixel size:", size, "\nM: Resulting pixel dimensions:")) message(paste0(capture.output(print(pixel.res)), collapse = "\n"), "\n") - ras <- terra::rast(nrows = pixel.res[2], + ras <- terra::rast(nrows = pixel.res[2], ncols = pixel.res[1], xmin = NewEx[1], xmax = NewEx[2], @@ -240,16 +240,16 @@ shapeToRaster <- function(shape, size, spatial = "spatial.csv", #' DEPRECATED -#' +#' #' Please use shapeToRaster instead. -#' +#' #' @inheritParams shapeToRaster #' #' @examples #' \donttest{ #' message("This function is deprecated, please use shapeToRaster instead.") #' } -#' +#' #' @return A raster object. #' #' @export @@ -288,7 +288,7 @@ loadShape <- function(shape, size, spatial = "spatial.csv", #' length(suppressWarnings(packageDescription("gdistance"))), #' length(suppressWarnings(packageDescription("sp"))), #' length(suppressWarnings(packageDescription("terra")))) -#' +#' #' missing.packages <- sapply(aux, function(x) x == 1) #' #' if (any(missing.packages)) { @@ -365,7 +365,7 @@ transitionLayer <- function(x, directions = c(16, 8, 4)){ #' length(suppressWarnings(packageDescription("gdistance"))), #' length(suppressWarnings(packageDescription("sp"))), #' length(suppressWarnings(packageDescription("terra")))) -#' +#' #' missing.packages <- sapply(aux, function(x) x == 1) #' #' if (any(missing.packages)) { @@ -460,7 +460,7 @@ distancesMatrix <- function(t.layer, starters = NULL, targets = starters, targets <- targets[, c(id.col, coord.x, coord.y)] colnames(targets) <- c(id.col, "longitude", "latitude") - + if (!is.null(id.col)) { if (!is.na(match(id.col, colnames(starters)))) { outputRows <- starters[, id.col] @@ -495,15 +495,15 @@ distancesMatrix <- function(t.layer, starters = NULL, targets = starters, #### Create starters and targets spatial dataframes sp::coordinates(starters) <- ~ longitude + latitude # converts the file to a spatialPoints object raster::crs(starters) <- raster::crs(t.layer) # sets the crs - + sp::coordinates(targets) <- ~ longitude + latitude # converts the file to a spatialPoints object raster::crs(targets) <- raster::crs(t.layer) - # NOTE: THE LINES ABOVE COULD BE CHANGED ONCE gdistance'S + # NOTE: THE LINES ABOVE COULD BE CHANGED ONCE gdistance'S # FUNCTIONS START LIKING SF OBJECTS LAYER # starters <- sf::st_as_sf(starters, coords = c("longitude","latitude"), crs = ...) # targets <- sf::st_as_sf(targets, coords = c("longitude","latitude"), crs = ...) - # NOTE: currently, transition layer objects are not + # NOTE: currently, transition layer objects are not # responding correctly to crs requests (e.g. sf::st_crs) #### Calculate a matrix of distances to each object @@ -515,13 +515,13 @@ in the shape file, consider applying a 'buffer' when calculating the transition will artificially add water space around the shape file.", call. = FALSE) dist.mat[dist.mat == Inf] <- NA } - + if (row.rename) rownames(dist.mat) <- outputRows - + if (col.rename) colnames(dist.mat) <- outputCols - + if (interactive() & actel) { # nocov start decision <- userInput("Would you like to save an actel-compatible distances matrix as 'distances.csv' in the current work directory?(y/n) ", choices = c("y", "n")) @@ -620,4 +620,4 @@ completeMatrix <- function(x){ return(x) } - + diff --git a/R/explore.R b/R/explore.R index 5507df1..7a814cc 100644 --- a/R/explore.R +++ b/R/explore.R @@ -56,7 +56,7 @@ #' @param override A vector of signals for which the user intends to manually #' define which movement events are valid and invalid. #' @param detections.y.axis The type of y axis desired for the individual -#' detection plots. While the argument defaults to "auto", it can be hard-set +#' detection plots. While the argument defaults to "auto", it can be hard-set #' to one of "stations" or "arrays". #' @param print.releases Logical: Should the release sites be printed in the #' study area diagrams? @@ -161,7 +161,7 @@ explore <- function( GUI = c("needed", "always", "never"), save.tables.locally = FALSE, print.releases = TRUE, - detections.y.axis = c("auto", "stations", "arrays")) + detections.y.axis = c("auto", "stations", "arrays")) { # check deprecated argument @@ -188,10 +188,10 @@ explore <- function( checkToken(token = attributes(datapack)$actel.token, timestamp = attributes(datapack)$timestamp) - if (length(min.per.event) > 1) + if (length(min.per.event) > 1) appendTo(c('screen', 'warning', 'report'), 'explore() only has array movements but two values were set for min.per.event. Disregarding second value.') - + aux <- checkArguments(dp = datapack, tz = tz, min.total.detections = min.total.detections, @@ -377,7 +377,7 @@ explore <- function( output <- checkMinimumN(movements = movements[[tag]], tag = tag, min.total.detections = min.total.detections, min.per.event = min.per.event[1], n = counter) - output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, + output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, spatial = spatial, dotmat = dotmat, GUI = GUI, save.tables.locally = save.tables.locally) output <- checkJumpDistance(movements = output, bio = bio, tag = tag, dotmat = dotmat, paths = paths, arrays = arrays, @@ -387,8 +387,8 @@ explore <- function( if (do.checkSpeeds) { temp.valid.movements <- simplifyMovements(movements = output, tag = tag, bio = bio, discard.first = discard.first, speed.method = speed.method, dist.mat = dist.mat) - output <- checkSpeeds(movements = output, tag = tag, detections = detections.list[[tag]], n = counter, - valid.movements = temp.valid.movements, speed.warning = speed.warning, + output <- checkSpeeds(movements = output, tag = tag, detections = detections.list[[tag]], n = counter, + valid.movements = temp.valid.movements, speed.warning = speed.warning, speed.error = speed.error, GUI = GUI, save.tables.locally = save.tables.locally) rm(temp.valid.movements) } @@ -397,9 +397,9 @@ explore <- function( output <- checkInactiveness(movements = output, tag = tag, detections = detections.list[[tag]], n = counter, inactive.warning = inactive.warning, inactive.error = inactive.error, dist.mat = dist.mat, GUI = GUI, save.tables.locally = save.tables.locally) - } + } } else { # nocov start - output <- overrideValidityChecks(moves = movements[[tag]], tag = tag, detections = detections.list[[tag]], + output <- overrideValidityChecks(moves = movements[[tag]], tag = tag, detections = detections.list[[tag]], GUI = GUI, save.tables.locally = save.tables.locally, n = counter) } # nocov end return(output) @@ -417,7 +417,7 @@ explore <- function( aux <- list(valid.movements = valid.movements, spatial = spatial, - rsp.info = list(bio = bio, + rsp.info = list(bio = bio, analysis.type = "explore")) times <- getTimes(input = aux, move.type = "array", event.type = "arrival", n.events = "first") rm(aux) @@ -434,7 +434,7 @@ explore <- function( deployments <- do.call(rbind.data.frame, deployments) # extra info for potential RSP analysis - rsp.info <- list(analysis.type = "explore", analysis.time = the.time, + rsp.info <- list(analysis.type = "explore", analysis.time = the.time, bio = bio, tz = tz, actel.version = utils::packageVersion("actel")) if (!is.null(override)) @@ -457,7 +457,7 @@ explore <- function( } if (interactive()) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), choices = c("y", "n"), hash = "# save results?") } else { # nocov end decision <- "n" @@ -466,10 +466,10 @@ explore <- function( if (decision == "y") { # nocov start appendTo(c("Screen", "Report"), paste0("M: Saving results as '", resultsname, "'.")) if (attributes(dist.mat)$valid) - save(bio, detections, valid.detections, spatial, deployments, arrays, + save(bio, detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, times, rsp.info, dist.mat, file = resultsname) else - save(bio, detections, valid.detections, spatial, deployments, arrays, + save(bio, detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, times, rsp.info, file = resultsname) } else { appendTo(c("Screen", "Report"), paste0("M: Skipping saving of the results.")) @@ -494,24 +494,24 @@ explore <- function( biometric.fragment <- printBiometrics(bio = bio) - printDot(dot = dot, - spatial = spatial, + printDot(dot = dot, + spatial = spatial, print.releases = print.releases) - individual.plots <- printIndividuals(detections.list = detections, + individual.plots <- printIndividuals(detections.list = detections, movements = movements, valid.movements = valid.movements, spatial = spatial, rsp.info = rsp.info, y.axis = detections.y.axis) - circular.plots <- printCircular(times = timesToCircular(times), + circular.plots <- printCircular(times = timesToCircular(times), bio = bio) if (any(sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))))) { - sensor.plots <- printSensorData(detections = valid.detections, + sensor.plots <- printSensorData(detections = valid.detections, spatial = spatial, - rsp.info = rsp.info, + rsp.info = rsp.info, colour.by = detections.y.axis) } else { sensor.plots <- NULL @@ -582,7 +582,7 @@ explore <- function( jobname <- paste0(gsub(" |:", ".", as.character(Sys.time())), ".actel.log.txt") if (interactive() & !report) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), choices = c("y", "n"), hash = "# save job log?") } else { # nocov end decision <- "n" @@ -593,14 +593,14 @@ explore <- function( } # nocov end output <- list(bio = bio, - detections = detections, - valid.detections = valid.detections, - spatial = spatial, - deployments = deployments, + detections = detections, + valid.detections = valid.detections, + spatial = spatial, + deployments = deployments, arrays = arrays, - movements = movements, - valid.movements = valid.movements, - times = times, + movements = movements, + valid.movements = valid.movements, + times = times, rsp.info = rsp.info) if (attributes(dist.mat)$valid) diff --git a/R/get.R b/R/get.R index 8d6aabf..d623248 100644 --- a/R/get.R +++ b/R/get.R @@ -1,10 +1,10 @@ #' Extract speeds from the analysis results. -#' +#' #' @inheritParams getTimes #' @param direct Logical: Extract only speeds between arrays that are directly connected (i.e. neighbouring arrays)? #' @param type The type of movements to record. One of "all", "forward", or "backward". In the two last options, #' only the forward or backwards (relatively to the study area structure) movement speeds are returned. -#' +#' #' @examples #' # using the example results loaded with actel #' getSpeeds(example.results) @@ -14,7 +14,7 @@ #' # or #' getSpeeds(example.results, type = "backward") #' -#' # and also how many events per tag (this won't change the output +#' # and also how many events per tag (this won't change the output #' # with the example.results, only because these results are minimal). #' getSpeeds(example.results, n.events = "first") #' # or @@ -43,172 +43,172 @@ getSpeeds <- function(input, type = c("all", "forward", "backward"), direct = FA stop("Could not recognise the input as an actel results object.", call. = FALSE) if (!is.null(input$dist.mat) && is.null(attributes(input$dist.mat)$valid)) - stop("The input object was not compiled using actel 1.1.0 or higher. Please re-run the analysis with the current version of actel.", call. = FALSE) + stop("The input object was not compiled using actel 1.1.0 or higher. Please re-run the analysis with the current version of actel.", call. = FALSE) if (is.null(input$dist.mat) || !attributes(input$dist.mat)$valid) - stop("These results do not contain a valid distances matrix.", call. = FALSE) - - type <- match.arg(type) - n.events <- match.arg(n.events) - speed.method <- attributes(input$dist.mat)$speed.method - to.station.col <- ifelse(speed.method == "last to first", "First.station", "Last.station") - - output.list <- lapply(names(input$valid.movements), function(tag) { - # cat(tag, "\n") - # treat movements as data frame to avoid data.table shenanigans - aux <- as.data.frame(input$valid.movements[[tag]]) - # find events with speeds - to.extract <- which(!is.na(aux$Average.speed.m.s)) - - if (direct) { - if (to.extract[1] == 1) { - # check that first event is connected to release - the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] - the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] - # if not, exclude first event - if (aux$Array[1] != the.first.array) - to.extract <- to.extract[-1] - } - - # check that remaining events are direct - if (length(to.extract) > 0) { - # If first event is still present, avoid it - if (to.extract[1] == 1) { - if (length(to.extract) > 1) { - keep <- sapply(to.extract[-1], function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$neighbours) - }) - to.extract <- to.extract[c(TRUE, keep)] - } - # else just work through everything - } else { - keep <- sapply(to.extract, function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$neighbours) - }) - to.extract <- to.extract[keep] - } - } - } - - if (length(to.extract) > 0 & type == "forward") { - # if first event was selected - if (to.extract[1] == 1) { - # check that first event is at expected first array or at some array coming after it - the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] - the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] - if (!(aux$Array[1] %in% c(the.first.array, input$arrays[[the.first.array]]$all.after))) #first array must be expected first array or after it - to.extract <- to.extract[-1] - } - - # check that remaining events are forward - if (length(to.extract) > 0) { - # If first event is still present, avoid it - if (to.extract[1] == 1) { - if (length(to.extract) > 1) { - keep <- sapply(to.extract[-1], function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.before) # previous array must be before current array - }) - to.extract <- to.extract[c(TRUE, keep)] - } - # else just work through everything - } else { - keep <- sapply(to.extract, function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.before) # previous array must be before current array - }) - to.extract <- to.extract[keep] - } - } - } - - if (length(to.extract) > 0 & type == "backward") { - # if first event was selected - if (to.extract[1] == 1) { - # check that first event is at expected first array or at some array coming after it - the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] - the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] - if (!(aux$Array[1] %in% input$arrays[[the.first.array]]$all.before)) # first array must be before expected first array - to.extract <- to.extract[-1] - } - - # check that remaining events are forward - if (length(to.extract) > 0) { - # If first event is still present, avoid it - if (to.extract[1] == 1) { - if (length(to.extract) > 1) { - keep <- sapply(to.extract[-1], function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.after) # previous array must be after current array - }) - to.extract <- to.extract[c(TRUE, keep)] - } - # else just work through everything - } else { - keep <- sapply(to.extract, function(i) { - the.array <- aux$Array[i] - return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.after) # previous array must be after current array - }) - to.extract <- to.extract[keep] - } - } - } - - if (length(to.extract) > 0) { - if (to.extract[1] == 1) { - first.line <- data.frame( - Tag = tag, - Event = 1, - From.array = "Release", - From.station = input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)], - To.array = aux$Array[1], - To.station = aux[1, to.station.col], - Speed = aux$Average.speed.m.s[1]) - to.extract <- to.extract[-1] - } else { - first.line <- NULL - } - } else { - first.line <- NULL - } - - if (length(to.extract) > 0) { - other.lines <- data.frame( - Tag = rep(tag, length(to.extract)), - Event = to.extract, - From.array = aux$Array[to.extract - 1], - From.station = aux$Last.station[to.extract - 1], - To.array = aux$Array[to.extract], - To.station = aux[to.extract, to.station.col], - Speed = aux$Average.speed.m.s[to.extract]) - } else { - other.lines <- NULL - } - - output <- rbind(first.line, other.lines) - - if (!is.null(output) & n.events != "all") { - output$temp_column <- with(output, paste0(From.array, "_", To.array)) - aux <- split(output, output$temp_column) - - if (n.events == "first") - aux <- lapply(aux, function(x) x[1, , drop = FALSE]) - - if (n.events == "last") - aux <- lapply(aux, function(x) x[nrow(x), , drop = FALSE]) - - output <- as.data.frame(data.table::rbindlist(aux)) - output <- output[, -match("temp_column", colnames(output))] - } - - return(output) - }) - - output <- data.table::rbindlist(output.list) - - return(output) + stop("These results do not contain a valid distances matrix.", call. = FALSE) + + type <- match.arg(type) + n.events <- match.arg(n.events) + speed.method <- attributes(input$dist.mat)$speed.method + to.station.col <- ifelse(speed.method == "last to first", "First.station", "Last.station") + + output.list <- lapply(names(input$valid.movements), function(tag) { + # cat(tag, "\n") + # treat movements as data frame to avoid data.table shenanigans + aux <- as.data.frame(input$valid.movements[[tag]]) + # find events with speeds + to.extract <- which(!is.na(aux$Average.speed.m.s)) + + if (direct) { + if (to.extract[1] == 1) { + # check that first event is connected to release + the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] + the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] + # if not, exclude first event + if (aux$Array[1] != the.first.array) + to.extract <- to.extract[-1] + } + + # check that remaining events are direct + if (length(to.extract) > 0) { + # If first event is still present, avoid it + if (to.extract[1] == 1) { + if (length(to.extract) > 1) { + keep <- sapply(to.extract[-1], function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$neighbours) + }) + to.extract <- to.extract[c(TRUE, keep)] + } + # else just work through everything + } else { + keep <- sapply(to.extract, function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$neighbours) + }) + to.extract <- to.extract[keep] + } + } + } + + if (length(to.extract) > 0 & type == "forward") { + # if first event was selected + if (to.extract[1] == 1) { + # check that first event is at expected first array or at some array coming after it + the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] + the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] + if (!(aux$Array[1] %in% c(the.first.array, input$arrays[[the.first.array]]$all.after))) #first array must be expected first array or after it + to.extract <- to.extract[-1] + } + + # check that remaining events are forward + if (length(to.extract) > 0) { + # If first event is still present, avoid it + if (to.extract[1] == 1) { + if (length(to.extract) > 1) { + keep <- sapply(to.extract[-1], function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.before) # previous array must be before current array + }) + to.extract <- to.extract[c(TRUE, keep)] + } + # else just work through everything + } else { + keep <- sapply(to.extract, function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.before) # previous array must be before current array + }) + to.extract <- to.extract[keep] + } + } + } + + if (length(to.extract) > 0 & type == "backward") { + # if first event was selected + if (to.extract[1] == 1) { + # check that first event is at expected first array or at some array coming after it + the.release <- input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)] + the.first.array <- input$spatial$release.sites$Array[input$spatial$release.sites$Standard.name == the.release] + if (!(aux$Array[1] %in% input$arrays[[the.first.array]]$all.before)) # first array must be before expected first array + to.extract <- to.extract[-1] + } + + # check that remaining events are forward + if (length(to.extract) > 0) { + # If first event is still present, avoid it + if (to.extract[1] == 1) { + if (length(to.extract) > 1) { + keep <- sapply(to.extract[-1], function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.after) # previous array must be after current array + }) + to.extract <- to.extract[c(TRUE, keep)] + } + # else just work through everything + } else { + keep <- sapply(to.extract, function(i) { + the.array <- aux$Array[i] + return(aux$Array[i - 1] %in% input$arrays[[the.array]]$all.after) # previous array must be after current array + }) + to.extract <- to.extract[keep] + } + } + } + + if (length(to.extract) > 0) { + if (to.extract[1] == 1) { + first.line <- data.frame( + Tag = tag, + Event = 1, + From.array = "Release", + From.station = input$rsp.info$bio$Release.site[which(input$rsp.info$bio$Transmitter == tag)], + To.array = aux$Array[1], + To.station = aux[1, to.station.col], + Speed = aux$Average.speed.m.s[1]) + to.extract <- to.extract[-1] + } else { + first.line <- NULL + } + } else { + first.line <- NULL + } + + if (length(to.extract) > 0) { + other.lines <- data.frame( + Tag = rep(tag, length(to.extract)), + Event = to.extract, + From.array = aux$Array[to.extract - 1], + From.station = aux$Last.station[to.extract - 1], + To.array = aux$Array[to.extract], + To.station = aux[to.extract, to.station.col], + Speed = aux$Average.speed.m.s[to.extract]) + } else { + other.lines <- NULL + } + + output <- rbind(first.line, other.lines) + + if (!is.null(output) & n.events != "all") { + output$temp_column <- with(output, paste0(From.array, "_", To.array)) + aux <- split(output, output$temp_column) + + if (n.events == "first") + aux <- lapply(aux, function(x) x[1, , drop = FALSE]) + + if (n.events == "last") + aux <- lapply(aux, function(x) x[nrow(x), , drop = FALSE]) + + output <- as.data.frame(data.table::rbindlist(aux)) + output <- output[, -match("temp_column", colnames(output))] + } + + return(output) + }) + + output <- data.table::rbindlist(output.list) + + return(output) } #' Extract timestamps from the analysis results. diff --git a/R/helper.R b/R/helper.R index bfbbb2b..2703ed9 100644 --- a/R/helper.R +++ b/R/helper.R @@ -1,11 +1,11 @@ #' collapse event indexes into ranges -#' +#' #' @param x a numerical vector -#' +#' #' @return a string of isolated events and event ranges -#' +#' #' @keywords internal -#' +#' createEventRanges <- function(x) { overlaps <- c(FALSE, x[-length(x)] == x[-1]-1) starts <- which(!overlaps) @@ -15,25 +15,25 @@ createEventRanges <- function(x) { aux$Combine <- aux$Start != aux$Stop aux$Final <- aux$Start aux$Final[aux$Combine] <- paste(aux$Start[aux$Combine], aux$Stop[aux$Combine], sep = ":") - return(aux$Final) + return(aux$Final) } #' Split a dataframe every nth row -#' +#' #' Idea from here: https://stackoverflow.com/questions/7060272/split-up-a-dataframe-by-number-of-rows -#' +#' #' @param x the dataframe #' @param n the number of rows to keep in each chunk -#' +#' #' @return A list of equal-sized dataframes -#' +#' #' @keywords internal -#' +#' splitN <- function(x, n, row.names = FALSE) { r <- nrow(x) z <- rep(1:ceiling(r / n), each = n)[1:r] output <- split(x, z) - + # reset row names? if (!row.names) output <- lapply(output, function(x) { @@ -52,16 +52,16 @@ splitN <- function(x, n, row.names = FALSE) { } #' darken colours -#' +#' #' Copied from https://gist.github.com/Jfortin1/72ef064469d1703c6b30 -#' +#' #' @param color The colour to be darkened #' @param factor The level of darkening -#' +#' #' @return The darker colour code -#' +#' #' @keywords internal -#' +#' darken <- function(color, factor = 1.4){ col <- grDevices::col2rgb(color) @@ -75,14 +75,14 @@ darken <- function(color, factor = 1.4){ } #' Match POSIX values -#' +#' #' @param this the vector of posix to be match #' @param there the vector of posix to be matched against -#' +#' #' @return a vector with the matches -#' +#' #' @keywords internal -#' +#' match.POSIXt <- function(this, there) { sapply(this, function(i) { x <- which(i == there) @@ -95,13 +95,13 @@ match.POSIXt <- function(this, there) { } #' stop function but paste error to the report too -#' +#' #' @param ... parts of the error string -#' +#' #' @return No return value, called for side effects. -#' +#' #' @keywords internal -#' +#' stopAndReport <- function(...) { the.string <- paste0(...) appendTo("Report", paste0("Error: ", the.string)) @@ -109,21 +109,21 @@ stopAndReport <- function(...) { } #' Find original station name -#' +#' #' @param input The results of an actel analysis (either explore, migration or residency). #' @param station The station standard name or number. -#' +#' #' @examples #' stationName(example.results, 1) -#' +#' #' # or -#' +#' #' stationName(example.results, "St.2") -#' +#' #' @return The original station name -#' +#' #' @export -#' +#' stationName <- function(input, station) { if (!inherits(input, "list")) stop("Could not recognise the input as an actel results object.", call. = FALSE) @@ -524,7 +524,7 @@ emergencyBreak <- function(the.function.call) { # nocov start appendTo("Report", paste0("Function call:\n-------------------\n", the.function.call, "\n-------------------")) message("\nM: The analysis errored. You can recover latest the job log (including your comments and decisions) by running recoverLog().") - + if (getOption("actel.debug", default = FALSE)) { file.copy(paste0(tempdir(), "/temp_log.txt"), paste0(tempdir(), "/latest_actel_error_log.txt")) } else { @@ -534,10 +534,10 @@ emergencyBreak <- function(the.function.call) { # nocov start } # nocov end #' Recover latest actel crash log -#' +#' #' @param file Name of the file to which the log should be saved. #' @param overwrite Logical: If 'file' already exists, should its content be overwritten? -#' +#' #' @examples #' \dontshow{ #' sink(paste0(tempdir(), "/latest_actel_error_log.txt")) @@ -550,18 +550,18 @@ emergencyBreak <- function(the.function.call) { # nocov start #' Function: example()") #' sink() #' } -#' +#' #' recoverLog(file = paste0(tempdir(), "/new_log.txt")) -#' +#' #' \dontshow{ #' file.remove(paste0(tempdir(), "/latest_actel_error_log.txt")) #' file.remove(paste0(tempdir(), "/new_log.txt")) #' } -#' +#' #' @return No return value, called for side effects. -#' +#' #' @export -#' +#' recoverLog <- function(file, overwrite = FALSE) { if (!file.exists(paste0(tempdir(), "/latest_actel_error_log.txt"))) stop("No crash logs found.", call. = FALSE) @@ -651,20 +651,20 @@ timesToCircular <- function(x, by.group = FALSE) { #' cleanly extract lowest signal from signals string -#' +#' #' @param x -#' +#' #' @return a vector of lowest signals -#' +#' #' @keywords internal -#' +#' lowestSignal <- function(x) { - sapply(as.character(x), function(i) + sapply(as.character(x), function(i) min( as.numeric( unlist( - strsplit(i, - "|", + strsplit(i, + "|", fixed = TRUE) ) ) @@ -673,14 +673,14 @@ lowestSignal <- function(x) { } #' Split signals from multi-signal input -#' +#' #' @param x -#' +#' #' @return a list of split signals -#' +#' #' @keywords internal -#' -#' +#' +#' splitSignals <- function(x) { if(length(x) != 1) stop('splitSignals can only split one input at a time') @@ -689,12 +689,12 @@ splitSignals <- function(x) { #' Convert Lotek CDMA log to csv -#' +#' #' Lotek CDMA logs are exported in TXT, and contain several chunks of #' of information. Importantly, the detections may be saved with a GMT offset, #' as opposed to the more common UTC standard. #' Additionally, the date format isn't the standard yyyy-mm-dd. -#' +#' #' This function extracts the detections from the CDMA file, converts the #' dates to yyyy-mm-dd, binds the time to the date and resets it to UTC, and #' ultimately converts the dataframe into the standard format accepted by actel. @@ -708,51 +708,51 @@ splitSignals <- function(x) { #' sink(dummy_file) #' cat( #' "WHS FSK Receiver Data File -#' -#' Receiver Configuration: +#' +#' Receiver Configuration: #' Working Frequency: 76 KHz #' Bit Rate: 2400 bps #' Code Type: FSK #' Serial Number: WHS3K-1234567 #' Node ID: 10000 -#' +#' #' Receiver Settings: #' GMT Correction: 00:00 -#' +#' #' Decoded Tag Data: #' Date Time TOA Tag ID Type Value Power #' ======================================================================= #' 04/09/24 22:50:03 0.43875 37910 P 9.1 12 #' 08/21/24 12:45:18 0.99646 55606 M 0 1 #' 08/23/24 15:01:04 0.76042 55778 P 0.0 2 -#' +#' #' Receiver Sensor Messages: #' Date Time Sensor Temp Press Battery Tilt-X Tilt-Y Tilt-Z #' ============================================================================= -#' 04/11/24 21:44:00 T / P 1534 0 -#' +#' 04/11/24 21:44:00 T / P 1534 0 +#' #' Receiver Setup Messages: -#' Date Time Type Details +#' Date Time Type Details #' ============================================================================= #' 08/22/24 18:50:11 Change Logging Mode New Mode: SETUP #' ") #' sink() -#' +#' #' # now read it #' x <- convertLotekCDMAFile(dummy_file) -#' +#' #' # the dummy file will be deleted automatically once you close this R session. -#' +#' #' @return A data frame of standardized detections from the input file. #' #' @export #' convertLotekCDMAFile <- function(file, date_format = "%m/%d/%y") { file_raw <- readLines(file) - + serial_n <- file_raw[grep("^Serial Number:", file_raw)] serial_n <- extractSignals(serial_n) - + code_type <- file_raw[grep("^Code Type:", file_raw)] code_type <- sub("Code Type:\\s*", "", code_type) if (code_type == "") { @@ -767,7 +767,7 @@ convertLotekCDMAFile <- function(file, date_format = "%m/%d/%y") { # and the detection headers and then work with them. To find those lines: det_start <- grep("=========", file_raw)[1] det_end <- grep("Receiver Sensor Messages:", file_raw)[1] - 2 - + # To properly parse the columns, we must use the column names, otherwise the # import will fail if any of the columns only has NAs in it. But we must # remove the "===" row before working with it. We must also replace any single @@ -775,13 +775,13 @@ convertLotekCDMAFile <- function(file, date_format = "%m/%d/%y") { det_lines <- file_raw[(det_start-1):det_end] det_lines <- det_lines[-2] # <- the "=====" line det_lines[1] <- stringr::str_replace_all(det_lines[1], - pattern = "(? 1)) - stopAndReport('Override is numeric but there are multiple tags', - 'that match the overridden signal. Use codespace-signal', + stopAndReport('Override is numeric but there are multiple tags', + 'that match the overridden signal. Use codespace-signal', ' overrides instead.') if (any(link <- is.na(match(override, lowest_signals)))) - stopAndReport("Some tags listed in 'override' (", - paste0(override[link], collapse = ", "), + stopAndReport("Some tags listed in 'override' (", + paste0(override[link], collapse = ", "), ") are not listed in the biometrics file.") - } + } else { # new override based on full tag if (any(link <- is.na(match(override, bio$Transmitter)))) - stopAndReport("Some tags listed in 'override' (", - paste0(override[link], collapse = ", "), + stopAndReport("Some tags listed in 'override' (", + paste0(override[link], collapse = ", "), ") are not listed in the biometrics file.") } } deployments <- loadDeployments(input = "deployments.csv", tz = tz) - + # check that receivers are not deployed before being retrieved - checkDeploymentTimes(input = deployments) - + checkDeploymentTimes(input = deployments) + spatial <- loadSpatial(input = "spatial.csv", section.order = section.order) - # match Station.name in the deployments to Station.name in spatial, + # match Station.name in the deployments to Station.name in spatial, # and vice-versa - deployments <- checkDeploymentStations(input = deployments, spatial = spatial) - + deployments <- checkDeploymentStations(input = deployments, spatial = spatial) + # Prepare serial numbers to overwrite the serials in detections - deployments <- createUniqueSerials(input = deployments) + deployments <- createUniqueSerials(input = deployments) - detections <- loadDetections(start.time = start.time, stop.time = stop.time, - tz = tz, save.detections = save.detections, + detections <- loadDetections(start.time = start.time, stop.time = stop.time, + tz = tz, save.detections = save.detections, record.source = TRUE) detections <- checkDupDetections(input = detections) use.fakedot <- TRUE if (file.exists("spatial.dot")) { - appendTo(c("Screen", "Report"), + appendTo(c("Screen", "Report"), paste0("M: A 'spatial.dot' file was detected", ", activating multi-branch analysis.")) - recipient <- loadDot(input = "spatial.dot", spatial = spatial, + recipient <- loadDot(input = "spatial.dot", spatial = spatial, disregard.parallels = disregard.parallels) use.fakedot <- FALSE } if (use.fakedot & file.exists("spatial.txt")) { - appendTo(c("Screen", "Report"), + appendTo(c("Screen", "Report"), paste0("M: A 'spatial.txt' file was detected, activating", " multi-branch analysis.")) - recipient <- loadDot(input = "spatial.txt", spatial = spatial, + recipient <- loadDot(input = "spatial.txt", spatial = spatial, disregard.parallels = disregard.parallels) use.fakedot <- FALSE } if (use.fakedot) { n <- length(unique(spatial$Array[spatial$Type == "Hydrophone"])) if (n > 1) { - fakedot <- paste(unique(spatial$Array[spatial$Type == "Hydrophone"]), + fakedot <- paste(unique(spatial$Array[spatial$Type == "Hydrophone"]), collapse = "--") } else { aux <- unique(spatial$Array[spatial$Type == "Hydrophone"]) fakedot <- paste(aux, "--", aux) } - recipient <- loadDot(string = fakedot, spatial = spatial, + recipient <- loadDot(string = fakedot, spatial = spatial, disregard.parallels = disregard.parallels) } dot <- recipient$dot @@ -147,7 +147,7 @@ loadStudyData <- function(tz, override = NULL, start.time, rm(use.fakedot, recipient) - # Check if there is a logical first array in the study area, should a + # Check if there is a logical first array in the study area, should a # replacement release site need to be created. if (sum(unlist(lapply(arrays, function(a) is.null(a$before)))) == 1) { link <- unlist(lapply(arrays, function(a) is.null(a$before))) @@ -156,39 +156,39 @@ loadStudyData <- function(tz, override = NULL, start.time, first.array <- NULL } # Finish structuring the spatial file - spatial <- transformSpatial(spatial = spatial, bio = bio, arrays = arrays, - dotmat = dotmat, first.array = first.array) - - # Get standardized station and receiver names, check for receivers + spatial <- transformSpatial(spatial = spatial, bio = bio, arrays = arrays, + dotmat = dotmat, first.array = first.array) + + # Get standardized station and receiver names, check for receivers # with no detections - detections <- createStandards(detections = detections, spatial = spatial, - deployments = deployments, - discard.orphans = discard.orphans) - + detections <- createStandards(detections = detections, spatial = spatial, + deployments = deployments, + discard.orphans = discard.orphans) + # Check if there are detections from unknown receivers - checkUnknownReceivers(input = detections) - - appendTo(c("Screen","Report"), - paste0("M: Data time range: ", - as.character(head(detections$Timestamp, 1)), - " to ", as.character(tail(detections$Timestamp, 1)), + checkUnknownReceivers(input = detections) + + appendTo(c("Screen","Report"), + paste0("M: Data time range: ", + as.character(head(detections$Timestamp, 1)), + " to ", as.character(tail(detections$Timestamp, 1)), " (", tz, ").")) - arrays <- liveArrayTimes(arrays = arrays, deployments = deployments, + arrays <- liveArrayTimes(arrays = arrays, deployments = deployments, spatial = spatial) # Reorder arrays object by spatial order link <- match(unlist(spatial$array.order), names(arrays)) - arrays <- arrays[link] + arrays <- arrays[link] rm(link) - + # Load distances and check if they are valid - dist.mat <- loadDistances(spatial = spatial) - + dist.mat <- loadDistances(spatial = spatial) + # Split the detections by tag, store full transmitter names in bio - recipient <- splitDetections(detections = detections, bio = bio, - exclude.tags = exclude.tags) - + recipient <- splitDetections(detections = detections, bio = bio, + exclude.tags = exclude.tags) + detections.list <- recipient$detections.list bio <- recipient$bio if (is.null(detections.list) | is.null(bio)) @@ -196,12 +196,12 @@ loadStudyData <- function(tz, override = NULL, start.time, " (splitDetections). If this error persists,", " contact the developer.") # nocov rm(recipient) - + # Check if there is any data loss due to unknown receivers - recipient <- checkTagsInUnknownReceivers(detections.list = detections.list, + recipient <- checkTagsInUnknownReceivers(detections.list = detections.list, deployments = deployments, - spatial = spatial) - + spatial = spatial) + spatial <- recipient$spatial deployments <- recipient$deployments detections.list <- recipient$detections.list @@ -211,23 +211,23 @@ loadStudyData <- function(tz, override = NULL, start.time, " contact the developer.") # nocov rm(recipient) - detections.list <- checkDetectionsBeforeRelease(input = detections.list, - bio = bio, + detections.list <- checkDetectionsBeforeRelease(input = detections.list, + bio = bio, discard.orphans = discard.orphans) - appendTo(c("Screen", - "Report"), + appendTo(c("Screen", + "Report"), "M: Data successfully imported!") loading.failed <- FALSE - return(list(bio = bio, - deployments = deployments, - spatial = spatial, + return(list(bio = bio, + deployments = deployments, + spatial = spatial, dot = dot, - arrays = arrays, - dotmat = dotmat, + arrays = arrays, + dotmat = dotmat, dist.mat = dist.mat, - detections.list = detections.list, + detections.list = detections.list, paths = paths)) } @@ -243,28 +243,28 @@ loadStudyData <- function(tz, override = NULL, start.time, #' \itemize{ #' \item \code{dot}: A data frame containing the connections between arrays #' \item \code{arrays}: A list containing detailed information on the arrays -#' \item \code{dotmat}: A matrix of the distance (in number of arrays) +#' \item \code{dotmat}: A matrix of the distance (in number of arrays) #' between pairs of arrays #' \item \code{paths}: A list of the all array paths between each pair of arrays. #' } #' #' @keywords internal #' -loadDot <- function(string = NULL, input = NULL, spatial, +loadDot <- function(string = NULL, input = NULL, spatial, disregard.parallels, preloading = FALSE) { appendTo("debug", "Running loadDot.") if (is.null(string) & is.null(input)) stopAndReport("No dot file or dot string were specified.") if (is.null(string)) { tryCatch(dot <- readDot(input = input, silent = TRUE), - error = function(e) stopAndReport("The contents of the '", input, + error = function(e) stopAndReport("The contents of the '", input, "' file could not be recognised", " by the readDot function.")) } else { dot <- readDot(string = string, silent = TRUE) } mat <- dotMatrix(input = dot) - aux <- sapply(spatial$Array, + aux <- sapply(spatial$Array, function(x) { unlist(strsplit(x, "|", fixed = TRUE)) } @@ -281,13 +281,13 @@ loadDot <- function(string = NULL, input = NULL, spatial, if (file.exists("spatial.txt")) { stopAndReport("Not all the arrays listed in the spatial.csv", " file are present in the spatial.txt.", - "\n Missing arrays: ", + "\n Missing arrays: ", paste(unique.arrays[link], collapse = ", "), "\n") } if (file.exists("spatial.dot")) { stopAndReport("Not all the arrays listed in the spatial.csv", " file are present in the spatial.dot.", - "\n Missing arrays: ", + "\n Missing arrays: ", paste(unique.arrays[link], collapse = ", "), "\n") } if (!file.exists("spatial.txt") & !file.exists("spatial.dot")) { @@ -302,21 +302,21 @@ loadDot <- function(string = NULL, input = NULL, spatial, stopAndReport(paste0("Not all arrays listed in the dot input are", " present in the spatial input. The dot input", " should only contain arrays that are listed in", - " spatial.\n Alien arrays: ", + " spatial.\n Alien arrays: ", paste(colnames(mat)[link], collapse = ", "), "\n")) } else { if (file.exists("spatial.txt")) { stopAndReport("Some arrays listed in the spatial.txt file", " are not present in the spatial.csv file. The", " dot input should only contain arrays that are", - " listed in spatial.\n Alien arrays: ", + " listed in spatial.\n Alien arrays: ", paste(colnames(mat)[link], collapse = ", "), "\n") } if (file.exists("spatial.dot")) { stopAndReport("Some arrays listed in the spatial.dot file are", " not present in the spatial.csv file. The dot", " input should only contain arrays that are", - " listed in spatial.\n Alien arrays: ", + " listed in spatial.\n Alien arrays: ", paste(colnames(mat)[link], collapse = ", "), "\n") } if (!file.exists("spatial.txt") & !file.exists("spatial.dot")) { @@ -377,17 +377,17 @@ readDot <- function (input = NULL, string = NULL, silent = FALSE) { } paths <- lines[grepl("[<-][->]", lines)] if (length(paths) == 0) { - stop("Could not recognise the input contents as DOT formatted connections.", + stop("Could not recognise the input contents as DOT formatted connections.", call. = FALSE) } - + # if something looks like a badly formatted connector, complain and stop if (any(grepl("<<|>>|>-|-<|><|<>|<->", paths))) { stop("The input appears to have badly formatted connectors", " ('<<', '>>', '>-', '-<'', '><', '<>' or '<->'). Please fix", " these before continuing.", call. = FALSE) } - + # there's probably a smarter way to do these, but hey, this works. paths <- gsub("[ ]*<-", "<-", paths) paths <- gsub("<-[ ]*", "<-", paths) @@ -399,23 +399,23 @@ readDot <- function (input = NULL, string = NULL, silent = FALSE) { paths <- gsub("\\[label=[^\\]]","", paths) paths <- gsub("^[ ]*", "", paths) paths <- gsub("[ ]*$", "", paths) - + # only spaces left now should be part of array names, and need to be replaced if (any(grepl(" ", paths))) { if (!silent) { - warning("Replacing spaces with '_' in the node names.", + warning("Replacing spaces with '_' in the node names.", immediate. = TRUE, call. = FALSE) } paths <- gsub(" ", "_", paths) } - check <- grepl("\\\\|/|:|\\*|\\?|\\\"|<(?!-)|(?|\\\'", + check <- grepl("\\\\|/|:|\\*|\\?|\\\"|<(?!-)|(?|\\\'", paths, perl = TRUE) if (any(check)) { if (!silent) { warning("Troublesome characters found in the node names (\\/:*?\"<>\').", " Replacing these with '_'.", immediate. = TRUE, call. = FALSE) } - paths <- gsub("\\\\|/|:|\\*|\\?|\\\"|<(?!-)|(?|\\\'", "_", + paths <- gsub("\\\\|/|:|\\*|\\?|\\\"|<(?!-)|(?|\\\'", "_", paths, perl = TRUE) } nodes <- strsplit(paths,"[<-][->]") @@ -426,12 +426,12 @@ readDot <- function (input = NULL, string = NULL, silent = FALSE) { stringsAsFactors = FALSE) for (i in 1:length(nodes)) { n <- length(nodes[[i]]) - escaped_nodes <- gsub(pattern = "([[:punct:]])", + escaped_nodes <- gsub(pattern = "([[:punct:]])", replacement = "\\\\\\1", nodes[[i]]) type <- gsub(paste0(escaped_nodes, collapse = "|"), "", paths[[i]]) aux <- data.frame( A = nodes[[i]][1:(n - 1)], - to = sapply(seq(from = 1, to = nchar(type), by = 2), + to = sapply(seq(from = 1, to = nchar(type), by = 2), function(i) substr(type, i, i + 1)), B = nodes[[i]][2:n], stringsAsFactors = FALSE) @@ -472,8 +472,8 @@ dotMatrix <- function(input) { for (B in nodes) { if (graph[A, B] == i) { # cat(B, "\n") - candidates <- rownames(graph) != B - candidates <- candidates & rownames(graph) != A + candidates <- rownames(graph) != B + candidates <- candidates & rownames(graph) != A candidates <- candidates & graph[B, ] == 1 if (any(candidates)) { to.change <- names(candidates)[candidates] @@ -506,7 +506,7 @@ dotMatrix <- function(input) { dotList <- function(input, spatial) { appendTo("debug", "Running dotList.") - # if there are sections, determine which connections are at the + # if there are sections, determine which connections are at the # edge between sections if (any(grepl("^Section$", colnames(spatial)))) { sections <- levels(spatial$Section) @@ -538,7 +538,7 @@ dotList <- function(input, spatial) { recipient <- list( neighbours = unique(c(auxA$B, auxB$A, names(parallel)[!is.na(parallel)])), before = if (nrow(auxB) == 0) { - NULL + NULL } else { unique(auxB$A) }, @@ -579,12 +579,12 @@ dotPaths <- function(input, disregard.parallels) { for (direction in (c("before", "after"))) { capture <- lapply(names(input), function(a) { link <- paste0(direction, ".peers") - input[[a]][[link]] <<- findPeers(array = a, - array.list = input, - peer.direction = direction, + input[[a]][[link]] <<- findPeers(array = a, + array.list = input, + peer.direction = direction, disregard.parallels = disregard.parallels) - recipient <- findDirectChains(array = a, - array.list = input, + recipient <- findDirectChains(array = a, + array.list = input, direction = direction) input[[a]][[paste0("all.", direction)]] <<- recipient[[1]] input[[a]][[paste0("all.", direction, ".and.par")]] <<- recipient[[2]] @@ -604,8 +604,8 @@ dotPaths <- function(input, disregard.parallels) { #' #' @keywords internal #' -findPeers <- function(array, array.list, - peer.direction = c("before", "after"), +findPeers <- function(array, array.list, + peer.direction = c("before", "after"), disregard.parallels) { peer.direction <- match.arg(peer.direction) opposite.direction <- ifelse(peer.direction == "before", "after", "before") @@ -613,38 +613,38 @@ findPeers <- function(array, array.list, if (length(array) > 1) { stopAndReport("'array' must be of length 1. This error should never", " happen. Contact developer.") # nocov - } + } if (!(array %in% names(array.list))) { stopAndReport(paste0("Requested array does not exist in the array list", - " (findPeers). This error should never happen.", + " (findPeers). This error should never happen.", " Contact developer.")) # nocov - } - + } + # start with nothing - usable.peers <- c() - + usable.peers <- c() + # placeholder just to trigger the start of the while loop - check.results <- c(TRUE, FALSE) - + check.results <- c(TRUE, FALSE) + # round <- 0 # debug counter # cat("Array", array, "-", peer.direction, "peers\n") # debug and testing - + while (any(check.results) & !all(check.results)) { # round <- round + 1 # debug counter # cat("Round", round, "\n") # debug and testing - # Check every array that is not the one we're examining and that has + # Check every array that is not the one we're examining and that has # not been deemed a peer yet. link <- !(names(array.list) %in% c(array, usable.peers)) to.check <- names(array.list)[link] # cat("Checking:", to.check, "\n") # debug and testing - + check.results <- sapply(to.check, function(x) { # only relevant to test if array x is a valid peer if it connects # with anything in the opposite direction. - # e.g. if I have A -- B -- C, A cannot be the "after" peer of anyone, + # e.g. if I have A -- B -- C, A cannot be the "after" peer of anyone, # because nothing comes "before" it. no.connections <- length(array.list[[x]][[opposite.direction]]) == 0 @@ -655,28 +655,28 @@ findPeers <- function(array, array.list, # There are two types of parallels that can cause trouble: # 1) parallels in the array for which we are determining peers (object "array") # 2) parallels in the array we're trying to determine as a valid peer (object "x") - # + # # Type 1 is only an issue if we want to ignore parallel arrays (i.e. disregard.parallels = TRUE) and # the array "array" is right next to the array "x". That will affect the first two components of the check: if (disregard.parallels & array %in% array.list[[x]][[opposite.direction]]) { - # For array x to be a valid peer of the array we're determining peers for (object "array"), - # the max number of connections to array x can only be the sum of the peers we already know + # For array x to be a valid peer of the array we're determining peers for (object "array"), + # the max number of connections to array x can only be the sum of the peers we already know # about, the array "array", and any parallels of the array "array". n_opposites <- length(array.list[[x]][[opposite.direction]]) n_peers <- length(usable.peers) n_par <- length(array.list[[array]]$parallel) too.many.connections <- n_opposites > sum(n_peers, n_par, 1) # Additionally, all the connections to array x must be either the array "array", a parallel - # of the array "array" that shares all connections with array "array", or an array that has + # of the array "array" that shares all connections with array "array", or an array that has # already been determined as a valid peer. - valid.parallels <- sapply(array.list[[array]]$parallel, + valid.parallels <- sapply(array.list[[array]]$parallel, function(parallel) { - all(array.list[[parallel]][[opposite.direction]] %in% + all(array.list[[parallel]][[opposite.direction]] %in% array.list[[array]][[opposite.direction]]) } ) - all.connections.are.valid.peers <- - all(array.list[[x]][[opposite.direction]] %in% + all.connections.are.valid.peers <- + all(array.list[[x]][[opposite.direction]] %in% c(array, names(valid.parallels)[valid.parallels], usable.peers)) } else { # In a situation where either disregard.parallels = FALSE, or the array we're determining @@ -684,7 +684,7 @@ findPeers <- function(array, array.list, # (object "x"), then the nax number of connections to array x can only be the sum of the # peers we already know about plus the array "array". too.many.connections <- length(array.list[[x]][[opposite.direction]]) > sum(length(usable.peers), 1) - # Additionally, all the connections to array x must be either the array "array", or an + # Additionally, all the connections to array x must be either the array "array", or an # array that has already been determined as a valid peer. Note that parallels are not allowed here, # even if disregard.parallels = TRUE. If this ever becomes a point of confusion, find the # drawings in issue #72. @@ -693,7 +693,7 @@ findPeers <- function(array, array.list, if (too.many.connections | !all.connections.are.valid.peers){ return(FALSE) # not worth continuing - } + } # Type 2 is only relevant if disregard.parallels = FALSE. Here, we have to confirm if the # arrays that are parallel to array "x" do not have any third-party connections that are not, @@ -704,13 +704,13 @@ findPeers <- function(array, array.list, # F -- E # E.g. if array "array" is B, in the two checks above, array C will emerge as a potential peer # for B. If we disregard parallels, than that is indeed the case. However, if we do not disregard - # parallels, then array E (a parallel of C) will cause array C to be invalidated, due to the - # connection coming from array F. This wouldn't had been a problem if F were a valid peer + # parallels, then array E (a parallel of C) will cause array C to be invalidated, due to the + # connection coming from array F. This wouldn't had been a problem if F were a valid peer # of "B" (e.g. if B -- F). if (disregard.parallels) { parallels.are.not.an.issue <- TRUE } else { - # So, if disregard.parallels = FALSE, and array x has parallels, we + # So, if disregard.parallels = FALSE, and array x has parallels, we # need to go find which arrays lead to the parallels of array x leading.to.parallels <- unique(unlist(sapply(array.list[[x]]$parallel, function(parallel) array.list[[parallel]][[opposite.direction]]))) # Finally, we verify that only valid peers of array "array" lead to the parallels listed above. @@ -832,18 +832,18 @@ setSpatialStandards <- function(input){ input$Standard.name <- as.character(input$Station.name) input$Standard.name <- gsub(" ", "_", input$Standard.name) link <- input$Type == "Hydrophone" - input$Standard.name[link] <- paste0("St.", + input$Standard.name[link] <- paste0("St.", seq_len(sum(input$Type == "Hydrophone"))) return(input) } #' Load distances matrix #' -#' @param input Either a path to a csv file containing a distances matrix, +#' @param input Either a path to a csv file containing a distances matrix, #' or an R object containing a distances matrix. #' @param spatial A list of spatial objects in the study area. #' -#' @return A matrix of the distances (in metres) between stations +#' @return A matrix of the distances (in metres) between stations #' (if a 'distances.csv' is present) #' #' @keywords internal @@ -854,37 +854,37 @@ loadDistances <- function(input = "distances.csv", spatial) { invalid.dist <- TRUE if (is.character(input)) { if (file.exists(input)) { - appendTo(c("Screen", - "Report"), - paste0("M: File '", + appendTo(c("Screen", + "Report"), + paste0("M: File '", input, "' found, activating speed calculations.")) dist.mat <- as.matrix(read.csv(input, row.names = 1, check.names = FALSE)) if (ncol(dist.mat) == 1) { - warning("Only one column was identified in '", - input, "'. If this seems wrong,", - " please make sure that the values are separated using commas.", - immediate. = TRUE, + warning("Only one column was identified in '", + input, "'. If this seems wrong,", + " please make sure that the values are separated using commas.", + immediate. = TRUE, call. = FALSE) } } else { dist.mat <- NULL } } else { - # Ensure the input is a matrix, + # Ensure the input is a matrix, # in case the user provided the data in a non-base format dist.mat <- as.matrix(input) - } + } if (!is.null(dist.mat)) { rownames(dist.mat) <- gsub(" ", "_", rownames(dist.mat)) colnames(dist.mat) <- gsub(" ", "_", colnames(dist.mat)) invalid.dist <- FALSE if (nrow(dist.mat) != ncol(dist.mat)) { - appendTo(c("Screen", - "Report", - "Warning"), - paste0("The distances matrix appears to be missing data", - " (ncol != nrow). Deactivating speed calculations", + appendTo(c("Screen", + "Report", + "Warning"), + paste0("The distances matrix appears to be missing data", + " (ncol != nrow). Deactivating speed calculations", " to avoid function failure.")) invalid.dist <- TRUE } @@ -1025,7 +1025,7 @@ loadDeployments <- function(input, tz){ if (preloaded & inherits(input$Start, "POSIXct") & inherits(input$Stop, "POSIXct")) { appendTo(c("Screen", "Report"), "M: Preloaded deployment times are already in POSIX format. Skipping timestamp format checks.") - + if (attributes(input$Start)$tz != attributes(input$Stop)$tz) stopAndReport("Deployment Start and Stop times are not in the same time zone (", attributes(input$Start)$tz, " != ", attributes(input$Stop)$tz, ")! Please double-check the deployments.") @@ -1219,15 +1219,15 @@ loadSpatial <- function(input = "spatial.csv", section.order = NULL){ aux <- with(aux, as.data.frame.matrix(table(Array, Section))) sections.per.array <- apply(aux, 1, function(i) sum(i > 0)) if (any(sections.per.array > 1)) { - stopAndReport(ifelse(sum(sections.per.array > 1) == 1, "Array '", "Arrays '"), - paste0(names(sections.per.array)[sections.per.array > 1], collapse = "', '"), - ifelse(sum(sections.per.array > 1) == 1, "' has been", "' have been"), + stopAndReport(ifelse(sum(sections.per.array > 1) == 1, "Array '", "Arrays '"), + paste0(names(sections.per.array)[sections.per.array > 1], collapse = "', '"), + ifelse(sum(sections.per.array > 1) == 1, "' has been", "' have been"), " assigned to more than one section! Each array can only belong to one section. Please correct the spatial input before continuing.") } } else { if (!is.null(section.order)) appendTo(c("Screen", "Report", "Warning"), "'section.order' was set but input has no 'Section' column. Ignoring argument.") - + appendTo(c("Screen", "Report", "Warning"), "The spatial input does not contain a 'Section' column. This input is only valid for explore() analyses.") } # check release arrays exist @@ -1350,7 +1350,7 @@ loadBio <- function(input, tz){ check <- table(bio$Signal) > 1 prefix <- "Signal" } - } + } else { if (any(colnames(bio) == "Code.space")) { aux <- unlist(apply(bio, 1, function(x) { @@ -1369,10 +1369,10 @@ loadBio <- function(input, tz){ stopAndReport(prefix, ifelse(sum(check) > 1, "s ", " "), paste(names(check)[check], collapse = ", "), ifelse(sum(check) > 1," are ", " is "), "duplicated in the biometrics.") # check sensor names - if (!expect_integer) { + if (!expect_integer) { if (!any(grepl("^Sensor\\.unit$", colnames(bio)))) { appendTo(c("Screen", "Warning"), "Tags with multiple sensors are listed in the biometrics, but a 'Sensor.unit' column could not be found. Skipping sensor unit assignment.") - } + } else { bio$Sensor.unit <- as.character(bio$Sensor.unit) # failsafe in case all values are numeric, or NA. bio$Sensor.unit[bio$Sensor.unit == ''] <- NA_character_ @@ -1380,14 +1380,14 @@ loadBio <- function(input, tz){ if (any(link <- na.as.false(startsWith(bio$Sensor.unit, '|')))) appendTo(c('screen', 'warning'), paste0("The Sensor.unit information in ", ifelse(sum(link) <= 10, - paste0("row(s) ", paste0(which(link), collapse = ", ")), + paste0("row(s) ", paste0(which(link), collapse = ", ")), paste0(sum(link), " row(s)")), " of the biometrics starts with a '|' character. Could you have forgotten to include a sensor unit?")) if (any(link <- na.as.false(endsWith(bio$Sensor.unit, '|')))) appendTo(c('screen', 'warning'), paste0("The Sensor.unit information in ", ifelse(sum(link) <= 10, - paste0("row(s) ", paste0(which(link), collapse = ", ")), + paste0("row(s) ", paste0(which(link), collapse = ", ")), paste0(sum(link), " row(s)")), " of the biometrics ends with a '|' character. Could you have forgotten to include a sensor unit?")) @@ -1396,9 +1396,9 @@ loadBio <- function(input, tz){ sensors_per_tag <- sapply(aux, length) if (any(link <- signals_per_tag != sensors_per_tag)) - stopAndReport("The number of provided sensor units does not match the number of signals for ", + stopAndReport("The number of provided sensor units does not match the number of signals for ", ifelse(sum(link) <= 10, - paste0("row(s) ", paste0(which(link), collapse = ", ")), + paste0("row(s) ", paste0(which(link), collapse = ", ")), paste0(sum(link), " row(s)")), " of the biometrics.") } @@ -1410,11 +1410,11 @@ loadBio <- function(input, tz){ bio$Release.site <- "unspecified" } else { bio$Release.site <- gsub(" ", "_", bio$Release.site) - + # replace any weird characters in station names if (any(grepl("\\\\|/|:|\\*|\\?|\\\"|<|>|\\\'", bio$Release.site))) bio$Release.site <- gsub("\\\\|/|:|\\*|\\?|\\\"|<|>|\\\'", "_", bio$Release.site) - + bio$Release.site <- factor(bio$Release.site) if (any(link <- is.na(bio$Release.site) | bio$Release.site == "")) { appendTo(c("Screen","Report","Warning"),"Some animals contain no release site information. You may want to double-check the data.\n Filling the blanks with 'unspecified'.") @@ -1469,7 +1469,7 @@ loadBio <- function(input, tz){ #' #' @keywords internal #' -loadDetections <- function(start.time = NULL, stop.time = NULL, tz, force = FALSE, +loadDetections <- function(start.time = NULL, stop.time = NULL, tz, force = FALSE, save.detections = FALSE, record.source = FALSE) { # NOTE: The variable actel.detections is loaded from a RData file, if present. To avoid package check # notes, the variable name is created before any use. @@ -1529,13 +1529,13 @@ loadDetections <- function(start.time = NULL, stop.time = NULL, tz, force = FALS #' #' @keywords internal #' -compileDetections <- function(path = "detections", start.time = NULL, +compileDetections <- function(path = "detections", start.time = NULL, stop.time = NULL, tz, save.detections = FALSE, record.source = FALSE) { appendTo("Screen", "M: Compiling detections...") # Find the detection files if (file_test("-d", path)) { - file.list <- list.files(path = path, - pattern = "*(\\.[cC][sS][vV]|\\.[vV][rR][lL])", + file.list <- list.files(path = path, + pattern = "*(\\.[cC][sS][vV]|\\.[vV][rR][lL])", full.names = TRUE) if (length(file.list) == 0) { stopAndReport("A 'detections' folder is present but appears to be empty.") @@ -1549,7 +1549,7 @@ compileDetections <- function(path = "detections", start.time = NULL, } } if (file_test("-d", path) & file.exists("detections.csv")) { - appendTo(c("Screen", "Warning", "Report"), + appendTo(c("Screen", "Warning", "Report"), paste0("Both a 'detections' folder and a 'detections.csv' file are ", "present in the current directory.\n", " Loading ONLY the files present in the 'detections' folder.")) @@ -1581,7 +1581,7 @@ compileDetections <- function(path = "detections", start.time = NULL, } file_header <- readLines(i, 1) - + # find the header format that matches the current file file_match <- sapply(header_formats, function(fingerprint) { @@ -1589,7 +1589,7 @@ compileDetections <- function(path = "detections", start.time = NULL, function(i) {grepl(i, file_header)})) }) - # if no matches were found, then warn the + # if no matches were found, then warn the # user that the file won't be processed. if (all(!file_match)) { appendTo(c("Screen", "Report", "Warning"), @@ -1618,11 +1618,11 @@ compileDetections <- function(path = "detections", start.time = NULL, file_type <- names(file_match)[file_match][1] # preliminary load and check of CSV logs - if (file_type %in% + if (file_type %in% c("std", "thelma_new", "thelma_old", "vemco", "innovasea")) { aux <- data.table::fread(i, fill = TRUE, sep = ",", showProgress = FALSE) if(nrow(aux) == 0){ - appendTo(c("Screen", "Report"), + appendTo(c("Screen", "Report"), paste0("File '", i, "' is empty, skipping processing.")) flush.console() return(NULL) # File is empty, skip to next file @@ -1631,7 +1631,7 @@ compileDetections <- function(path = "detections", start.time = NULL, if (file_type == "std") { appendTo("debug", paste0("File '", i, "' matches a Standard log.")) output <- tryCatch( - processStandardFile(input = aux), + processStandardFile(input = aux), error = function(e) { stopAndReport("Something went wrong when processing file '", i, "'. If you are absolutely sure this file is ok, contact the ", @@ -1690,8 +1690,8 @@ compileDetections <- function(path = "detections", start.time = NULL, names(data.files) <- file.list if (any(sapply(data.files, is.null))) { if (sum(sapply(data.files, is.null)) > 1) { - appendTo("Screen", - paste("M:", sum(sapply(data.files, is.null)), + appendTo("Screen", + paste("M:", sum(sapply(data.files, is.null)), "files were excluded from further analyses.")) } else { appendTo("Screen", "M: One file was excluded from further analyses.") @@ -1752,12 +1752,12 @@ processStandardFile <- function(input) { input <- as.data.frame(input, stringsAsFactors = FALSE) time_vec <- fasttime::fastPOSIXct( - sapply(as.character(input$Timestamp), + sapply(as.character(input$Timestamp), function(x) gsub("Z", "", gsub("T", " ", x))), tz = "UTC") output <- data.table::data.table( - Timestamp = time_vec, + Timestamp = time_vec, Receiver = input$Receiver, CodeSpace = input$CodeSpace, Signal = input$Signal) @@ -1860,7 +1860,7 @@ processThelmaNewFile <- function(input) { codespace_vec <- sapply(input$Protocol, function(x) unlist(strsplit(x, "-", fixed = TRUE))[1]) - + output <- data.table::data.table( Timestamp = time_vec, Receiver = input$Receiver, @@ -1914,10 +1914,10 @@ processVemcoFile <- function(input) { input$Sensor.Unit <- rep(NA_character_, nrow(input)) } - std_cols <- c("Timestamp", "Receiver", "CodeSpace", + std_cols <- c("Timestamp", "Receiver", "CodeSpace", "Signal", "Sensor.Value", "Sensor.Unit") input <- input[, std_cols, with = FALSE] - input$Timestamp <- fasttime::fastPOSIXct(as.character(input$Timestamp), + input$Timestamp <- fasttime::fastPOSIXct(as.character(input$Timestamp), tz = "UTC") if (any(is.na(input$Timestamp))) { @@ -1953,20 +1953,20 @@ processInnovaseaFile <- function(input) { transmitter_aux <- strsplit(input$Full.ID, "-", fixed = TRUE) input$CodeSpace <- extractCodeSpaces(input$Full.ID) input$Signal <- extractSignals(input$Full.ID) - - input <- data.table::setnames(input, + + input <- data.table::setnames(input, c("Serial.Number", "Receiver"), c("Device.Time.(UTC)", "Timestamp"), c("Raw.Data", "Sensor.Value")) input$Sensor.Unit <- rep(NA_character_, nrow(input)) - std_cols <- c("Timestamp", "Receiver", "CodeSpace", + std_cols <- c("Timestamp", "Receiver", "CodeSpace", "Signal", "Sensor.Value", "Sensor.Unit") input <- input[, std_cols, with = FALSE] - input$Timestamp <- fasttime::fastPOSIXct(as.character(input$Timestamp), + input$Timestamp <- fasttime::fastPOSIXct(as.character(input$Timestamp), tz = "UTC") - + if (any(is.na(input$Timestamp))) { stop("Importing timestamps failed", call. = FALSE) } @@ -2092,7 +2092,7 @@ createUniqueSerials <- function(input) { #' splitDetections <- function(detections, bio, exclude.tags = NULL) { appendTo("debug", "Running splitDetections.") - + if (file.exists(paste0(tempdir(), "/temp_strays.csv"))) file.remove(paste0(tempdir(), "/temp_strays.csv")) @@ -2132,21 +2132,21 @@ splitDetections <- function(detections, bio, exclude.tags = NULL) { trimmed_list <- lapply(1:nrow(bio_aux), function(i) { # cat(i, "\r") - + # create/reset variable to store the codespace the_codespace <- c() - # This sapply grabs all entries that match the target signal(s) and code space (if relevant) + # This sapply grabs all entries that match the target signal(s) and code space (if relevant) list_matches <- sapply(bio_aux$Signal_expanded[[i]], function(j) { signal_link <- detected$Signal == j - + if (sum(signal_link) == 0) return(NA) - + if (is.na(bio_aux$Code.space[i])) { if (sum(signal_link) > 1) # this should never happen because duplicated signals with no codespaces are handled by checkDupSignals stopAndReport("Something went wrong when splitting the detections. This should not have happened. Contact the developer. (1)") - + the_codespace <<- unique(detected$Code.space[which(signal_link)]) return(which(signal_link)) } else { @@ -2155,9 +2155,9 @@ splitDetections <- function(detections, bio, exclude.tags = NULL) { stopAndReport("Something went wrong when splitting the detections. This should not have happened. Contact the developer. (2)") if (sum(codespace_link) == 0) { - appendTo(c("Screen", "Report", "Warning"), - paste0("Signal ", j, " was found in the detections, but its code space does not match the required ('", - bio_aux$Code.space[i],"' != '", paste0(unique(detected$Code.space[which(signal_link)]), collapse = "', '"), + appendTo(c("Screen", "Report", "Warning"), + paste0("Signal ", j, " was found in the detections, but its code space does not match the required ('", + bio_aux$Code.space[i],"' != '", paste0(unique(detected$Code.space[which(signal_link)]), collapse = "', '"), "').\n Are you sure the code space was written correctly? Discarding detections from alien code space(s).")) return(NA) } else { @@ -2318,11 +2318,11 @@ createStandards <- function(detections, spatial, deployments, discard.orphans = detections$Section <- NA_character_ empty.receivers <- NULL appendTo(c("Screen", "Report"), "M: Matching detections with deployment periods.") - + if (interactive()) pb <- txtProgressBar(min = 0, max = nrow(detections), style = 3, width = 60) # nocov counter <- 0 - + for (i in 1:length(deployments)) { receiver.link <- detections$Receiver == names(deployments)[i] counter <- counter + sum(receiver.link) @@ -2358,12 +2358,12 @@ createStandards <- function(detections, spatial, deployments, discard.orphans = message(paste0(capture.output(print(detections[receiver.link, ][the.error, !c("Transmitter", "Valid", "Standard.name", "Array", "Section")])), collapse = "\n")) message("") message("Possible options:\n a) Stop and double-check the data (recommended)\n b) Discard orphan detections in this instance.\n c) Discard orphan detections for all instances.\n d) Save orphan detections to a file and re-open dialogue.") - + restart <- TRUE while (restart) { if (interactive()) { # nocov start - decision <- userInput("Which option should be followed?(a/b/c/d) ", - choices = letters[1:4], + decision <- userInput("Which option should be followed?(a/b/c/d) ", + choices = letters[1:4], hash = paste("# orphan detections for receiver", names(deployments)[i])) } else { # nocov end decision <- "b" @@ -2371,7 +2371,7 @@ createStandards <- function(detections, spatial, deployments, discard.orphans = if (decision == "a") stopAndReport("Stopping analysis per user command.") # nocov - + if (decision == "b") { detections <- detections[-rows.to.remove] restart <- FALSE @@ -2393,13 +2393,13 @@ createStandards <- function(detections, spatial, deployments, discard.orphans = file.name <- paste0(file.name, ".csv") # prevent auto-overwrite if (file.exists(file.name)) { - aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), - choices = c("y", "n"), + aux <- userInput(paste0("File '", file.name, "' already exists. Overwrite contents?(y/n) "), + choices = c("y", "n"), hash = "# overwrite file with same name?") if (aux == "y") overwrite <- TRUE else - overwrite <- FALSE + overwrite <- FALSE } else overwrite <- TRUE @@ -2433,16 +2433,16 @@ createStandards <- function(detections, spatial, deployments, discard.orphans = } # nocov end appendTo(c("Screen", "Report"), paste0("M: Number of ALS: ", length(deployments), " (of which ", length(empty.receivers), " had no detections)")) - + if (!is.null(empty.receivers)) appendTo(c("Screen", "Report", "Warning"), paste0("No detections were found for receiver(s) ", paste0(empty.receivers, collapse = ", "), ".")) - + detections$Receiver <- as.factor(detections$Receiver) detections$Array <- factor(detections$Array, levels = unlist(spatial$array.order)) - + if (any(grepl("^Section$", colnames(spatial$stations)))) detections$Section <- factor(detections$Section, levels = names(spatial$array.order)) - + detections$Standard.name <- factor(detections$Standard.name, levels = spatial$stations$Standard.name) return(detections) } @@ -2621,15 +2621,15 @@ discardFirst <- function(input, bio, trim) { } #' Assign live times to arrays -#' +#' #' @param arrays The array list #' @param deployments the deployments list #' @param spatial The spatial list -#' +#' #' @return an expanded array list -#' +#' #' @keywords internal -#' +#' liveArrayTimes <- function(arrays, deployments, spatial) { xdep <- do.call(rbind, deployments) capture <- lapply(names(arrays), function(a) { diff --git a/R/migration.R b/R/migration.R index ac96066..8903e65 100644 --- a/R/migration.R +++ b/R/migration.R @@ -7,10 +7,10 @@ #' odd. Multiple options allow you to tweak the analysis to fit your study #' perfectly. #' -#' @param section.order A vector containing the order by which sections should +#' @param section.order A vector containing the order by which sections should #' be aligned in the results. #' @param success.arrays The arrays that mark the end of the study area. If a -#' tag crosses one of these arrays, the respective animal is considered to have +#' tag crosses one of these arrays, the respective animal is considered to have #' successfully migrated through the study area. #' @param if.last.skip.section Logical: Should a tag detected at the last array #' of a given section be considered to have disappeared in the next section? @@ -309,11 +309,11 @@ migration <- function( x <- replicates[[i]] all.stations <- spatial$stations$Standard.name[spatial$stations$Array == i] if (any(link <- !x %in% all.stations)) { - stopAndReport("In replicates: Station", - ifelse(sum(link) > 1, "s ", " "), - paste(x[link], collapse = ", "), - ifelse(sum(link) > 1, " are", " is"), - " not part of ", i, " (available stations: ", + stopAndReport("In replicates: Station", + ifelse(sum(link) > 1, "s ", " "), + paste(x[link], collapse = ", "), + ifelse(sum(link) > 1, " are", " is"), + " not part of ", i, " (available stations: ", paste(all.stations, collapse = ", "), ").") } }) @@ -419,7 +419,7 @@ migration <- function( output <- checkFirstDetBackFromRelease(movements = output, tag = tag, detections = detections.list[[tag]], spatial = spatial, bio = bio, arrays = arrays, GUI = GUI, save.tables.locally = save.tables.locally, n = counter) - output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, + output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, spatial = spatial, dotmat = dotmat, GUI = GUI, save.tables.locally = save.tables.locally) output <- checkJumpDistance(movements = output, bio = bio, tag = tag, dotmat = dotmat, paths = paths, arrays = arrays, @@ -429,8 +429,8 @@ migration <- function( if (do.checkSpeeds) { temp.valid.movements <- simplifyMovements(movements = output, tag = tag, bio = bio, discard.first = discard.first, speed.method = speed.method, dist.mat = dist.mat) - output <- checkSpeeds(movements = output, tag = tag, valid.movements = temp.valid.movements, - detections = detections.list[[tag]], speed.warning = speed.warning, n = counter, + output <- checkSpeeds(movements = output, tag = tag, valid.movements = temp.valid.movements, + detections = detections.list[[tag]], speed.warning = speed.warning, n = counter, speed.error = speed.error, GUI = GUI, save.tables.locally = save.tables.locally) rm(temp.valid.movements) } @@ -464,7 +464,7 @@ migration <- function( aux <- checkMinimumN(movements = aux, tag = tag, min.total.detections = 0, # don't run the minimum total detections check here. min.per.event = min.per.event[2], n = counter) - output <- checkLinearity(secmoves = aux, tag = tag, spatial = spatial, arrays = arrays, + output <- checkLinearity(secmoves = aux, tag = tag, spatial = spatial, arrays = arrays, GUI = GUI, save.tables.locally = save.tables.locally, n = counter) return(output) } else { @@ -484,7 +484,7 @@ migration <- function( appendTo(c("Screen", "Report"), "M: Filtering valid section movements.") - section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial, + section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial, valid.dist = attributes(dist.mat)$valid) appendTo(c("Screen", "Report"), "M: Compiling migration timetable.") @@ -500,7 +500,7 @@ migration <- function( section.overview <- assembleSectionOverview(status.df = status.df, spatial = spatial) - aux <- list(valid.movements = valid.movements, spatial = spatial, + aux <- list(valid.movements = valid.movements, spatial = spatial, rsp.info = list(bio = bio, analysis.type = "migration")) times <- getTimes(input = aux, move.type = "array", event.type = "arrival", n.events = "first") rm(aux) @@ -601,7 +601,7 @@ migration <- function( matrices <- the.matrices # extra info for potential RSP analysis - rsp.info <- list(analysis.type = "migration", analysis.time = the.time, bio = bio, + rsp.info <- list(analysis.type = "migration", analysis.time = the.time, bio = bio, tz = tz, actel.version = utils::packageVersion("actel")) if (!is.null(override)) @@ -623,7 +623,7 @@ migration <- function( } if (interactive()) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), choices = c("y", "n"), hash = "# save results?") } else { # nocov end decision <- "n" @@ -632,12 +632,12 @@ migration <- function( if (decision == "y") { # nocov start appendTo(c("Screen", "Report"), paste0("M: Saving results as '", resultsname, "'.")) if (attributes(dist.mat)$valid) { - save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, - section.movements, status.df, section.overview, group.overview, release.overview, matrices, + save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, + section.movements, status.df, section.overview, group.overview, release.overview, matrices, overall.CJS, intra.array.matrices, intra.array.CJS, times, rsp.info, dist.mat, file = resultsname) } else { - save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, - section.movements, status.df, section.overview, group.overview, release.overview, matrices, + save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, + section.movements, status.df, section.overview, group.overview, release.overview, matrices, overall.CJS, intra.array.matrices, intra.array.CJS, times, rsp.info, file = resultsname) } } else { # nocov end @@ -706,9 +706,9 @@ migration <- function( survival.graph.size <- "width=90%" else survival.graph.size <- "height=4in" if (any(sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))))) { - sensor.plots <- printSensorData(detections = valid.detections, + sensor.plots <- printSensorData(detections = valid.detections, spatial = spatial, - rsp.info = rsp.info, + rsp.info = rsp.info, colour.by = detections.y.axis) } else { sensor.plots <- NULL @@ -718,7 +718,7 @@ migration <- function( # wrap up the txt report appendTo("Report", "M: Analysis completed!\n\n-------------------") - + if (file.exists(paste(tempdir(), "temp_comments.txt", sep = "/"))) appendTo("Report", paste0("User comments:\n-------------------\n", gsub("\t", ": ", gsub("\r", "", readr::read_file(paste(tempdir(), "temp_comments.txt", sep = "/")))), "-------------------")) # nocov @@ -783,7 +783,7 @@ migration <- function( jobname <- paste0(gsub(" |:", ".", as.character(Sys.time())), ".actel.log.txt") if (interactive() & !report) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), choices = c("y", "n"), hash = "# save job log?") } else { # nocov end decision <- "n" @@ -796,19 +796,19 @@ migration <- function( output <- list(detections = detections, valid.detections = valid.detections, spatial = spatial, - deployments = deployments, + deployments = deployments, arrays = arrays, movements = movements, valid.movements = valid.movements, - section.movements = section.movements, + section.movements = section.movements, status.df = status.df, - section.overview = section.overview, + section.overview = section.overview, group.overview = group.overview, - release.overview = release.overview, + release.overview = release.overview, matrices = matrices, - overall.CJS = overall.CJS, + overall.CJS = overall.CJS, intra.array.matrices = intra.array.matrices, - intra.array.CJS = intra.array.CJS, + intra.array.CJS = intra.array.CJS, times = times, rsp.info = rsp.info) @@ -843,7 +843,7 @@ migration <- function( #' printMigrationRmd <- function(override.fragment, biometric.fragment, section.overview, efficiency.fragment, display.progression, array.overview.fragment, survival.graph.size, - individual.plots, circular.plots, sensor.plots, spatial, deployments, valid.detections, + individual.plots, circular.plots, sensor.plots, spatial, deployments, valid.detections, detections, detections.y.axis){ work.path <- paste0(tempdir(), "/actel_report_auxiliary_files/") @@ -1195,7 +1195,7 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, the.row <- match(tag, bio$Transmitter) origin.time <- bio[the.row, "Release.date"] origin.place <- as.character(bio[the.row, "Release.site"]) - + if (origin.time <= aux$First.time[1]) { if (grepl("first$", speed.method)) { diff --git a/R/movements.R b/R/movements.R index 879e220..a7f9d5d 100644 --- a/R/movements.R +++ b/R/movements.R @@ -17,7 +17,7 @@ NULL #' Group movements #' #' Crawls trough the detections of each tag and groups them based on ALS arrays and time requirements. -#' +#' #' @inheritParams move_args #' @inheritParams explore #' @@ -187,7 +187,7 @@ movementSpeeds <- function(movements, speed.method, dist.mat) { capture <- lapply(2:nrow(movements), function(i) { changed_array <- movements$Array[i] != movements$Array[i - 1] neither_unknown <- all(!grep("^Unknown$", movements$Array[(i - 1):i])) - + if (changed_array & neither_unknown) { if (grepl("^first", speed.method)) { time_start <- movements$First.time[i - 1] @@ -351,7 +351,7 @@ sectionMovements <- function(movements, spatial, valid.dist) { # combine object above into single vector event.index <- combine(aux) - + # determine in which array movements the tag changed section aux <- rle(event.index) last.events <- cumsum(aux$lengths) @@ -434,15 +434,15 @@ updateValidity <- function(arrmoves, secmoves) { } #' Wrapper for simplifyMovements -#' +#' #' @inheritParams move_args #' @inheritParams explore #' @param movements A list of movements for each tag. -#' +#' #' @return A list of valid movements -#' +#' #' @keywords internal -#' +#' assembleValidMoves <- function(movements, bio, discard.first, speed.method, dist.mat) { appendTo("debug", "Running assembleValidMoves.") counter <- 0 @@ -450,34 +450,34 @@ assembleValidMoves <- function(movements, bio, discard.first, speed.method, dist pb <- txtProgressBar(min = 0, max = sum(sapply(movements, nrow)), style = 3, width = 60) valid.movements <- lapply(seq_along(movements), function(i) { - output <- simplifyMovements(movements = movements[[i]], tag = names(movements)[i], bio = bio, + output <- simplifyMovements(movements = movements[[i]], tag = names(movements)[i], bio = bio, discard.first = discard.first, speed.method = speed.method, dist.mat = dist.mat) counter <<- counter + nrow(movements[[i]]) if (interactive()) - setTxtProgressBar(pb, counter) + setTxtProgressBar(pb, counter) return(output) }) if (interactive()) close(pb) rm(counter) - + names(valid.movements) <- names(movements) valid.movements <- valid.movements[!unlist(lapply(valid.movements, is.null))] - - return(valid.movements) + + return(valid.movements) } - + #' Wrapper for sectionMovements -#' +#' #' @inheritParams move_args #' @inheritParams explore #' @param valid.moves A list of movements for each tag. -#' +#' #' @return A list of valid movements -#' +#' #' @keywords internal -#' +#' assembleValidSecMoves <- function(valid.moves, spatial, valid.dist) { appendTo("debug", "Running assembleValidSecMoves.") @@ -488,12 +488,12 @@ assembleValidSecMoves <- function(valid.moves, spatial, valid.dist) { secmoves <- lapply(seq_along(valid.moves), function(i) { appendTo("debug", paste0("debug: Compiling valid section movements for tag ", names(valid.moves)[i],".")) - output <- sectionMovements(movements = valid.moves[[i]], spatial = spatial, + output <- sectionMovements(movements = valid.moves[[i]], spatial = spatial, valid.dist = valid.dist) counter <<- counter + nrow(valid.moves[[i]]) if (interactive()) - setTxtProgressBar(pb, counter) + setTxtProgressBar(pb, counter) return(output) }) @@ -501,9 +501,9 @@ assembleValidSecMoves <- function(valid.moves, spatial, valid.dist) { if (interactive()) close(pb) rm(counter) - + names(secmoves) <- names(valid.moves) - - return(secmoves) + + return(secmoves) } diff --git a/R/plot.R b/R/plot.R index 0a5ea2d..a30372a 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,5 +1,5 @@ #' Plot array live times -#' +#' #' @param input An actel results object, or a preload object #' @param arrays Optional: A subset of arrays to be plotted #' @param show.stations Logical: Should the live times of each station be shown under the array bars? @@ -11,7 +11,7 @@ #' @param xlab,ylab Optional axis names for the plot. #' @param col An optional colour scheme for the array bars. If left empty, default colours will be added. #' Note: Station bars are 40% lighter than the array bars. -#' +#' #' @return A ggplot object. #' #' @examples @@ -29,8 +29,8 @@ #' #' @export #' -#' -plotLive <- function(input, arrays, show.stations = FALSE, array.size = 2, station.size = 1, +#' +plotLive <- function(input, arrays, show.stations = FALSE, array.size = 2, station.size = 1, show.caps = TRUE, cap.prop = 2, title = "", xlab = "", ylab = "", col) { value <- NULL Y <- NULL @@ -62,7 +62,7 @@ plotLive <- function(input, arrays, show.stations = FALSE, array.size = 2, stati warning("This dataset contains unknown stations. These stations will not be plotted.", immediate. = TRUE, call. = FALSE) xdep <- xdep[xdep$Array != "Unknown", ] } - + # prepare input if (show.stations) { xdep$line <- 1:nrow(xdep) @@ -148,10 +148,10 @@ plotLive <- function(input, arrays, show.stations = FALSE, array.size = 2, stati p <- ggplot2::ggplot(data = pd, ggplot2::aes(x = value, y = Y, group = line)) # place holder just to set the Y in order p <- p + ggplot2::geom_path() - + a <- pd[pd$Array == pd$Y, ] p <- p + ggplot2::geom_path(data = a, ggplot2::aes(col = Section), linewidth = a$Size) - + if (show.stations) { s <- pd[pd$Array != pd$Y, ] p <- p + ggplot2::geom_path(data = s, col = s$col, linewidth = s$Size) @@ -203,7 +203,7 @@ plotLive <- function(input, arrays, show.stations = FALSE, array.size = 2, stati #' #' @export #' -plotSensors <- function(input, tag, sensor, title = tag, xlab, ylab, pcol, psize = 1, lsize = 0.5, +plotSensors <- function(input, tag, sensor, title = tag, xlab, ylab, pcol, psize = 1, lsize = 0.5, colour.by = c("array", "section"), array.alias, lcol = "grey40", verbose = TRUE) { Timestamp <- NULL Sensor.Value <- NULL @@ -228,7 +228,7 @@ plotSensors <- function(input, tag, sensor, title = tag, xlab, ylab, pcol, psize if (length(lcol) > 1) stop("Please provide only one value for 'lcol'.", call. = FALSE) - + detections <- input$valid.detections[[tag]] spatial <- input$spatial @@ -305,7 +305,7 @@ plotSensors <- function(input, tag, sensor, title = tag, xlab, ylab, pcol, psize } #' Plot simultaneous/cumulative presences at a give array or set of arrays -#' +#' #' @param input The results of an actel analysis (either explore, migration or residency). #' @param arrays One or more arrays to be analysed. If multiple arrays are provided, data will be grouped. #' @param title An optional title for the plot. @@ -333,12 +333,12 @@ plotSensors <- function(input, tag, sensor, title = tag, xlab, ylab, pcol, psize #' p #' #' # You can also save the plot using ggsave! -#' +#' #' @export -#' +#' plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = TRUE, y.style = c("absolute", "relative"), type = c("default", "bars", "lines"), timestep = c("days", "hours", "mins"), cumulative = FALSE, ladder.type = c("arrival", "departure")) { - + cbPalette <- c("#56B4E9", "#E69F00", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#999999") names(cbPalette) <- c("Blue", "Orange", "Green", "Yellow", "Darkblue", "Darkorange", "Pink", "Grey") @@ -372,7 +372,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = stop("Could not find array(s) '", paste(arrays[link], collapse = "', '"), "' in the study area.", call. = FALSE) n.groups <- length(unique(input$status.df$Group)) - + if (missing(col)) { if (by.group) { if (n.groups < 8) @@ -388,7 +388,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = if (by.group) { if (length(col) != n.groups) stop("The number of colours provided does not match the number of groups in the analysis.", call. = FALSE) - names(col) <- unique(input$status.df$Group) + names(col) <- unique(input$status.df$Group) } else { col <- col[1] names(col) <- "All" @@ -403,7 +403,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = if (ladder.type == "arrival") title <- paste(paste(arrays, collapse = "|"), "- Cumulative arrivals") else - title <- paste(paste(arrays, collapse = "|"), "- Cumulative departures") + title <- paste(paste(arrays, collapse = "|"), "- Cumulative departures") } else title <- paste(paste(arrays, collapse = "|"), "- Simultaneous presence") @@ -411,7 +411,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = # extract information as well as time ranges first.time <- as.POSIXct(NA)[-1] - last.time <- as.POSIXct(NA)[-1] + last.time <- as.POSIXct(NA)[-1] plot.list <- lapply(names(input$valid.movements), function(tag) { # cat(tag, "\n") @@ -428,7 +428,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = if (as.POSIXlt(output$Last.time[1])$isdst == 1) output$Last.time <- output$Last.time + 3600 - + last.time <<- c(last.time, output$Last.time[nrow(output)]) first.time <<- c(first.time, output$First.time[1]) return(output) @@ -448,7 +448,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = last.time <- max(last.time) first.time <- min(first.time) - + if (timestep == "days") seconds <- 3600 * 24 @@ -458,7 +458,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = if (timestep == "mins") seconds <- 60 - timerange <- seq(from = first.time, to = last.time, by = seconds) + timerange <- seq(from = first.time, to = last.time, by = seconds) if (is.null(first.time) | is.null(last.time)) stop("Not enough valid data to draw a plot. Aborting.", call. = FALSE) @@ -466,7 +466,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = if (by.group) { link <- match(names(plot.list), input$status.df$Transmitter) group.names <- input$status.df$Group[link] - + plotdata <- lapply(unique(group.names), function(the.group) { # cat("Group: ", as.character(the.group), "\n") @@ -563,7 +563,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = return(x) }) } - + plotdata <- data.table::rbindlist(recipient) if (missing(xlab)) @@ -600,7 +600,7 @@ plotArray <- function(input, arrays, title, xlab, ylab, lwd = 1, col, by.group = } #' Plot moves for one ore more tags -#' +#' #' The output of plotMoves is a ggplot object, which means you can then use it in combination #' with other ggplot functions, or even together with other packages such as patchwork. #' @@ -768,11 +768,11 @@ plotMoves <- function(input, tags, title, xlab, ylab, col, array.alias, show.rel #' default section names with user defined ones. #' @param frame.warning Logical. By default, actel highlights manually changed or overridden tags in yellow #' and red plot frames, respectively. Set to FALSE to deactivate this behaviour. -#' @param x.label.format A character string giving a date-time format for the x labels. +#' @param x.label.format A character string giving a date-time format for the x labels. #' If missing, ggplot's default labels are used. #' @param only.valid Logical. Should only valid detections be printed? #' @param like.migration Logical. For plots originating from migration analyses, should the additional -#' grey vertical bars be included? Defaults to TRUE, and only has a visible effect if the input stems from +#' grey vertical bars be included? Defaults to TRUE, and only has a visible effect if the input stems from #' a migration analysis. #' #' @return A ggplot object. @@ -792,7 +792,7 @@ plotMoves <- function(input, tags, title, xlab, ylab, col, array.alias, show.rel #' #' @export #' -plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arrays"), title, +plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arrays"), title, xlab, ylab, col, array.alias, section.alias, frame.warning = TRUE, x.label.format, only.valid = FALSE, like.migration = TRUE) { # NOTE: The NULL variables below are actually column names used by ggplot. @@ -819,7 +819,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr if (length(tag) > 1) stop("Please list only one tag", call. = FALSE) - + if (is.na(match(tag, names(input$detections)))) stop("Could not find tag '", tag, "' in the input.", call. = FALSE) @@ -852,7 +852,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr else y.axis <- "stations" } - + # renaming arrays if relevant if (!missing(array.alias)) { # check if any arrays are alien @@ -925,7 +925,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr # assign y values if (y.axis == "stations") - detections$plot.y <- factor(detections$Standard.name, levels = y.order) + detections$plot.y <- factor(detections$Standard.name, levels = y.order) else detections$plot.y <- factor(detections$Array, levels = y.order) @@ -934,7 +934,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr detections$Colour <- detections$Array if (!missing(section.alias)) warning("section.alias is irrelevant when y.axis = 'stations'. Ignoring section.alias.", immediate. = TRUE, call. = FALSE) - } else { + } else { aux <- lapply(seq_along(array.order$Array), function(i) { x <- match(detections$plot.y, array.order$Array[i]) x[!is.na(x)] <- array.order$Section[i] @@ -949,7 +949,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr section.levels <- unique(array.order$Section) detections$Colour <- factor(aux, levels = section.levels) - + # Rename sections, if relevant if (!missing(section.alias)) { link <- match(names(section.alias), section.levels) @@ -957,7 +957,7 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr warning("Could not find ", ifelse(sum(is.na(link) == 1), "section ", "sections "), names(section.alias)[is.na(link)], " in the study's sections.", call. = FALSE, immediate. = TRUE) levels(detections$Colour)[link[!is.na(link)]] <- section.alias[!is.na(link)] section.levels <- levels(detections$Colour) - + if (any(is.na(detections$Colour))) { warning("Suppressing ", !is.na(detections$Colour), " detection(s) as the respective sections were suppressed.", immediate. = TRUE, call. = FALSE) detections <- detections[!is.na(detections$Colour), ] @@ -1156,9 +1156,9 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr #' @param ylegend Adjustment to the vertical positioning of the legend. Only relevant if the legend is being drawn #' in the corner of the plot. #' @param xlegend Adjustment to the horizontal positioning of the legend. -#' @param xjust How the legend is to be justified when the legend is drawn at the bottom a the plot. +#' @param xjust How the legend is to be justified when the legend is drawn at the bottom a the plot. #' One of 'auto' (i.e. let actel decide the best adjustment), 'left', 'centre', or 'right'. -#' @param cex A numerical vector giving the amount by which plotting characters and symbols should be scaled +#' @param cex A numerical vector giving the amount by which plotting characters and symbols should be scaled #' relative to the default. When saving the plot in a vectorial form, it is recommended to change the height #' and width arguments rather than the cex. #' @param expand Parameter that controls the size of the plotted circle. Defaults to 0.95. Larger values expand the circle, while smaller values shrink the circle. @@ -1179,8 +1179,8 @@ plotDetections <- function(input, tag, type, y.axis = c("auto", "stations", "arr #' @export #' plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), col, alpha = 0.8, title = "", mean.dash = TRUE, - mean.range = TRUE, mean.range.darken.factor = 1.4, rings = TRUE, file, width, height, bg = "transparent", ncol, - legend.pos = c("auto", "corner", "bottom"), ylegend, xlegend, xjust = c("auto", "centre", "left", "right"), + mean.range = TRUE, mean.range.darken.factor = 1.4, rings = TRUE, file, width, height, bg = "transparent", ncol, + legend.pos = c("auto", "corner", "bottom"), ylegend, xlegend, xjust = c("auto", "centre", "left", "right"), expand = 0.95, cex = 1){ legend.pos <- match.arg(legend.pos) @@ -1319,11 +1319,11 @@ plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), if (missing(file) || (grepl("\\.svg$", file) | grepl("\\.pdf", file))) ylegend <- -0.97 + (0.08 * (ceiling(length(times) / ncol) - 2)) } else { - ylegend <- -0.97 + ylegend <- -0.97 } } if (xjust != "auto") - warning("'xjust' was set but legend is being plotted in the corner. Ignoring 'xjust'.", immediate. = TRUE, call. = FALSE) + warning("'xjust' was set but legend is being plotted in the corner. Ignoring 'xjust'.", immediate. = TRUE, call. = FALSE) xjust <- "left" } else { if (missing(ylegend)) @@ -1347,7 +1347,7 @@ plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), if (missing(xlegend)) xlegend <- 0 } - + if (xjust == "right") { xjust <- 1 if (missing(xlegend)) @@ -1370,7 +1370,7 @@ plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), horizontal.mar <- vertical.mar * area.prop oldpar <- par(mar = c(b, horizontal.mar / 2, 2, horizontal.mar / 2), cex = cex, xpd = TRUE) # bottom, left, top, right - # resetting the par is only necessary if no file was specified, + # resetting the par is only necessary if no file was specified, # and thus dev.off() was not called at the end of the function. on.exit(if (missing(file)) par(oldpar), add = TRUE) @@ -1387,8 +1387,8 @@ plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), if (mean.dash) { roseMean(times, col = scales::alpha(params$col, 1), mean.length = c(0.07, -0.07), mean.lwd = 6, - box.range = ifelse(mean.range, "std.error", "none"), fill = "white", horizontal.border = "black", - vertical.border = scales::alpha(sapply(params$col, function(i) darken(i, mean.range.darken.factor)), 1), box.size = c(1.015, 0.985), + box.range = ifelse(mean.range, "std.error", "none"), fill = "white", horizontal.border = "black", + vertical.border = scales::alpha(sapply(params$col, function(i) darken(i, mean.range.darken.factor)), 1), box.size = c(1.015, 0.985), edge.length = c(0.025, -0.025), edge.lwd = 2) } @@ -1404,7 +1404,7 @@ plotTimes <- function(times, night = NULL, circular.scale = c("area", "linear"), if(!missing(file)) message("M: Plot saved to ", file) - # graphics device is turned off by on.exit set up + # graphics device is turned off by on.exit set up # right after the device was opened. } @@ -1688,7 +1688,7 @@ plotResidency <- function(input, tag, title, xlab, ylab, col) { if (length(tag) > 1) stop("Please list only one tag", call. = FALSE) - + if (is.na(match(tag, names(input$time.ratios)))) stop("Could not find tag '", tag, "' in the input.", call. = FALSE) @@ -1770,9 +1770,9 @@ plotResidency <- function(input, tag, title, xlab, ylab, col) { #' #' By default, this function plots the global residency. However, you can use the argument 'group' #' to plot the results only from a specific animal group. Lastly, you can also use 'sections', rather -#' than 'group', to compare the residency at a specific section (or group of sections) between the +#' than 'group', to compare the residency at a specific section (or group of sections) between the #' different groups. -#' +#' #' The output of plotRatios is a ggplot object, which means you can then use it in combination #' with other ggplot functions, or even together with other packages such as patchwork. #' @@ -1808,11 +1808,11 @@ plotResidency <- function(input, tag, title, xlab, ylab, col) { #' #' @export #' -plotRatios <- function(input, groups, sections, - type = c("absolutes", "percentages"), +plotRatios <- function(input, groups, sections, + type = c("absolutes", "percentages"), title, xlab, ylab, col, col.by = c("default", "section", "group")) { # NOTE: The NULL variables below are actually column names used by ggplot. - # This definition is just to prevent the package check from issuing a + # This definition is just to prevent the package check from issuing a # note due unknown variables. type <- match.arg(type) col.by <- match.arg(col.by) @@ -1821,9 +1821,9 @@ plotRatios <- function(input, groups, sections, Group <- NULL n <- NULL - cbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", + cbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#999999") - names(cbPalette) <- c("Orange", "Blue", "Green", "Yellow", "Darkblue", + names(cbPalette) <- c("Orange", "Blue", "Green", "Yellow", "Darkblue", "Darkorange", "Pink", "Grey") if (!inherits(input, "list")) { @@ -1854,20 +1854,20 @@ plotRatios <- function(input, groups, sections, if (missing(sections)) { title <- "Global ratios" } else { - title <- paste0("Ratios for section", - ifelse(length(sections) > 1, "s ", " "), + title <- paste0("Ratios for section", + ifelse(length(sections) > 1, "s ", " "), paste0(sections, collapse = ", ")) } } else { if (missing(sections)) { - title <- paste0("Ratios for group", - ifelse(length(groups) > 1, "s ", " "), + title <- paste0("Ratios for group", + ifelse(length(groups) > 1, "s ", " "), paste0(groups, collapse = ", ")) } else { - title <- paste0("Ratios for group", - ifelse(length(groups) > 1, "s ", " "), - paste0(groups, collapse = ", "), - " in section", ifelse(length(sections) > 1, "s ", " "), + title <- paste0("Ratios for group", + ifelse(length(groups) > 1, "s ", " "), + paste0(groups, collapse = ", "), + " in section", ifelse(length(sections) > 1, "s ", " "), paste0(sections, collapse = ", ")) } } @@ -1876,8 +1876,8 @@ plotRatios <- function(input, groups, sections, if (!missing(groups)) { link <- is.na(match(groups, names(input$group.ratios))) if (any(link)) { - stop("Could not find group(s) '", - paste(groups[link], collapse = "', '") , + stop("Could not find group(s) '", + paste(groups[link], collapse = "', '") , "' in the input.", call. = FALSE) } } else { @@ -1887,9 +1887,9 @@ plotRatios <- function(input, groups, sections, if (!missing(sections)) { link <- any(is.na(match(sections, colnames(input$global.ratios$absolutes)))) if (link) { - stop("Section", ifelse(sum(link) > 1, "s '", " '"), + stop("Section", ifelse(sum(link) > 1, "s '", " '"), paste0(sections[link], collapse = "', '"), - ifelse(sum(link) > 1, "' do ", "' does "), + ifelse(sum(link) > 1, "' do ", "' does "), "not exist, or no tags have ever been assigned to it.", call. = FALSE) } } else { @@ -1935,13 +1935,13 @@ plotRatios <- function(input, groups, sections, # remove groups that were never detected before continuing aux <- aux[sapply(aux, length) > 0] - + if (col.by == 'group') { the.ratios <- aux[[1]][, c('Timeslot', 'n')] colnames(the.ratios)[2] <- aux[[1]]$Group[1] # add other groups as new columns if there are any if (length(aux) > 1) { - for (i in 2:length(aux)) { + for (i in 2:length(aux)) { the.ratios[, ncol(the.ratios) + 1] <- aux[[i]]$n colnames(the.ratios)[ncol(the.ratios)] <- aux[[i]]$Group[1] } @@ -1971,7 +1971,7 @@ plotRatios <- function(input, groups, sections, the.ratios[r, 2:(ncol(the.ratios))] <- a / b } } - rm(r) + rm(r) } if (missing(xlab)) { @@ -2014,8 +2014,8 @@ plotRatios <- function(input, groups, sections, } else { if (col.by == 'group') { if (length(col) < length(groups)) { - warning("Not enough colours supplied in 'col' (", - length(col)," supplied and ", length(groups), + warning("Not enough colours supplied in 'col' (", + length(col)," supplied and ", length(groups), " needed). Reusing colours.", immediate. = TRUE, call. = FALSE) } unique.colours <- rep(col, length.out = length(groups)) @@ -2030,17 +2030,17 @@ plotRatios <- function(input, groups, sections, } if (col.by == 'group') { - p <- ggplot2::ggplot(data = plotdata, + p <- ggplot2::ggplot(data = plotdata, ggplot2::aes(x = Timeslot, y = n, fill = Group, col = Group)) } else { - p <- ggplot2::ggplot(data = plotdata, + p <- ggplot2::ggplot(data = plotdata, ggplot2::aes(x = Timeslot, y = n, fill = Location, col = Location)) } if (attributes(input$global.ratios[[1]])$timestep == "days") { bar_width <- 86400 } else { - bar_width <- 3600 + bar_width <- 3600 } p <- p + ggplot2::geom_bar(width = bar_width, stat = "identity") @@ -2048,7 +2048,7 @@ plotRatios <- function(input, groups, sections, max.y <- max(with(plotdata, aggregate(n, list(Timeslot), sum))$x) if (type == "absolutes") { - p <- p + ggplot2::scale_y_continuous(limits = c(0, max.y * 1.05), + p <- p + ggplot2::scale_y_continuous(limits = c(0, max.y * 1.05), expand = c(0, 0)) } else { p <- p + ggplot2::scale_y_continuous(limits = c(0, max.y), @@ -2072,7 +2072,7 @@ plotRatios <- function(input, groups, sections, #' Plot DOT diagram -#' +#' #' This function is useful for quickly checking if your spatial.txt file is #' properly set up. The spatial.txt file can be imported using [readDot()] #' @@ -2080,7 +2080,7 @@ plotRatios <- function(input, groups, sections, #' to a dot data frame using [readDot()]. #' @param spatial a data frame containing stations and respective coordinates. #' Note: The mean coordinates for the stations of any given array will be used. -#' @param coord.x,coord.y The names of the columns containing the x and y +#' @param coord.x,coord.y The names of the columns containing the x and y #' positions of the stations in the spatial data frame. #' @param placement Two possible options: "literal" will place the nodes exactly #' at the average coordinates for the array (which may lead to varying degrees @@ -2107,7 +2107,7 @@ plotRatios <- function(input, groups, sections, #' #' # now we can plot it using plotDot: #' plotDot(my_dot) -#' +#' #' # plotDot can also be called directly using the string of text: #' plotDot(x) #' @@ -2115,7 +2115,7 @@ plotRatios <- function(input, groups, sections, #' #' @export #' -plotDot <- function(dot, spatial, coord.x, coord.y, +plotDot <- function(dot, spatial, coord.x, coord.y, placement = c("literal", "spaced"), expand = 1, file, fill = c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7"), text_colour = "white") { @@ -2159,7 +2159,7 @@ plotDot <- function(dot, spatial, coord.x, coord.y, stop("spatial was provided, but coord.x and/or coord.y are missing.", call. = FALSE) } - + if (!any(colnames(spatial) == coord.x)) { stop("Could not find column '", coord.x, "' in spatial.", call. = FALSE) } @@ -2170,7 +2170,7 @@ plotDot <- function(dot, spatial, coord.x, coord.y, # Use only the hydrophone lines spatial <- spatial[spatial$Type == "Hydrophone", ] - + if (any(is.na(match(unique_arrays, unique(spatial$Array))))) { stop("spatial was provided, but not all arrays specified ", "in the dot exist in spatial.", call. = FALSE) @@ -2183,11 +2183,11 @@ plotDot <- function(dot, spatial, coord.x, coord.y, xspatial <- spatial[!is.na(match(spatial$Array, unique_arrays)), ] - dot_coords <- aggregate(xspatial[, c(coord.x, coord.y)], + dot_coords <- aggregate(xspatial[, c(coord.x, coord.y)], list(xspatial$Array), mean) colnames(dot_coords) <- c("Array", "x", "y") - # make sure both are in the same row order, + # make sure both are in the same row order, # to simplify transferring the data further down. fix_row_order <- match(diagram_nodes$label, dot_coords$Array) dot_coords <- dot_coords[fix_row_order, ] @@ -2195,7 +2195,7 @@ plotDot <- function(dot, spatial, coord.x, coord.y, # make coords start at 0 to simplify the plotting dot_coords$x <- dot_coords$x - min(dot_coords$x) dot_coords$y <- dot_coords$y - min(dot_coords$y) - + if (placement == "spaced") { diagram_nodes$x[order(dot_coords$x)] <- (1:nrow(dot_coords) - 1) * expand diagram_nodes$y[order(dot_coords$y)] <- (1:nrow(dot_coords) - 1) * expand @@ -2242,7 +2242,7 @@ plotDot <- function(dot, spatial, coord.x, coord.y, diagram_edges <- NULL add_line_details <- FALSE } else { - diagram_edges <- apply(dot[, c(1, 3), drop = FALSE], 2, + diagram_edges <- apply(dot[, c(1, 3), drop = FALSE], 2, function(x) { match(x, diagram_nodes$label) }) diff --git a/R/preload.R b/R/preload.R index 5365dec..58f433a 100644 --- a/R/preload.R +++ b/R/preload.R @@ -80,17 +80,17 @@ preload <- function(biometrics, spatial, deployments, detections, dot = NULL, the.function.call <- paste0("preload(biometrics = ", deparse(substitute(biometrics)), ", spatial = ", deparse(substitute(spatial)), - ", deployments = ", deparse(substitute(deployments)), - ", detections = ", deparse(substitute(detections)), - ", dot = ", ifelse(is.null(dot), "NULL", deparse(substitute(dot))), - ", distances = ", ifelse(is.null(distances), "NULL", + ", deployments = ", deparse(substitute(deployments)), + ", detections = ", deparse(substitute(detections)), + ", dot = ", ifelse(is.null(dot), "NULL", deparse(substitute(dot))), + ", distances = ", ifelse(is.null(distances), "NULL", deparse(substitute(distances))), - ", tz = '", tz, "'", + ", tz = '", tz, "'", ", start.time = ", ifelse(is.null(start.time), "NULL", paste0("'", start.time, "'")), ", stop.time = ", ifelse(is.null(stop.time), "NULL", paste0("'", stop.time, "'")), - ", section.order = ", ifelse(is.null(section.order), "NULL", + ", section.order = ", ifelse(is.null(section.order), "NULL", paste0("c('", paste(section.order, collapse = "', '"), "')")), ", exclude.tags = ", ifelse(is.null(exclude.tags), "NULL", paste0("c('", paste(exclude.tags, collapse = "', '"), "')")), @@ -152,13 +152,13 @@ preload <- function(biometrics, spatial, deployments, detections, dot = NULL, disregard.parallels = disregard.parallels, preloading = TRUE) } else { - if (!is.character(dot)) { - stop("'dot' was set but could not recognised as a string. ", + if (!is.character(dot)) { + stop("'dot' was set but could not recognised as a string. ", "Please prepare a dot string and include it in the dot argument.\n", "You can use readDot to check the quality of your dot string.", call. = FALSE) } else { - recipient <- loadDot(string = dot, spatial = spatial, + recipient <- loadDot(string = dot, spatial = spatial, disregard.parallels = disregard.parallels, preloading = TRUE) } @@ -208,11 +208,11 @@ preload <- function(biometrics, spatial, deployments, detections, dot = NULL, rm(link) if (is.null(distances)) { - dist.mat <- NA + dist.mat <- NA attributes(dist.mat)$valid <- FALSE } else { # Load distances and check if they are valid - dist.mat <- loadDistances(input = distances, spatial = spatial) + dist.mat <- loadDistances(input = distances, spatial = spatial) } # Split the detections by tag, store full transmitter names in bio @@ -250,27 +250,27 @@ preload <- function(biometrics, spatial, deployments, detections, dot = NULL, detections.list = detections.list, paths = paths, disregard.parallels = disregard.parallels, tz = tz) - # create actel token - actel.token <- stringi::stri_rand_strings(1, 10) - timestamp <- as.character(Sys.time()) + # create actel token + actel.token <- stringi::stri_rand_strings(1, 10) + timestamp <- as.character(Sys.time()) - key <- data.frame(Token = actel.token, Timestamp = timestamp) + key <- data.frame(Token = actel.token, Timestamp = timestamp) - # save token - write.table(key, paste0(tempdir(), "/actel_token_list.csv"), sep = ",", - append = file.exists(paste0(tempdir(), "/actel_token_list.csv")), - col.names = !file.exists(paste0(tempdir(), "/actel_token_list.csv")), - row.names = FALSE) + # save token + write.table(key, paste0(tempdir(), "/actel_token_list.csv"), sep = ",", + append = file.exists(paste0(tempdir(), "/actel_token_list.csv")), + col.names = !file.exists(paste0(tempdir(), "/actel_token_list.csv")), + row.names = FALSE) - # stamp the output - attributes(output)$actel.token <- actel.token - attributes(output)$timestamp <- timestamp + # stamp the output + attributes(output)$actel.token <- actel.token + attributes(output)$timestamp <- timestamp # carbon copy report messages attributes(output)$loading_messages <- readLines(paste0(tempdir(), "/temp_log.txt")) attributes(output)$function_call <- the.function.call - return(output) + return(output) } @@ -284,19 +284,19 @@ preload <- function(biometrics, spatial, deployments, detections, dot = NULL, #' @keywords internal #' preloadDetections <- function(input, tz, start.time = NULL, stop.time = NULL) { - mandatory.cols <- c("Timestamp", "Receiver", "CodeSpace", "Signal") + mandatory.cols <- c("Timestamp", "Receiver", "CodeSpace", "Signal") - if (any(link <- is.na(match(mandatory.cols, colnames(input))))) { - if (any(is.na(match(mandatory.cols[3:4], colnames(input))))) { - also.say <- paste0("\nThe functions extractSignals and ", + if (any(link <- is.na(match(mandatory.cols, colnames(input))))) { + if (any(is.na(match(mandatory.cols[3:4], colnames(input))))) { + also.say <- paste0("\nThe functions extractSignals and ", "extractCodeSpaces can be used to break transmitter codes apart.") } else { - also.say <- "" + also.say <- "" } - stop("The following mandatory columns are missing in the detections: ", + stop("The following mandatory columns are missing in the detections: ", paste(mandatory.cols[link], collapse = ", "), also.say, call. = FALSE) - } + } link <- apply(input[, mandatory.cols], 2, function(i) any(is.na(i))) if (any(link)) { @@ -305,90 +305,90 @@ preloadDetections <- function(input, tz, start.time = NULL, stop.time = NULL) { call. = FALSE) } - if (!is.integer(input$Signal)) { - appendTo(c("Screen", "Warning", "Report"), + if (!is.integer(input$Signal)) { + appendTo(c("Screen", "Warning", "Report"), paste0("The 'Signal' column in the detections is not of type integer. ", "Attempting to convert.")) - input$Signal <- tryCatch(as.integer(input$Signal), - warning = function(w) { + input$Signal <- tryCatch(as.integer(input$Signal), + warning = function(w) { stop("Attempting to convert the 'Signal' to integer failed. Aborting.", call. = FALSE) }) - } + } - if (!is.integer(input$Receiver)) { - appendTo(c("Screen", "Warning", "Report"), + if (!is.integer(input$Receiver)) { + appendTo(c("Screen", "Warning", "Report"), paste0("The 'Receiver' column in the detections is not of type ", "integer. Attempting to convert.")) - aux <- tryCatch(as.integer(input$Receiver), - warning = function(w) { - appendTo(c("Screen", "Warning", "Report"), + aux <- tryCatch(as.integer(input$Receiver), + warning = function(w) { + appendTo(c("Screen", "Warning", "Report"), paste0("Attempting to convert the 'Receiver' to integer failed. ", "Attempting to extract only the serial numbers.")) - return(NULL) }) + return(NULL) }) - if (is.null(aux)) { + if (is.null(aux)) { # extractSignals works for extracting only the receiver numbers too - aux <- tryCatch(extractSignals(input$Receiver), - warning = function(w) { + aux <- tryCatch(extractSignals(input$Receiver), + warning = function(w) { stop("Extracting the serial numbers failed. Aborting.", call. = FALSE) }) - } - input$Receiver <- aux - } + } + input$Receiver <- aux + } if (!is.character(input$CodeSpace)) input$CodeSpace <- as.character(input$CodeSpace) - if (length(the.col <- grep("^[S|s]ensor\\.[U|u]nit$", colnames(input))) > 0) - colnames(input)[the.col] <- "Sensor.Unit" + if (length(the.col <- grep("^[S|s]ensor\\.[U|u]nit$", colnames(input))) > 0) + colnames(input)[the.col] <- "Sensor.Unit" - if (length(the.col <- grep("^[S|s]ensor\\.[V|v]alue$", colnames(input))) > 0) - colnames(input)[the.col] <- "Sensor.Value" - - if (!any(grepl("^Sensor\\.Value$", colnames(input)))) { - appendTo(c("Screen", "Warning", "Report"), + if (length(the.col <- grep("^[S|s]ensor\\.[V|v]alue$", colnames(input))) > 0) + colnames(input)[the.col] <- "Sensor.Value" + + if (!any(grepl("^Sensor\\.Value$", colnames(input)))) { + appendTo(c("Screen", "Warning", "Report"), paste0("Could not find a 'Sensor.Value' column in the detections. ", "Filling one with NA.")) - input$Sensor.Value <- NA_real_ - } + input$Sensor.Value <- NA_real_ + } - if (!any(grepl("^Sensor\\.Unit$", colnames(input)))) { - appendTo(c("Screen", "Warning", "Report"), + if (!any(grepl("^Sensor\\.Unit$", colnames(input)))) { + appendTo(c("Screen", "Warning", "Report"), paste0("Could not find a 'Sensor.Unit' column in the detections. ", "Filling one with NA.")) - input$Sensor.Unit <- NA_character_ - } + input$Sensor.Unit <- NA_character_ + } - if (!is.numeric(input$Sensor.Value)) { - appendTo(c("Screen", "Warning", "Report"), + if (!is.numeric(input$Sensor.Value)) { + appendTo(c("Screen", "Warning", "Report"), paste0("The 'Sensor.Value' column in the detections is not of type ", "numeric. Attempting to convert.")) - input$Sensor.Value <- tryCatch(as.numeric(input$Sensor.Value), - warning = function(w) { + input$Sensor.Value <- tryCatch(as.numeric(input$Sensor.Value), + warning = function(w) { stop("Attempting to convert the 'Sensor.Value' to numeric failed. ", "Aborting.", call. = FALSE) }) - } + } - if (!inherits(input$Timestamp, "POSIXct")) { - appendTo(c("Screen", "Report"), + if (!inherits(input$Timestamp, "POSIXct")) { + appendTo(c("Screen", "Report"), "M: Converting detection timestamps to POSIX objects.") if (!is.character(input$Timestamp)) { input$Timestamp <- as.character(input$Timestamp) } - + input$Timestamp <- fasttime::fastPOSIXct(input$Timestamp, tz = "UTC") if (any(is.na(input$Timestamp))) { stop("Converting the timestamps failed. Aborting.", call. = FALSE) } - attributes(input$Timestamp)$tzone <- tz - } else { + attributes(input$Timestamp)$tzone <- tz + } else { if (attributes(input$Timestamp)$tz != "UTC") { if (attributes(input$Timestamp)$tz != tz) { stopAndReport("Detections provided in POSIX format but not in UTC ", @@ -423,15 +423,15 @@ preloadDetections <- function(input, tz, start.time = NULL, stop.time = NULL) { " per user command (", onr - nrow(input), " detections discarded).")) } - if (any(grepl("^Valid$", colnames(input)))) { - if (!is.logical(input$Valid)) { - appendTo(c("Screen", "Warning", "Report"), + if (any(grepl("^Valid$", colnames(input)))) { + if (!is.logical(input$Valid)) { + appendTo(c("Screen", "Warning", "Report"), paste0("The detections have a column named 'Valid' but its content ", "is not logical. Resetting to Valid = TRUE.")) - input$Valid <- TRUE - } + input$Valid <- TRUE + } } else { - input$Valid <- TRUE + input$Valid <- TRUE } input$Transmitter <- as.factor(paste(input$CodeSpace, input$Signal, sep = "-")) diff --git a/R/print.R b/R/print.R index d1ddce5..82af215 100644 --- a/R/print.R +++ b/R/print.R @@ -48,7 +48,7 @@ printProgression <- function(dot, overall.CJS, spatial, status.df, print.release to.fill <- gg_colour_hue(length(sections)) diagram_nodes$fillcolor <- rep(NA_character_, nrow(diagram_nodes)) - + for (i in 1:length(sections)) { arrays <- spatial$array.order[[i]] diagram_nodes$fillcolor[matchl(diagram_nodes$label, arrays)] <- to.fill[i] @@ -215,7 +215,7 @@ printDot <- function(dot, spatial, print.releases) { to.fill <- gg_colour_hue(length(sections)) diagram_nodes$fillcolor <- rep(NA_character_, nrow(diagram_nodes)) - + for (i in 1:length(sections)) { arrays <- spatial$array.order[[i]] diagram_nodes$fillcolor[matchl(diagram_nodes$label, arrays)] <- to.fill[i] @@ -640,7 +640,7 @@ knitr::kable(intra.array.CJS[[',i ,']]$absolutes) #' #' @keywords internal #' -printIndividuals <- function(detections.list, movements, valid.movements, spatial, +printIndividuals <- function(detections.list, movements, valid.movements, spatial, status.df = NULL, rsp.info, y.axis = c("auto", "stations", "arrays"), extension = "png") { appendTo("debug", "Starting printIndividuals") @@ -652,7 +652,7 @@ printIndividuals <- function(detections.list, movements, valid.movements, spatia Array <- NULL Station <- NULL y.axis <- match.arg(y.axis) - + fake.results <- list(detections = detections.list, movements = movements, valid.movements = valid.movements, @@ -802,9 +802,9 @@ printCircular <- function(times, bio, suffix = NULL){ names(trim.times) <- unique(bio$Group) ylegend <- -0.97 } - + colours.to.use <- colours[names(trim.times)] - + if (legend.pos == "bottom") { ylegend <- -1.15 xlegend <- 0 @@ -831,12 +831,12 @@ printCircular <- function(times, bio, suffix = NULL){ b <- (ceiling(length(colours.to.use) / number.of.columns)) vertical.mar <- b + 2 - + # The try call prevents the report from crashing down in the presence of unknown errors. try( - {grDevices::svg(paste0(work.path, "times_", names(times)[i], suffix, ".svg"), + {grDevices::svg(paste0(work.path, "times_", names(times)[i], suffix, ".svg"), height = 5, width = 5, bg = "transparent") - + par(mar = c(b, (b + 2) / 2, 2, (b + 2) / 2), xpd = TRUE) # bottom, left, top, right copyOfCirclePlotRad(main = names(times)[i], shrink = 1.05, xlab = "", ylab = "") @@ -845,8 +845,8 @@ printCircular <- function(times, bio, suffix = NULL){ prop = prop, tcl.text = -0.1, tol = 0.05, col = colours.to.use, border = "black") roseMean(trim.times, col = scales::alpha(params$col, 1), mean.length = c(0.07, -0.07), mean.lwd = 6, - box.range = "std.error", fill = "white", horizontal.border = "black", - vertical.border = scales::alpha(sapply(params$col, darken), 1), box.size = c(1.015, 0.985), + box.range = "std.error", fill = "white", horizontal.border = "black", + vertical.border = scales::alpha(sapply(params$col, darken), 1), box.size = c(1.015, 0.985), edge.length = c(0.025, -0.025), edge.lwd = 2) ringsRel(plot.params = params, border = "black", ring.text = TRUE, @@ -1098,12 +1098,12 @@ ringsRel <- function(plot.params, border, rings.lty, #' @keywords internal #' roseMean <- function(input, col = c("cornflowerblue", "chartreuse3", "deeppink"), - mean.length = c(0.0125, -0.0125), mean.lwd = 4, box.range = c("none", "std.error", "sd"), + mean.length = c(0.0125, -0.0125), mean.lwd = 4, box.range = c("none", "std.error", "sd"), fill = "white", horizontal.border = "black", vertical.border = "black", box.size = c(1.015, 0.985), edge.length = c(0.025, -0.025), edge.lwd = 2){ box.range <- match.arg(box.range) - + if(is.matrix(input) | is.data.frame(input)){ # the different series in the input must be broken into individual # list elements to play nicely with the code below. @@ -1125,7 +1125,7 @@ roseMean <- function(input, col = c("cornflowerblue", "chartreuse3", "deeppink") if (!exists("plotdata")) stop("Input must be a list of circular objects, a data.frame, a matrix or a vector.\n") - + # expand colour and fill to match the number of data series to be plotted col <- rep(col, length.out = length(plotdata)) fill <- rep(fill, length.out = length(plotdata)) @@ -1137,7 +1137,7 @@ roseMean <- function(input, col = c("cornflowerblue", "chartreuse3", "deeppink") for (i in 1:length(plotdata)) { # calculate a circular mean first (needed for the if-statement below) m <- circular::mean.circular(plotdata[[i]], na.rm = TRUE) - + # start by plotting the desired ranges, if one was requested if(box.range != "none"){ if(box.range == "std.error") @@ -1155,7 +1155,7 @@ roseMean <- function(input, col = c("cornflowerblue", "chartreuse3", "deeppink") # convert to x and y coordinates xx <- c(box.size[1] * cos(seq(left, right, length = 1000) + zero), rev(box.size[2] * cos(seq(left, right, length = 1000) + zero))) yy <- c(box.size[1] * sin(seq(left, right, length = 1000) + zero), rev(box.size[2] * sin(seq(left, right, length = 1000) + zero))) - + # plot the range box polygon(xx, yy, col = fill[i], border = horizontal.border[i]) @@ -1299,10 +1299,10 @@ printSectionTimes <- function(section.times, bio, detections) { appendTo("debug", "Starting printSectionTimes") Date <- Group <- NULL - + cbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#999999") names(cbPalette) <- c("Orange", "Blue", "Green", "Yellow", "Darkblue", "Darkorange", "Pink", "Grey") - + time.range <- c(min(bio$Release.date), max(do.call(c, lapply(detections, function(x) x$Timestamp)))) dayrange <- as.Date(time.range) dayrange[1] <- dayrange[1] - 1 @@ -1312,13 +1312,13 @@ printSectionTimes <- function(section.times, bio, detections) { # cat(i, '\n') plotdata <- suppressMessages(reshape2::melt(section.times[[i]])) plotdata <- plotdata[complete.cases(plotdata), ] - + link <- match(plotdata$Transmitter, bio$Transmitter) plotdata$Group <- bio$Group[link] plotdata$Group <- droplevels(plotdata$Group) - + plotdata$Date <- as.Date(substring(as.character(plotdata$value), 1, 10)) - + p <- ggplot2::ggplot(data = plotdata, ggplot2::aes(x = Date, fill = Group)) p <- p + ggplot2::geom_bar(width = 0.9) p <- p + ggplot2::theme_bw() @@ -1326,11 +1326,11 @@ printSectionTimes <- function(section.times, bio, detections) { p <- p + ggplot2::scale_y_continuous(expand = c(0, 0, 0.05, 0)) p <- p + ggplot2::scale_x_date(limits = dayrange) p <- p + ggplot2::labs(x = "", y = "n") - + if (length(unique(plotdata$Group)) <= 8) { p <- p + ggplot2::scale_fill_manual(values = as.vector(cbPalette)[1:length(unique(plotdata$Group))], drop = FALSE) } - + ggplot2::ggsave(paste0(tempdir(), "/actel_report_auxiliary_files/", i,"_days.png"), width = 10, height = length(unique(plotdata$variable)) * 2, limitsize = FALSE) }) @@ -1379,7 +1379,7 @@ printGlobalRatios <- function(global.ratios, group.ratios, time.ratios, spatial, #' #' @param ratios the daily ratios #' @inheritParams sectionMovements -#' +#' #' @return A string of file locations in rmd syntax, to be included in printRmd #' #' @keywords internal @@ -1401,13 +1401,13 @@ printIndividualResidency <- function(ratios, global.ratios, spatial, rsp.info) { capture <- lapply(names(ratios), function(i) { counter <<- counter + 1 - + p <- plotResidency(input = fake.results, tag = i) ggplot2::ggsave(paste0(tempdir(), "/actel_report_auxiliary_files/", i,"_residency.png"), width = 10, height = 1.5) - + individual.plots <<- paste0(individual.plots, "![](", tempdir(), "/actel_report_auxiliary_files/", i, "_residency.png){ width=95% }\n") - + if (interactive()) setTxtProgressBar(pb, counter) }) @@ -1435,11 +1435,11 @@ printLastSection <- function(input, spatial) { cbPalette <- c("#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#CC79A7", "#999999") names(cbPalette) <- c("Orange", "Blue", "Green", "Yellow", "Darkblue", "Darkorange", "Pink", "Grey") - + input$Group <- rownames(input) plotdata <- suppressMessages(reshape2::melt(input)) colnames(plotdata) <- c("Group", "Section", "n") - plotdata$Section <- factor(gsub("Disap. in |Disap. at ", "", plotdata$Section), + plotdata$Section <- factor(gsub("Disap. in |Disap. at ", "", plotdata$Section), levels = c(names(spatial$array.order), "Release")) if (length(levels(plotdata$Section)) < 5) @@ -1473,7 +1473,7 @@ printLastSection <- function(input, spatial) { p <- p + ggplot2::scale_y_continuous(expand = c(0, 0, 0.05, 0)) p <- p + ggplot2::facet_wrap(. ~ Group, ncol = number.of.columns) p <- p + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 90, vjust = 0.5, hjust = 1)) - + ggplot2::ggsave(paste0(tempdir(), "/actel_report_auxiliary_files/last_section.png"), units = "px", width = 1800, height = ceiling(the.height), limitsize = FALSE) appendTo("debug", "Finished printLastSection") diff --git a/R/residency.R b/R/residency.R index c32f99f..015695a 100644 --- a/R/residency.R +++ b/R/residency.R @@ -12,7 +12,7 @@ #' \code{section.error} detections, user intervention is suggested. #' Defaults to 1. To disable user intervention suggestions, set to 0. #' @param section.warning If a tag has section movement events with less or equal to -#' \code{section.warning} detections, a warning is issued. Defaults to 1. +#' \code{section.warning} detections, a warning is issued. Defaults to 1. #' To disable section warnings, set to 0. Must be equal to or greater than \code{section.error}. #' @param timestep The resolution desired for the residency calculations. #' One of "days" (default) or "hours". @@ -308,12 +308,12 @@ residency <- function( x <- replicates[[i]] all.stations <- spatial$stations$Standard.name[spatial$stations$Array == i] if (any(link <- !x %in% all.stations)) { - stop(paste0("In replicates: Station", - ifelse(sum(link) > 1, "s ", " "), - paste(x[link], collapse = ", "), - ifelse(sum(link) > 1, " are", " is"), - " not part of ", i, " (available stations: ", - paste(all.stations, collapse = ", "), ")."), + stop(paste0("In replicates: Station", + ifelse(sum(link) > 1, "s ", " "), + paste(x[link], collapse = ", "), + ifelse(sum(link) > 1, " are", " is"), + " not part of ", i, " (available stations: ", + paste(all.stations, collapse = ", "), ")."), call. = FALSE) } }) @@ -392,7 +392,7 @@ residency <- function( output <- checkMinimumN(movements = movements[[tag]], tag = tag, min.total.detections = min.total.detections, min.per.event = min.per.event[1], n = counter) - output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, + output <- checkImpassables(movements = output, tag = tag, bio = bio, detections = detections.list[[tag]], n = counter, spatial = spatial, dotmat = dotmat, GUI = GUI, save.tables.locally = save.tables.locally) output <- checkJumpDistance(movements = output, bio = bio, tag = tag, dotmat = dotmat, paths = paths, arrays = arrays, @@ -402,8 +402,8 @@ residency <- function( if (do.checkSpeeds) { temp.valid.movements <- simplifyMovements(movements = output, tag = tag, bio = bio, discard.first = discard.first, speed.method = speed.method, dist.mat = dist.mat) - output <- checkSpeeds(movements = output, tag = tag, valid.movements = temp.valid.movements, - detections = detections.list[[tag]], speed.warning = speed.warning, n = counter, + output <- checkSpeeds(movements = output, tag = tag, valid.movements = temp.valid.movements, + detections = detections.list[[tag]], speed.warning = speed.warning, n = counter, speed.error = speed.error, GUI = GUI, save.tables.locally = save.tables.locally) rm(temp.valid.movements) } @@ -433,11 +433,11 @@ residency <- function( appendTo("debug", paste0("debug: Compiling section movements for tag ", tag,".")) aux <- sectionMovements(movements = movements[[i]], spatial = spatial, valid.dist = attributes(dist.mat)$valid) - + aux <- checkMinimumN(movements = aux, tag = tag, min.total.detections = 0, # don't run the minimum total detections check here. min.per.event = min.per.event[2], n = counter) - output <- checkSMovesN(secmoves = aux, tag = tag, section.warning = section.warning, section.error = section.error, GUI = GUI, + output <- checkSMovesN(secmoves = aux, tag = tag, section.warning = section.warning, section.error = section.error, GUI = GUI, save.tables.locally = save.tables.locally, n = counter) return(output) }) @@ -454,9 +454,9 @@ residency <- function( appendTo(c("Screen", "Report"), "M: Filtering valid section movements.") - section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial, + section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial, valid.dist = attributes(dist.mat)$valid) - + # Grab summary information appendTo(c("Screen", "Report"), "M: Compiling residency objects.") @@ -473,9 +473,9 @@ residency <- function( spatial = spatial, rsp.info = list(bio = bio, analysis.type = "residency")) array.times <- getTimes(input = aux, move.type = "array", event.type = "arrival", n.events = "all") - section.times <- list(arrival = getTimes(input = aux, move.type = "section", + section.times <- list(arrival = getTimes(input = aux, move.type = "section", event.type = "arrival", n.events = "all"), - departure = getTimes(input = aux, move.type = "section", + departure = getTimes(input = aux, move.type = "section", event.type = "departure", n.events = "all")) rm(aux) @@ -503,7 +503,7 @@ residency <- function( appendTo(c('screen', 'warning', 'report'), paste0('Group ', as.character(i), ' has no detections. Skipping ratio calculations.')) return(NULL) - } + } else { link <- link[!is.na(link)] trim.positions <- time.positions[, c(1, link)] @@ -553,7 +553,7 @@ residency <- function( efficiency <- efficiency[1:3] # extra info for potential RSP analysis - rsp.info <- list(analysis.type = "residency", analysis.time = the.time, bio = bio, + rsp.info <- list(analysis.type = "residency", analysis.time = the.time, bio = bio, tz = tz, actel.version = utils::packageVersion("actel")) if (!is.null(override)) @@ -575,7 +575,7 @@ residency <- function( } if (interactive()) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), choices = c("y", "n"), hash = "# save results?") } else { # nocov end decision <- "n" @@ -586,12 +586,12 @@ residency <- function( if (attributes(dist.mat)$valid) save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, section.movements, status.df, last.seen, array.times, section.times, intra.array.matrices, - residency.list, time.ratios, time.positions, global.ratios, group.ratios, efficiency, + residency.list, time.ratios, time.positions, global.ratios, group.ratios, efficiency, intra.array.CJS, rsp.info, dist.mat, file = resultsname) else save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements, section.movements, status.df, last.seen, array.times, section.times, intra.array.matrices, - residency.list, time.ratios, time.positions, global.ratios, group.ratios, efficiency, + residency.list, time.ratios, time.positions, global.ratios, group.ratios, efficiency, intra.array.CJS, rsp.info, file = resultsname) } else { appendTo(c("Screen", "Report"), paste0("M: Skipping saving of the results.")) @@ -605,7 +605,7 @@ residency <- function( if (report) { appendTo(c("Screen", "Report"), "M: Producing the report.") on.exit({if (trigger.report.error.message) message("M: Producing the report failed. If you have saved a copy of the results, you can reload them using dataToList().")}, add = TRUE) - + if (dir.exists(paste0(tempdir(), "/actel_report_auxiliary_files"))) unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), recursive = TRUE) @@ -615,7 +615,7 @@ residency <- function( on.exit(unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), recursive = TRUE), add = TRUE) biometric.fragment <- printBiometrics(bio = bio) - + printDot(dot = dot, spatial = spatial, print.releases = print.releases) @@ -643,15 +643,15 @@ residency <- function( suffix = "_array") section.arrival.circular.plots <- printCircular(times = timesToCircular(section.times$arrival), - bio = bio, + bio = bio, suffix = "_section_arrival") - section.departure.circular.plots <- printCircular(times = timesToCircular(section.times$departure), - bio = bio, + section.departure.circular.plots <- printCircular(times = timesToCircular(section.times$departure), + bio = bio, suffix = "_section_departure") appendTo(c("Screen", "Report"), "M: Drawing individual residency graphics.") - + individual.residency.plots <- printIndividualResidency(ratios = time.ratios, global.ratios = global.ratios, @@ -666,9 +666,9 @@ residency <- function( spatial = spatial) if (any(sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))))) { - sensor.plots <- printSensorData(detections = valid.detections, + sensor.plots <- printSensorData(detections = valid.detections, spatial = spatial, - rsp.info = rsp.info, + rsp.info = rsp.info, colour.by = detections.y.axis) } else { sensor.plots <- NULL @@ -679,7 +679,7 @@ residency <- function( # wrap up the txt report appendTo("Report", "M: Analysis completed!\n\n-------------------") - + if (file.exists(paste(tempdir(), "temp_comments.txt", sep = "/"))) appendTo("Report", paste0("User comments:\n-------------------\n", gsub("\t", ": ", gsub("\r", "", readr::read_file(paste(tempdir(), "temp_comments.txt", sep = "/")))), "-------------------")) # nocov @@ -729,7 +729,7 @@ residency <- function( appendTo("debug", "debug: Converting report to html") rmarkdown::render(input = paste0(tempdir(), "/actel_report_auxiliary_files/actel_residency_report.Rmd"), - output_dir = paste0(tempdir(), "/actel_report_auxiliary_files"), + output_dir = paste0(tempdir(), "/actel_report_auxiliary_files"), quiet = TRUE) appendTo("debug", "debug: Moving report") @@ -745,7 +745,7 @@ residency <- function( jobname <- paste0(gsub(" |:", ".", as.character(Sys.time())), ".actel.log.txt") if (interactive() & !report) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), + decision <- userInput(paste0("Would you like to save a copy of the analysis log to ", jobname, "?(y/n) "), choices = c("y", "n"), hash = "# save job log?") } else { # nocov end decision <- "n" @@ -1034,7 +1034,7 @@ Note: ### Individual detection plots -Note: +Note: : You can choose to plot detections by station or by array using the `detections.y.axis` argument. : The detections are coloured by ', ifelse(detections.y.axis == "stations", 'array', 'section'), '. The vertical black dashed line shows the release time. The full dark-grey line shows the movement events considered valid, while the dashed dark-grey line shows the movement events considered invalid. ', ifelse(detections.y.axis == "stations", ' : The movement event lines move straight between the first and last station of each event (i.e. in-between detections will not be individually linked by the line).\n', ''), @@ -1200,12 +1200,12 @@ assembleResidency <- function(secmoves, movements, spatial) { recipient <- rep(NA, ncol(res.df)) names(recipient) <- colnames(res.df) recipient <- t(as.data.frame(recipient)) - + total.time <- apply(aux[[i]][, c("First.time", "Last.time")], 1, function(x) difftime(x[2], x[1], units = "secs")) recipient[1, paste0("Total.time.", names(aux)[i])] <- sum(total.time) recipient[1, paste0("Average.time.", names(aux)[i])] <- mean(total.time) recipient[1, paste0("Times.entered.", names(aux)[i])] <- nrow(aux[[i]]) - + entry.time <- mean(circular::circular(decimalTime(format(aux[[i]]$First.time, "%H:%M:%S")), units = "hours", template = "clock24")) if (!is.na(entry.time)) { if (entry.time < 0) @@ -1459,7 +1459,7 @@ getResidency <- function(movements, spatial){ recipient$Index <- (1:nrow(recipient) * 2) - 1 if (nrow(recipient) > 1) { to.add <- data.frame( - A = match(recipient$Section[-nrow(recipient)], + A = match(recipient$Section[-nrow(recipient)], names(spatial$array.order)), B = match(recipient$Section[-1], names(spatial$array.order)), First.time = recipient$Last.time[-nrow(recipient)], @@ -1489,7 +1489,7 @@ getResidency <- function(movements, spatial){ nrow(x) == 1 && x$First.time == x$Last.time }) if (any(inst.exception)) { - appendTo(c("Screen", "Report", "Warning"), + appendTo(c("Screen", "Report", "Warning"), paste("Valid detections for tag", paste(names(output)[inst.exception], collapse = ", "), "start and end on the same instant. ", @@ -1770,7 +1770,7 @@ resRatiosIndOut <- function(input, slots, tz, tag) { # assign section name output$Most.time <- colnames(output)[aux - 1][the.zone] - + # finally, round the proportions to a more sensible format output[, aux] <- round(output[, aux, drop = FALSE], 3) @@ -1793,7 +1793,7 @@ resPositions <- function(ratios, timestep = c("days", "hours")) { # extract first and last time first.time <- as.POSIXct(NA)[-1] last.time <- as.POSIXct(NA)[-1] - + capture <- lapply(ratios, function(x) { first.time <<- c(first.time, x$Timeslot[1]) last.time <<- c(last.time, x$Timeslot[nrow(x)]) @@ -1815,11 +1815,11 @@ resPositions <- function(ratios, timestep = c("days", "hours")) { link <- match.POSIXt(ratios[[i]]$Timeslot, output$Timeslot) if (any(is.na(link))) stop("Something went wrong when creating the recipient for the global ratios. Contact the developer.") - + output[link, i] <<- ratios[[i]]$Most.time }) - attributes(output)$timestep <- timestep + attributes(output)$timestep <- timestep return(output) } diff --git a/R/user_interaction.R b/R/user_interaction.R index 2ba4ad2..b987211 100644 --- a/R/user_interaction.R +++ b/R/user_interaction.R @@ -17,26 +17,26 @@ #' @param save.tables.locally Logical: If a table must be temporarily stored into a file #' for user inspection, should it be saved in the current working directory, or #' in R's temporary folder? -#' +#' #' @name user_interaction_args #' @keywords internal #' NULL #' Wrap frequently used code to handle user input -#' +#' #' @param question The question to be asked #' @param choices The accepted inputs. Leave empty for any input #' @param tag the tag code (for comments only) #' @param hash A string to attach to the decision in the UD. Ignored if input already has a hash string -#' +#' #' @keywords internal -#' +#' userInput <- function(question, choices, tag, hash) { appendTo("debug", "Running userInput.") if (interactive()) { # nocov start try.again <- TRUE - + while (try.again) { decision <- readline(question) aux <- strsplit(as.character(decision), "[ ]*#")[[1]] @@ -44,12 +44,12 @@ userInput <- function(question, choices, tag, hash) { output <- "" else output <- tolower(aux[1]) - + if (!missing(choices) && is.na(match(output, choices))) { appendTo("Screen", paste0("Option not recognized, please choose one of: '", paste0(choices, collapse = "', '"), "'.")) output <- NULL } - + if (!is.null(output)) { if (output == "comment") { if (missing(tag)) { @@ -63,8 +63,8 @@ userInput <- function(question, choices, tag, hash) { try.again <- FALSE } } - } - + } + if (length(aux) == 1 & !missing(hash)) appendTo("UD", paste(decision, hash)) else @@ -104,7 +104,7 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE if (popup) { output <- graphicalInvalidate(moves = moves, detections = detections, tag = tag, trigger = trigger) - decision <- userInput(paste0("Would you like to leave a comment for tag ", tag, "?(y/n) "), + decision <- userInput(paste0("Would you like to leave a comment for tag ", tag, "?(y/n) "), choices = c("y", "n"), hash = paste0("# comment ", tag, "?")) if (decision == "y") { @@ -132,7 +132,7 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE target.file <- "actel_inspect_movements.csv" else target.file <- paste0(tempdir(), '/actel_inspect_movements.csv') - + # save file to.display <- data.table::as.data.table(cbind(data.frame(Event = 1:sum(moves$Valid)), moves[(Valid)])) data.table::fwrite(to.display, target.file, dateTimeAs = "write.csv", showProgress = FALSE) @@ -147,8 +147,8 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE # start interaction if (force) { output <- invalidateEvents(displayed.moves = moves[(Valid)], # beware: table interaction blindly calls to the first column of "from". - all.moves = moves, - detections = detections, + all.moves = moves, + detections = detections, tag = tag, GUI = GUI) } else { @@ -156,15 +156,15 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE text.to.display <- "Would you like to render any movement event invalid?(y/n/comment) " else text.to.display <- "Would you like to render any movement event invalid, or expand an event?(y/n/comment) " - + decision <- userInput(text.to.display, - choices = c("y", "n", "comment"), - tag = tag, + choices = c("y", "n", "comment"), + tag = tag, hash = paste0("# invalidate/expand moves in ", tag, "?")) if (decision == "y") { output <- invalidateEvents(displayed.moves = moves[(Valid)], # beware: table interaction blindly calls to the first column of "from". - all.moves = moves, - detections = detections, + all.moves = moves, + detections = detections, tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) @@ -196,9 +196,9 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE message("\nM: Please find the exception which triggered this interaction at the top of the table.") message("") if (force) { - output <- invalidateEvents(displayed.moves = to.display, - all.moves = moves, - detections = detections, + output <- invalidateEvents(displayed.moves = to.display, + all.moves = moves, + detections = detections, tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) @@ -209,13 +209,13 @@ tableInteraction <- function(moves, detections, tag, trigger, GUI, force = FALSE text.to.display <- "Would you like to render any movement event invalid, or expand an event?(y/n/comment) " decision <- userInput(text.to.display, - choices = c("y", "n", "comment"), - tag = tag, + choices = c("y", "n", "comment"), + tag = tag, hash = paste0("# invalidate/expand moves in ", tag, "?")) if (decision == "y") { - output <- invalidateEvents(displayed.moves = to.display, - all.moves = moves, - detections = detections, + output <- invalidateEvents(displayed.moves = to.display, + all.moves = moves, + detections = detections, tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) @@ -245,18 +245,18 @@ invalidateEvents <- function(displayed.moves, all.moves, detections, tag, GUI, s Valid <- NULL appendTo("debug", "Running invalidateEvents.") appendTo("Screen", "Note: You can select event ranges by separating them with a ':' and/or multiple events at once by separating them with a space or a comma.") - + check <- TRUE while (check) { if (colnames(displayed.moves)[1] == "Section") { the.string <- userInput("Events to be rendered invalid: ", tag = tag) } else { - the.string <- userInput("Events to be rendered invalid (type 'expand' to inspect the detections of a given event): ", tag = tag) + the.string <- userInput("Events to be rendered invalid (type 'expand' to inspect the detections of a given event): ", tag = tag) if (the.string == "expand") { - all.moves <- expandEvent(displayed.moves = displayed.moves, - all.moves = all.moves, - detections = detections, + all.moves <- expandEvent(displayed.moves = displayed.moves, + all.moves = all.moves, + detections = detections, tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) @@ -269,10 +269,10 @@ invalidateEvents <- function(displayed.moves, all.moves, detections, tag, GUI, s text.to.display <- "Would you like to render any movement event invalid?(y/n/comment) " else text.to.display <- "Would you like to render any movement event invalid, or expand an event?(y/n/comment) " - + decision <- userInput(text.to.display, - choices = c("y", "n", "comment"), - tag = tag, + choices = c("y", "n", "comment"), + tag = tag, hash = paste0("# invalidate/expand moves in ", tag, "?")) if (decision == "y") { appendTo("Screen", "Note: You can select event ranges by separating them with a ':' and/or multiple events at once by separating them with a space or a comma.") @@ -315,18 +315,18 @@ invalidateEvents <- function(displayed.moves, all.moves, detections, tag, GUI, s appendTo("Screen", "Part of the input could not be recognised as a row number.") if (all(the.rows > 0 & the.rows <= nrow(displayed.moves))) { - + if (length(the.rows) <= 10) decision <- userInput(paste0("Confirm: Would you like to render event(s) ", paste(the.rows, collapse = ", "), " invalid?(y/n/comment) "), choices = c("y", "n", "comment"), tag = tag, hash = "# confirm?") else decision <- userInput(paste0("Confirm: Would you like to render ", length(the.rows), " events invalid?(y/n/comment) "), choices = c("y", "n", "comment"), tag = tag, hash = "# confirm?") - + if (decision == "y") { displayed.moves$Valid[the.rows] <- FALSE attributes(displayed.moves)$p.type <- "Manual" - + # transfer movement validity all.moves <- transferValidity(from = displayed.moves, to = all.moves) @@ -335,7 +335,7 @@ invalidateEvents <- function(displayed.moves, all.moves, detections, tag, GUI, s appendTo(c("Screen", "Report"), paste0("M: Movement event(s) ", paste(the.rows, collapse = ", "), " from tag ", tag," were rendered invalid per user command.")) else appendTo(c("Screen", "Report"), paste0("M: ", length(the.rows), " movement event(s) from tag ", tag," were rendered invalid per user command.")) - + if (colnames(all.moves)[1] == "Section") text.to.display <- "Would you like to render any more movement events invalid?(y/n/comment) " else @@ -343,7 +343,7 @@ invalidateEvents <- function(displayed.moves, all.moves, detections, tag, GUI, s decision <- userInput(text.to.display, choices = c("y", "n", "comment"), tag = tag, hash = "# invalidate more?") - + if (decision == "y") { if (colnames(all.moves)[1] == "Section") to.display <- all.moves[(Valid), -c(5, 7)] @@ -424,9 +424,9 @@ graphicalInvalidate <- function(detections, moves, tag, trigger) { # nocov start restart <- recipient$restart rm(recipient) } - + first.time <- FALSE - + moves$Valid <- graphical_valid if (restart) @@ -443,18 +443,18 @@ graphicalInvalidate <- function(detections, moves, tag, trigger) { # nocov start } # nocov end #' Handler for event expansion -#' +#' #' @inheritParams user_interaction_args -#' +#' #' @return An updated movements table -#' +#' #' @keywords internal -#' +#' expandEvent <- function(displayed.moves, all.moves, detections, tag, GUI, save.tables.locally) { # nocov start check <- TRUE abort <- FALSE while(check) { - event <- userInput("Which event would you like to expand? ", + event <- userInput("Which event would you like to expand? ", tag = tag, hash = "# Expand this event") event <- suppressWarnings(as.numeric(event)) @@ -495,9 +495,9 @@ expandEvent <- function(displayed.moves, all.moves, detections, tag, GUI, save.t if (popup) { output <- graphicalInvalidateDetections(detections = sub.det, - displayed.moves = displayed.moves, - all.moves = all.moves, - event = event, + displayed.moves = displayed.moves, + all.moves = all.moves, + event = event, tag = tag, silent = FALSE) } else { @@ -513,7 +513,7 @@ expandEvent <- function(displayed.moves, all.moves, detections, tag, GUI, save.t target.file <- "actel_inspect_detections.csv" else target.file <- paste0(tempdir(), '/actel_inspect_detections.csv') - + # save file to.display <- cbind(data.frame(Index = 1:nrow(sub.det)), sub.det) write.csv(to.display, target.file, row.names = FALSE) @@ -527,13 +527,13 @@ expandEvent <- function(displayed.moves, all.moves, detections, tag, GUI, save.t flush.console() # start interaction decision <- userInput("Would you like to render any detections invalid?(y/n/comment) ", - choices = c("y", "n", "comment"), - tag = tag, + choices = c("y", "n", "comment"), + tag = tag, hash = paste0("# invalidate detections in event ", event, " of ", tag, "?")) if (decision == "y") { - output <- invalidateDetections(displayed.moves = displayed.moves, - all.moves = all.moves, - detections = sub.det, + output <- invalidateDetections(displayed.moves = displayed.moves, + all.moves = all.moves, + detections = sub.det, tag = tag, event = event) } else { @@ -553,13 +553,13 @@ expandEvent <- function(displayed.moves, all.moves, detections, tag, GUI, save.t message(paste0(capture.output(print(sub.det, topn = nrow(sub.det))), collapse = "\n")) message("") decision <- userInput("Would you like to render any detections invalid?(y/n/comment) ", - choices = c("y", "n", "comment"), - tag = tag, + choices = c("y", "n", "comment"), + tag = tag, hash = paste0("# invalidate detections in event ", event, " of ", tag, "?")) if (decision == "y") { - output <- invalidateDetections(displayed.moves = displayed.moves, - all.moves = all.moves, - detections = sub.det, + output <- invalidateDetections(displayed.moves = displayed.moves, + all.moves = all.moves, + detections = sub.det, tag = tag, event = event) } else { @@ -618,24 +618,24 @@ invalidateDetections <- function(displayed.moves, all.moves, detections, tag, ev appendTo("Screen", "Part of the input could not be recognised as a row number.") if (all(the.rows > 0 & the.rows <= nrow(detections))) { - + if (length(the.rows) <= 10) decision <- userInput(paste0("Confirm: Would you like to render detection(s) ", paste(the.rows, collapse = ", "), " invalid?(y/n/comment) "), choices = c("y", "n", "comment"), tag = tag, hash = "# confirm?") else decision <- userInput(paste0("Confirm: Would you like to render ", length(the.rows), " detections invalid?(y/n/comment) "), choices = c("y", "n", "comment"), tag = tag, hash = "# confirm?") - + if (decision == "y") { - detections$Valid[the.rows] <- FALSE + detections$Valid[the.rows] <- FALSE if (length(the.rows) == 1) appendTo(c("Screen", "Report"), paste0("M: ", length(the.rows), " detection from valid event ", event, " of tag ", tag," was rendered invalid per user command.")) else appendTo(c("Screen", "Report"), paste0("M: ", length(the.rows), " detections from valid event ", event, " of tag ", tag," were rendered invalid per user command.")) - + decision <- userInput("Would you like to render any more detections invalid?(y/n/comment) ", choices = c("y", "n", "comment"), tag = tag, hash = "# invalidate more?") - + if (decision == "y") { check <- TRUE appendTo("Screen", paste0("M: Updated detections table from valid event ", event, " of tag ", tag, ":")) @@ -645,9 +645,9 @@ invalidateDetections <- function(displayed.moves, all.moves, detections, tag, ev check <- FALSE } } - all.moves <- createNewEvents(displayed.moves = displayed.moves, - all.moves = all.moves, - detections = detections, + all.moves <- createNewEvents(displayed.moves = displayed.moves, + all.moves = all.moves, + detections = detections, event = event) } else { appendTo("Screen", paste0("Please select only events within the row limits (1-", nrow(detections),").")) @@ -697,12 +697,12 @@ graphicalInvalidateDetections <- function(detections, displayed.moves, all.moves to.print = to.print, silent = silent) } - + detections$Valid <- graphical_valid - all.moves <- createNewEvents(displayed.moves = displayed.moves, - all.moves = all.moves, - detections = detections, + all.moves <- createNewEvents(displayed.moves = displayed.moves, + all.moves = all.moves, + detections = detections, event = event) if (any(!graphical_valid)) { @@ -750,18 +750,18 @@ overrideValidityChecks <- function(moves, detections, tag, GUI, save.tables.loca appendTo("debug", "Starting overrideValidityChecks.") message("----------------------------") appendTo(c("Screen", "Report"), trigger <- paste0("M: Override has been triggered for tag ", tag, " ", n, ". Entering full manual mode.")) - moves <- tableInteraction(moves = moves, detections = detections, tag = tag, + moves <- tableInteraction(moves = moves, detections = detections, tag = tag, trigger = trigger, GUI = GUI, save.tables.locally = save.tables.locally) attributes(moves)$p.type <- "Overridden" message("Terminating full manual mode\n----------------------------") return(moves) # nocov end } -#' Upon invalidating detections, recombines the remaining valid detections +#' Upon invalidating detections, recombines the remaining valid detections #' into new events, and merges them with the remaining events. -#' +#' #' @inheritParams user_interaction_args -#' +#' #' @return A data frame containing the movements for the target tag #' #' @keywords internal @@ -773,7 +773,7 @@ createNewEvents <- function(displayed.moves, all.moves, detections, event) { # n aux <- data.frame(Value = aux[[2]], n = aux[[1]]) aux$stop <- cumsum(aux$n) aux$start <- c(1, aux$stop[-1] - (aux$n[-1] - 1)) - + # the event needs to be converted to the original row number in the movements ori.event <- which(all.moves[[1]] == displayed.moves[[event, "Array"]] & grepl(displayed.moves[[event, "First.time"]], all.moves$First.time, fixed = TRUE)) diff --git a/R/widget_setups.R b/R/widget_setups.R index 43f659a..8a9889b 100644 --- a/R/widget_setups.R +++ b/R/widget_setups.R @@ -9,20 +9,20 @@ #' @param tag The tag being analysed. #' @param event The event selected for expansion. #' @param to.print The subset of detections to be displayed. -#' +#' #' @name widget_args #' @keywords internal #' NULL #' Event Widget (Tabbed version) -#' +#' #' @inheritParams widget_args -#' +#' #' @return The movements list, a vector of event validities, and a note on whether or not the widget should be restarted. -#' +#' #' @keywords internal -#' +#' eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trigger, first.time, type) { # nocov start appendTo("debug", "Running eventsTabbedWidget.") # initiate button variables @@ -52,7 +52,7 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig hdr[2, 1:2, expand = TRUE] <- gWidgets2::gtext(trigger, handler = NULL, container = hdr) hdr[3, 1:2, expand = TRUE] <- gWidgets2::glabel("Usage notes:\n - Edit event validity by selecting rows and choosing the desired action below.\n - Loading large tables can take some time. Please wait until the interaction buttons show up at the bottom of this window.", container = hdr) hdr[2, 1, expand = TRUE] <- gWidgets2::glabel("This table is very long!\n - Please allow some time for the action buttons to complete their tasks (particularly those that span multiple pages).\n - Please wait until the buttons appear at the bottom of the page before performing any action!", container = hdr) - + tbl <- list() nb <- gWidgets2::gnotebook(tab.pos = 3, expand = TRUE, container = g) # add handler that keeps track of current tab @@ -136,11 +136,11 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig complain <<- gWidgets2::gwindow("Warning", width = 300, height = 20) complain_layout <- gWidgets2::ggroup(horizontal = FALSE, container = complain) gWidgets2::glabel("No event was selected to expand.", container = complain_layout) - + complain_function <- function(h, ...) { gWidgets2::dispose(complain) } - complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, + complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, expand = TRUE, container = complain_layout) } if (length(event) > 1) { @@ -150,15 +150,15 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig complain <<- gWidgets2::gwindow("Warning", width = 300, height = 20) complain_layout <- gWidgets2::ggroup(horizontal = FALSE, container = complain) gWidgets2::glabel("Select only one event to expand.", container = complain_layout) - + complain_function <- function(h, ...) { gWidgets2::dispose(complain) } - complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, + complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, expand = TRUE, container = complain_layout) } if (length(event) == 1) { - link <- detections$Timestamp >= displayed.moves$First.time[event] & + link <- detections$Timestamp >= displayed.moves$First.time[event] & detections$Timestamp <= displayed.moves$Last.time[event] from <- match(displayed.moves$First.time[event], as.character(detections$Timestamp)) @@ -166,10 +166,10 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig sub.det <- detections[from:to, ] gWidgets2::visible(moves.window) <- FALSE - all.moves <<- graphicalInvalidateDetections(detections = sub.det, - displayed.moves = displayed.moves, - all.moves = all.moves, - event = event, + all.moves <<- graphicalInvalidateDetections(detections = sub.det, + displayed.moves = displayed.moves, + all.moves = all.moves, + event = event, tag = tag, silent = TRUE) @@ -218,7 +218,7 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig abort_function <- function(h, ...) { gWidgets2::dispose(confirm) } - confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) + confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) } btns[2, 6] <- gWidgets2::gbutton(text = "Submit and close", handler = close_function, action = NULL, container = btns) @@ -239,13 +239,13 @@ eventsTabbedWidget <- function(tag, displayed.moves, all.moves, detections, trig } # nocov end #' Event Widget (Single table version) -#' +#' #' @inheritParams widget_args -#' +#' #' @return The movements list, a vector of event validities, and a note on whether or not the widget should be restarted. -#' +#' #' @keywords internal -#' +#' eventsSingleWidget <- function(tag, displayed.moves, all.moves, detections, trigger, first.time, type) { # nocov start appendTo("debug", "Running eventsSingleWidget.") @@ -317,11 +317,11 @@ eventsSingleWidget <- function(tag, displayed.moves, all.moves, detections, trig complain <<- gWidgets2::gwindow("Warning", width = 300, height = 20) complain_layout <- gWidgets2::ggroup(horizontal = FALSE, container = complain) gWidgets2::glabel("No event was selected to expand.", container = complain_layout) - + complain_function <- function(h, ...) { gWidgets2::dispose(complain) } - complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, + complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, expand = TRUE, container = complain_layout) } if (length(event) > 1) { @@ -331,26 +331,26 @@ eventsSingleWidget <- function(tag, displayed.moves, all.moves, detections, trig complain <<- gWidgets2::gwindow("Warning", width = 300, height = 20) complain_layout <- gWidgets2::ggroup(horizontal = FALSE, container = complain) gWidgets2::glabel("Select only one event to expand.", container = complain_layout) - + complain_function <- function(h, ...) { gWidgets2::dispose(complain) } - complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, + complain_btn <- gWidgets2::gbutton(text = "Close", handler = complain_function, action = NULL, expand = TRUE, container = complain_layout) } if (length(event) == 1) { link <- detections$Timestamp >= displayed.moves$First.time[displayed.moves$Valid][event] & detections$Timestamp <= displayed.moves$Last.time[displayed.moves$Valid][event] - + from <- match(displayed.moves$First.time[event], as.character(detections$Timestamp)) to <- match(displayed.moves$Last.time[event], as.character(detections$Timestamp)) sub.det <- detections[from:to, ] - + gWidgets2::visible(moves.window) <- FALSE - all.moves <<- graphicalInvalidateDetections(detections = sub.det, - displayed.moves = displayed.moves, - all.moves = all.moves, - event = event, + all.moves <<- graphicalInvalidateDetections(detections = sub.det, + displayed.moves = displayed.moves, + all.moves = all.moves, + event = event, tag = tag, silent = TRUE) @@ -398,7 +398,7 @@ eventsSingleWidget <- function(tag, displayed.moves, all.moves, detections, trig abort_function <- function(h, ...) { gWidgets2::dispose(confirm) } - confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) + confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) } btns[2, 5] <- gWidgets2::gbutton(text = "Submit and close", handler = close_function, action = NULL, container = btns) @@ -419,13 +419,13 @@ eventsSingleWidget <- function(tag, displayed.moves, all.moves, detections, trig } # nocov end #' Detections Widget (Tabbed version) -#' +#' #' @inheritParams widget_args -#' +#' #' @return A vector of detection validities. -#' +#' #' @keywords internal -#' +#' detectionsTabbedWidget <- function(event, tag, to.print, silent) { # nocov start appendTo("debug", "Running detectionsTabbedWidget.") @@ -441,16 +441,16 @@ detectionsTabbedWidget <- function(event, tag, to.print, silent) { # nocov start message("M: Please wait while the GUI loads."); flush.console() - w2 <- gWidgets2::gwindow(paste0("Detections for valid event ", event, " from tag ", tag ,"."), + w2 <- gWidgets2::gwindow(paste0("Detections for valid event ", event, " from tag ", tag ,"."), width = 900, height = 500, visible = FALSE) on.exit({if(gWidgets2::isExtant(w2)) gWidgets2::dispose(w2)}, add = TRUE) - + g2 <- gWidgets2::ggroup(horizontal = FALSE, container = w2) hdr2 <- gWidgets2::glayout(container = g2) hdr2[1, 1, expand = TRUE] <- gWidgets2::glabel("Usage notes:\n - Edit detection validity by selecting rows and choosing the desired action below.\n - Loading large tables can take some time. Please wait until the interaction buttons show up at the bottom of this window.", container = hdr2) hdr2[2, 1, expand = TRUE] <- gWidgets2::glabel("This table is very long!\n - Please allow some time for the action buttons to complete their tasks (particularly those that span multiple pages).\n - _Please wait_ until the buttons appear at the bottom of the page before performing any action!", container = hdr2) - + tbl2 <- list() nb <- gWidgets2::gnotebook(tab.pos = 3, expand = TRUE, container = g2) # add handler that keeps track of current tab @@ -555,7 +555,7 @@ detectionsTabbedWidget <- function(event, tag, to.print, silent) { # nocov start abort_function <- function(h, ...) { gWidgets2::dispose(confirm) } - confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) + confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) } btns2[2, 6] <- gWidgets2::gbutton(text = "Submit and close", handler = close_function, action = NULL, container = btns2) @@ -576,13 +576,13 @@ detectionsTabbedWidget <- function(event, tag, to.print, silent) { # nocov start } # nocov end #' Detections Widget (Single table version) -#' +#' #' @inheritParams widget_args -#' +#' #' @return A vector of detection validities. -#' +#' #' @keywords internal -#' +#' detectionsSingleWidget <- function(event, tag, to.print, silent) { # nocov start appendTo("debug", "Running detectionsSingleWidget.") @@ -601,7 +601,7 @@ detectionsSingleWidget <- function(event, tag, to.print, silent) { # nocov start width = 900, height = 500, visible = FALSE) on.exit({if(gWidgets2::isExtant(w2)) gWidgets2::dispose(w2)}, add = TRUE) - + g2 <- gWidgets2::ggroup(horizontal = FALSE, container = w2) hdr2 <- gWidgets2::glayout(container = g2) hdr2[1, 1, expand = TRUE] <- gWidgets2::glabel("Usage notes:\n - Edit detection validity by selecting rows and choosing the desired action below.\n - Loading large tables can take some time. Please wait until the interaction buttons show up at the bottom of this window.", container = hdr2) @@ -670,7 +670,7 @@ detectionsSingleWidget <- function(event, tag, to.print, silent) { # nocov start abort_function <- function(h, ...) { gWidgets2::dispose(confirm) } - confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) + confirm_btns[1, 2, expand = TRUE] <- gWidgets2::gbutton(text = "Return", handler = abort_function, action = NULL, container = confirm_btns) } btns2[2, 5] <- gWidgets2::gbutton(text = "Submit and close", handler = close_function, action = NULL, container = btns2) diff --git a/R/z_examples.R b/R/z_examples.R index 2f83124..a399d7d 100644 --- a/R/z_examples.R +++ b/R/z_examples.R @@ -1,5 +1,5 @@ #' Deprecated function. -#' +#' #' Use blankWorkspace instead. #' #' @inheritParams blankWorkspace @@ -142,7 +142,7 @@ Once finished, explore the html report and the object 'results' for the output." #' \item{Longitude}{The longitude of the hydrophone station or release site in WGS84} #' \item{x}{The x coordinate of the hydrophone station or release site in EPSG 32632} #' \item{y}{The y coordinate of the hydrophone station or release site in EPSG 32632} -#' \item{Array}{If documenting a hydrophone station, the array to which the station belongs. +#' \item{Array}{If documenting a hydrophone station, the array to which the station belongs. #' If documenting a release site, the first array(s) where the fish is expected to be detected.} #' \item{Section}{The Section to which the hydrophone station belongs (irrelevant for the release sites).} #' \item{Type}{The type of spatial object (must be either 'Hydrophone' or 'Release')} @@ -227,7 +227,7 @@ NULL #' Example migration results #' -#' A list with the results of a migration analysis ran on the example data. +#' A list with the results of a migration analysis ran on the example data. #' Note: Many objects were trimmed to reduce package size. Use exampleWorkspace() #' To run an analysis on the example data and obtain a full results object. #' diff --git a/R/zzz.R b/R/zzz.R index 6a83a52..ea7ec05 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -5,12 +5,12 @@ new.ver <- tryCatch(old.packages(instPkgs = aux, repos = "https://cloud.r-project.org"), warning = function(w) NULL, error = function(e) NULL) if (!is.null(new.ver)) { # nocov start packageStartupMessage(paste0("-------------------------------------------------------------\n!!! A NEW VERSION of actel is available! (v.", inst.ver, " -> v.", new.ver[, "ReposVer"], ")\n!!! You should update actel before continuing.\n!!! You can update your packages by running update.packages()\n-------------------------------------------------------------\n")) - } # nocov end + } # nocov end - # temporary warning message - ctime <- file.info(find.package(pkgname, libname))$ctime - if (difftime(Sys.time(), ctime, units = "day") <= 7) - packageStartupMessage("---------------------------------------------------------------\n!!! IMPORTANT NOTE:\n!!!\n!!! A silent bug was found in how migration() handles parallel\n!!! sections. This bug is still present, but it does not affect\n!!! all datasets. It can impact the number of animals reported\n!!! to have passed by a given section.\n!!! \n!!! Until the issue is resolved, actel will now stop if it \n!!! detects parallel sections. If you are unsure if your study\n!!! area has parallel sections, try running the analyses again\n!!! with version 1.3.0.\n!!!\n!!! You can read more about this issue here:\n!!! https://hugomflavio.github.io/actel-website/issue_79.html\n!!!\n!!! (This message will stop being displayed in ", round(7 - difftime(Sys.time(), ctime, units = "day"), 0), " days)\n---------------------------------------------------------------\n") + # temporary warning message + ctime <- file.info(find.package(pkgname, libname))$ctime + if (difftime(Sys.time(), ctime, units = "day") <= 7) + packageStartupMessage("---------------------------------------------------------------\n!!! IMPORTANT NOTE:\n!!!\n!!! A silent bug was found in how migration() handles parallel\n!!! sections. This bug is still present, but it does not affect\n!!! all datasets. It can impact the number of animals reported\n!!! to have passed by a given section.\n!!! \n!!! Until the issue is resolved, actel will now stop if it \n!!! detects parallel sections. If you are unsure if your study\n!!! area has parallel sections, try running the analyses again\n!!! with version 1.3.0.\n!!!\n!!! You can read more about this issue here:\n!!! https://hugomflavio.github.io/actel-website/issue_79.html\n!!!\n!!! (This message will stop being displayed in ", round(7 - difftime(Sys.time(), ctime, units = "day"), 0), " days)\n---------------------------------------------------------------\n") } utils::globalVariables(c("example.spatial", "example.biometrics", "example.detections", "example.deployments"))