diff --git a/R/check.R b/R/check.R index 9cb5a70..6a10c61 100644 --- a/R/check.R +++ b/R/check.R @@ -987,8 +987,8 @@ checkReport <- function(report){ #' #' @keywords internal #' -checkFirstDetBackFromRelease <- function(movements, tag, bio, detections, arrays, spatial, GUI, save.tables.locally, n) { - event(type = "debug", "Running checkFirstDetBackFromRelease.") +checkFirstMove <- function(movements, tag, bio, detections, arrays, spatial, GUI, save.tables.locally, n) { + event(type = "debug", "Running checkFirstMove.") # NOTE: The NULL variables below are actually column names used by data.table. # This definition is just to prevent the package check from issuing a note due unknown variables. Valid <- NULL diff --git a/R/explore.R b/R/explore.R index f76b6a4..3112a75 100644 --- a/R/explore.R +++ b/R/explore.R @@ -450,7 +450,7 @@ explore <- function( 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 <- overrideChecks(moves = movements[[tag]], tag = tag, detections = detections.list[[tag]], GUI = GUI, save.tables.locally = save.tables.locally, n = counter) } # nocov end return(output) diff --git a/R/helper.R b/R/helper.R index 675eebe..c970138 100644 --- a/R/helper.R +++ b/R/helper.R @@ -1,3 +1,79 @@ +#' Parse argument and its value as a string +#' +#' used to store the calls of the main actel functions as a string +#' +#' @param arg the argument to be parsed +#' @param arg_val an optional argument, to use as the value of the argument +#' used in "arg". Used when arg is, in itself, a complex object provided +#' by the user. E.g. a datapack, or an argument of preload. +#' +#' @return A string showing the argument and its value, as it would have been +#' inputted into the R console. +#' +#' @keywords internal +#' +parse_arg <- function(arg, arg_val) { + output <- paste0(deparse(substitute(arg)), " = ") + + if (!missing(arg_val)) { + return(paste0(output, arg_val)) + } + if (is.null(arg)) { + return(paste0(output, "NULL")) + } + + if (is.character(arg)) { + a <- "'" + b <- "', '" + } else { + a <- "" + b <- ", " + } + if (is.list(arg)) { + output <- paste0(output, parse_list(arg)) + } else { + if (length(arg) == 1) { + output <- paste0(output, a, arg, a) + } else { + output <- paste0(output, "c(", a, paste0(arg, collapse = b), a, ")") + } + } + return(output) +} + +#' Helper to parse list arguments +#' +#' Used inside [parse_arg()] to properly parse list arguments +#' +#' @inheritParams parse_arg +#' +#' @return A string showing the list as it would have been +#' inputted into the R console. +#' +#' @keywords internal +#' +parse_list <- function(arg) { + aux <- sapply(1:length(arg), function(i) { + if (is.character(arg[[i]])) { + a <- "'" + b <- "', '" + } else { + a <- "" + b <- ", " + } + name_i <- names(arg)[i] + content <- paste(arg[[i]], collapse = b) + if (length(arg[[i]]) == 1) { + output_i <- paste0("'", name_i,"' = ", a, content, a) + } else { + output_i <- paste0("'", name_i,"' = c(", a, content, a, ")") + } + return(output_i) + }) + output <- paste0("list(", paste0(aux, collapse = ", "), ")") + return(output) +} + #' collapse event indexes into ranges #' #' @param x a numerical vector diff --git a/R/migration.R b/R/migration.R index 2f7f8fc..a637d41 100644 --- a/R/migration.R +++ b/R/migration.R @@ -3,9 +3,9 @@ #' The \code{migration} analysis runs the same initial checks as \code{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 animal/tag has been acting -#' odd. Multiple options allow you to tweak the analysis to fit your study -#' perfectly. +#' migration. Additional plots help you find out if some animal/tag has been +#' acting 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 #' be aligned in the results. @@ -48,40 +48,53 @@ #' #' @return A list containing: #' \itemize{ -#' \item \code{detections}: A list containing all detections for each target tag; -#' \item \code{valid.detections}: A list containing the valid detections for each target tag; -#' \item \code{spatial}: A list containing the spatial information used during the analysis; -#' \item \code{deployments}: A data frame containing the deployments of each receiver; -#' \item \code{arrays}: A list containing the array details used during the analysis; -#' \item \code{movements}: A list containing all movement events for each target tag; -#' \item \code{valid.movements}: A list containing the valid movement events for each target tag; -#' \item \code{section.movements}: A list containing the valid section shifts for each target tag; -#' \item \code{status.df}: A data.frame containing summary information for each tag, including the -#' following columns: +#' \item \code{detections}: A list containing all detections for each target +#' tag; +#' \item \code{valid.detections}: A list containing the valid detections for +#' each target tag; +#' \item \code{spatial}: A list containing the spatial information used during +#' the analysis; +#' \item \code{deployments}: A data frame containing the deployments of each +#' receiver; +#' \item \code{arrays}: A list containing the array details used during the +#' analysis; +#' \item \code{movements}: A list containing all movement events for each +#' target tag; +#' \item \code{valid.movements}: A list containing the valid movement events +#' for each target tag; +#' \item \code{section.movements}: A list containing the valid section shifts +#' for each target tag; +#' \item \code{status.df}: A data.frame containing summary information for each +#' tag, including the following columns: #' \itemize{ -#' \item \emph{Times.entered.\[section\]}: Number of times the tag was recorded -#' entering a given section. +#' \item \emph{Times.entered.\[section\]}: Number of times the tag was +#' recorded entering a given section. #' \item \emph{Average.time.until.\[section\]}: Time spent between release -#' or leaving another section and reaching at the given section. -#' \item \emph{Average.speed.to.\[section\]}: Average speed from release or leaving -#' one section and reaching the given section (if speed.method = "last to first"), -#' or from release/leaving one section and leaving the given section (if speed.method -#' = "last to last"). +#' or leaving another section and reaching at the given section. +#' \item \emph{Average.speed.to.\[section\]}: Average speed from release or +#' leaving one section and reaching the given section (if +#' speed.method = "last to first"), or from release/leaving one +#' section and leaving the given section +#' (if speed.method = "last to last"). #' \item \emph{First.array.\[section\]}: Array in which the tag was -#' first detected in a given section -#' \item \emph{First.station.\[section\]}: Standard name of the first station -#' where the tag was detected in a given section -#' \item \emph{First.arrived.\[section\]}: Very first arrival time at a given section -#' \item \emph{Average.time.in.\[section\]}: Average time spent within a given section -#' at each stay. -#' \item \emph{Average.speed.in.\[section\]}: Average speed within a given section -#' at each stay (only displayed if speed.method = "last to first"). +#' first detected in a given section +#' \item \emph{First.station.\[section\]}: Standard name of the first +#' station where the tag was detected in a given section +#' \item \emph{First.arrived.\[section\]}: Very first arrival time at a +#' given section +#' \item \emph{Average.time.in.\[section\]}: Average time spent within a +#' given section at each stay. +#' \item \emph{Average.speed.in.\[section\]}: Average speed within a given +#' section at each stay (only displayed if +#' speed.method = "last to first"). #' \item \emph{Last.array.\[section\]}: Array in which the tag was -#' last detected in a given section +#' last detected in a given section #' \item \emph{Last.station.\[section\]}: Standard name of the last station -#' where the tag was detected in a given section -#' \item \emph{Last.left.\[section\]}: Very last departure time from a given section -#' \item \emph{Total.time.in\[section\]}: Total time spent in a given section +#' where the tag was detected in a given section +#' \item \emph{Last.left.\[section\]}: Very last departure time from a +#' given section +#' \item \emph{Total.time.in\[section\]}: Total time spent in a given +#' section #' \item \emph{Very.last.array}: Last array where the tag was detected #' \item \emph{Status}: Fate assigned to the tag #' \item \emph{Valid.detections}: Number of valid detections @@ -93,25 +106,31 @@ #' \item 'Skipped' if no data was found for the tag, #' \item 'Auto' if no user interaction was required, #' \item 'Manual' if user interaction was suggested and the user made -#' changes to the validity of the events, +#' changes to the validity of the events, #' \item 'Overridden' if the user listed the tag in the -#' \code{override} argument. +#' \code{override} argument. #' } #' \item \emph{Comments}: Comments left by the user during the analysis #' } -#' \item \code{section.overview}: A data frame containing the number of tags that -#' disappeared in each section; +#' \item \code{section.overview}: A data frame containing the number of tags +#' that disappeared in each section; #' \item \code{group.overview}: A list containing the number of known and -#' estimated tags to have passed through each array, divided by group; +#' estimated tags to have passed through each array, divided by group; #' \item \code{release.overview}: A list containing the number of known and -#' estimated tags to have passed through each array, divided by group and release sites; -#' \item \code{matrices}: A list of CJS matrices used for the efficiency calculations; -#' \item \code{overall.CJS}: A list of CJS results of the inter-array CJS calculations; -#' \item \code{intra.array.CJS}: A list of CJS results of the intra-array CJS calculations; -#' \item \code{times}: A data frame containing all arrival times (per tag) at each array; -#' \item \code{rsp.info}: A list containing appendix information for the RSP package; +#' estimated tags to have passed through each array, divided by group +#' and release sites; +#' \item \code{matrices}: A list of CJS matrices used for the efficiency +#' calculations; +#' \item \code{overall.CJS}: A list of CJS results of the inter-array CJS +#' calculations; +#' \item \code{intra.array.CJS}: A list of CJS results of the intra-array CJS +#' calculations; +#' \item \code{times}: A data frame containing all arrival times (per tag) at +#' each array; +#' \item \code{rsp.info}: A list containing appendix information for the RSP +#' package; #' \item \code{dist.mat}: The distance matrix used in the analysis (if a valid -#' distance matrix was supplied) +#' distance matrix was supplied) #' } #' #' @seealso \code{\link{explore}}, \code{\link{residency}} @@ -162,8 +181,9 @@ migration <- function( # clean up any lost helpers deleteHelpers() - if (file.exists(paste0(tempdir(), "/actel_debug_file.txt"))) + if (file.exists(paste0(tempdir(), "/actel_debug_file.txt"))) { file.remove(paste0(tempdir(), "/actel_debug_file.txt")) + } # ------------------------ # debug lines @@ -233,37 +253,37 @@ migration <- function( # ------------------------ # Store function call - the_function_call <- paste0("migration(tz = ", ifelse(is.null(tz), "NULL", paste0("'", tz, "'")), - ", section.order = ", ifelse(is.null(section.order), "NULL", paste0("c('", paste(section.order, collapse = "', '"), "')")), - ", datapack = ", ifelse(is.null(datapack), "NULL", deparse(substitute(datapack))), - ", success.arrays = ", ifelse(is.null(success.arrays), "NULL", paste0("c('", paste(success.arrays, collapse = "', '"), "')")), - ", max.interval = ", max.interval, - ", min.total.detections = ", min.total.detections, - ", min.per.event = ", paste0("c(", paste(min.per.event, collapse = ", "), ")"), - ", start.time = ", ifelse(is.null(start.time), "NULL", paste0("'", start.time, "'")), - ", stop.time = ", ifelse(is.null(stop.time), "NULL", paste0("'", stop.time, "'")), - ", speed.method = '", speed.method, "'", - ", speed.warning = ", ifelse(is.null(speed.warning), "NULL", speed.warning), - ", speed.error = ", ifelse(is.null(speed.error), "NULL", speed.error), - ", jump.warning = ", jump.warning, - ", jump.error = ", jump.error, - ", inactive.warning = ", ifelse(is.null(inactive.warning), "NULL", inactive.warning), - ", inactive.error = ", ifelse(is.null(inactive.error), "NULL", inactive.error), - ", exclude.tags = ", ifelse(is.null(exclude.tags), "NULL", paste0("c('", paste(exclude.tags, collapse = "', '"), "')")), - ", override = ", ifelse(is.null(override), "NULL", paste0("c(", paste(override, collapse = ", "), ")")), - ", report = ", ifelse(report, "TRUE", "FALSE"), - ", auto.open = ", ifelse(auto.open, "TRUE", "FALSE"), - ", discard.orphans = ", ifelse(discard.orphans, "TRUE", "FALSE"), - ", discard.first = ", ifelse(is.null(discard.first), "NULL", discard.first), - ", save.detections = ", ifelse(save.detections, "TRUE", "FALSE"), - ", if.last.skip.section = ", ifelse(if.last.skip.section, "TRUE", "FALSE"), - ", replicates = ", ifelse(is.null(replicates),"NULL", paste0("list(", paste(sapply(1:length(replicates), function(i) paste0("'", names(replicates)[i], "' = c('", paste(replicates[[i]], collapse = "', '"), "')")), collapse = ", "), ")")), - ", disregard.parallels = ", ifelse(disregard.parallels, "TRUE", "FALSE"), - ", GUI = '", GUI, "'", - ", save.tables.locally = ", ifelse(save.tables.locally, "TRUE", "FALSE"), - ", print.releases = ", ifelse(print.releases, "TRUE", "FALSE"), - ", detections.y.axis = '", detections.y.axis, "'", - ")") + the_function_call <- paste0("migration(", + parse_arg(tz), ", ", + parse_arg(section.order), ", ", + parse_arg(datapack, + arg_val = deparse(substitute(datapack))), ", ", + parse_arg(success.arrays), ", ", + parse_arg(max.interval), ", ", + parse_arg(min.total.detections), ", ", + parse_arg(min.per.event), ", ", + parse_arg(stop.time), ", ", + parse_arg(speed.method), ", ", + parse_arg(speed.warning), ", ", + parse_arg(speed.error), ", ", + parse_arg(jump.warning), ", ", + parse_arg(jump.error), ", ", + parse_arg(inactive.warning), ", ", + parse_arg(inactive.error), ", ", + parse_arg(exclude.tags), ", ", + parse_arg(override), ", ", + parse_arg(report), ", ", + parse_arg(auto.open), ", ", + parse_arg(discard.orphans), ", ", + parse_arg(discard.first), ", ", + parse_arg(save.detections), ", ", + parse_arg(if.last.skip.section), ", ", + parse_arg(replicates), ", ", + parse_arg(disregard.parallels), ", ", + parse_arg(GUI), ", ", + parse_arg(save.tables.locally), ", ", + parse_arg(print.releases), ", ", + parse_arg(detections.y.axis), ")") event(type = "debug", the_function_call) # -------------------- @@ -298,9 +318,13 @@ migration <- function( # Load, structure and check the inputs if (is.null(datapack)) { - study.data <- loadStudyData(tz = tz, override = override, save.detections = save.detections, - start.time = start.time, stop.time = stop.time, discard.orphans = discard.orphans, - section.order = section.order, exclude.tags = exclude.tags, disregard.parallels = disregard.parallels) + study.data <- loadStudyData(tz = tz, override = override, + save.detections = save.detections, + start.time = start.time, stop.time = stop.time, + discard.orphans = discard.orphans, + section.order = section.order, + exclude.tags = exclude.tags, + disregard.parallels = disregard.parallels) } else { event(type = c("screen", "report"), "M: Running analysis on preloaded data (compiled on ", @@ -338,7 +362,8 @@ migration <- function( # Verify that replicate information is valid not_null <- !is.null(replicates) - any_mismatch <- not_null && any(is.na(match(names(replicates), names(arrays)))) + any_mismatch <- not_null && any(is.na(match(names(replicates), + names(arrays)))) if (any_mismatch) { event(type = "stop", "Some of the array names listed in the 'replicates' argument", @@ -405,13 +430,15 @@ migration <- function( # Discard early detections, if required if (!is.null(discard.first) && discard.first > 0) - detections.list <- discardFirst(input = detections.list, bio, trim = discard.first) + detections.list <- discardFirst(input = detections.list, + bio = bio, trim = discard.first) # Compile array movements event(type = c("screen", "report"), "M: Creating movement records for the valid tags.") - movements <- groupMovements(detections.list = detections.list, bio = bio, spatial = spatial, - speed.method = speed.method, max.interval = max.interval, tz = tz, + movements <- groupMovements(detections.list = detections.list, bio = bio, + spatial = spatial, speed.method = speed.method, + max.interval = max.interval, tz = tz, dist.mat = dist.mat) if (is.null(discard.first)) { @@ -463,10 +490,13 @@ migration <- function( movement.names <- names(movements) # clean override based on movements - if (is.numeric(override)) - trigger_override_warning <- any(link <- !override %in% extractSignals(movement.names)) - else - trigger_override_warning <- any(link <- !override %in% movement.names) + if (is.numeric(override)) { + link <- !override %in% extractSignals(movement.names) + trigger_override_warning <- any(link) + } else { + link <- !override %in% movement.names + trigger_override_warning <- any(link) + } if (trigger_override_warning) { event(type = c("warning", "screen", "report"), @@ -479,8 +509,9 @@ migration <- function( } # convert numeric override to full tag override to prevent problems downstream - if (is.numeric(override)) + if (is.numeric(override)) { override <- movement.names[match(override, extractSignals(movement.names))] + } movements <- lapply(seq_along(movements), function(i) { tag <- names(movements)[i] @@ -489,36 +520,61 @@ migration <- function( event(type = "debug", "Checking movement quality for tag ", tag,".") if (is.na(match(tag, override))) { - output <- checkMinimumN(movements = movements[[tag]], tag = tag, min.total.detections = min.total.detections, - min.per.event = min.per.event[1], n = counter) - - 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, - 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, - spatial = spatial, jump.warning = jump.warning, jump.error = jump.error, GUI = GUI, - detections = detections.list[[tag]], save.tables.locally = save.tables.locally, n = counter) + output <- checkMinimumN(movements = movements[[tag]], tag = tag, + min.total.detections = min.total.detections, + min.per.event = min.per.event[1], n = counter) + + output <- checkFirstMove(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, 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, spatial = spatial, + jump.warning = jump.warning, + jump.error = jump.error, GUI = GUI, + detections = detections.list[[tag]], + save.tables.locally = save.tables.locally, + n = counter) 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, - speed.error = speed.error, GUI = GUI, save.tables.locally = save.tables.locally) + 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, + speed.error = speed.error, GUI = GUI, + save.tables.locally = save.tables.locally) rm(temp.valid.movements) } if (do.checkInactiveness) { - 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) + 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 { - output <- overrideValidityChecks(moves = movements[[tag]], detections = detections.list[[tag]], n = counter, # nocov - tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) # nocov + output <- overrideChecks(moves = movements[[tag]], + detections = detections.list[[tag]], + n = counter, tag = tag, GUI = GUI, + save.tables.locally = save.tables.locally)# nocov } return(output) }) @@ -530,66 +586,80 @@ migration <- function( event(type = c("screen", "report"), "M: Compiling and checking section movements for the valid tags.") - section.movements <- lapply(seq_along(movements), function(i) { + secmoves <- lapply(seq_along(movements), function(i) { tag <- names(movements)[i] counter <- paste0("(", i, "/", length(movements), ")") event(type = "debug", "Compiling section movements for tag ", tag,".") - aux <- sectionMovements(movements = movements[[i]], spatial = spatial, valid.dist = attributes(dist.mat)$valid) + aux <- sectionMovements(movements = movements[[i]], spatial = spatial, + valid.dist = attributes(dist.mat)$valid) - if (!is.null(aux)) { # interesting... why do I have this here but not on residency? hm... - aux <- checkMinimumN(movements = aux, tag = tag, min.total.detections = 0, # don't run the minimum total detections check here. + if (!is.null(aux)) { + # don't run the minimum total detections check here (i.e. set it to 0); + # that's already done when compiling the array movements. + aux <- checkMinimumN(movements = aux, tag = tag, min.total.detections = 0, min.per.event = min.per.event[2], n = counter) - output <- checkLinearity(secmoves = aux, tag = tag, spatial = spatial, arrays = arrays, - GUI = GUI, save.tables.locally = save.tables.locally, n = counter) + output <- checkLinearity(secmoves = aux, tag = tag, spatial = spatial, + arrays = arrays, GUI = GUI, + save.tables.locally = save.tables.locally, + n = counter) return(output) } else { return(NULL) } }) - names(section.movements) <- names(movements) - section.movements <- section.movements[!sapply(section.movements, is.null)] + names(secmoves) <- names(movements) + secmoves <- secmoves[!sapply(secmoves, is.null)] + # Update array movements based on section movements validity - movements <- updateValidity(arrmoves = movements, secmoves = section.movements) + movements <- updateValidity(arrmoves = movements, + secmoves = secmoves) # compile valid movements event(type = c("screen", "report"), "M: Filtering valid array movements.") - - valid.movements <- assembleValidMoves(movements = movements, bio = bio, discard.first = discard.first, - speed.method = speed.method, dist.mat = dist.mat) + valid.movements <- assembleValidMoves(movements = movements, bio = bio, + discard.first = discard.first, + speed.method = speed.method, + dist.mat = dist.mat) event(type = c("screen", "report"), "M: Filtering valid section movements.") - - section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial, - valid.dist = attributes(dist.mat)$valid) + secmoves <- assembleValidSecMoves(valid.moves = valid.movements, + spatial = spatial, + valid.dist = attributes(dist.mat)$valid) event(type = c("screen", "report"), "M: Compiling migration timetable.") - - timetable <- assembleTimetable(secmoves = section.movements, valid.moves = valid.movements, all.moves = movements, spatial = spatial, - arrays = arrays, bio = bio, tz = tz, dist.mat = dist.mat, speed.method = speed.method, - if.last.skip.section = if.last.skip.section, success.arrays = success.arrays) - - status.df <- assembleOutput(timetable = timetable, bio = bio, spatial = spatial, + timetable <- assembleTimetable(secmoves = secmoves, + valid.moves = valid.movements, + all.moves = movements, spatial = spatial, + arrays = arrays, bio = bio, tz = tz, + dist.mat = dist.mat, + speed.method = speed.method, + if.last.skip.section = if.last.skip.section, + success.arrays = success.arrays) + + status.df <- assembleOutput(timetable = timetable, bio = bio, + spatial = spatial, dist.mat = dist.mat, tz = tz) event(type = c("screen", "report"), "M: Compiling summary information tables.") - - section.overview <- assembleSectionOverview(status.df = status.df, spatial = spatial) + section.overview <- assembleSectionOverview(status.df = status.df, + 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") + times <- getTimes(input = aux, move.type = "array", + event.type = "arrival", n.events = "first") rm(aux) event(type = "Screen", "M: Validating detections.") - - recipient <- validateDetections(detections.list = detections.list, movements = valid.movements) + recipient <- validateDetections(detections.list = detections.list, + movements = valid.movements) detections <- recipient$detections valid.detections <- recipient$valid.detections rm(recipient) @@ -597,10 +667,16 @@ migration <- function( # ------------------------------------- # CJS stuff - the.matrices <- assembleMatrices(spatial = spatial, movements = valid.movements, status.df = status.df, - arrays = arrays, paths = paths, dotmat = dotmat)[[2]] # extract only the minimum matrix + the.matrices <- assembleMatrices(spatial = spatial, + movements = valid.movements, + status.df = status.df, + arrays = arrays, paths = paths, + dotmat = dotmat) + # keep only the minimum matrix + the.matrices <- the.matrices[[2]] - m.by.array <- breakMatricesByArray(m = the.matrices, arrays = arrays, type = "peers") + m.by.array <- breakMatricesByArray(m = the.matrices, arrays = arrays, + type = "peers") if (is.null(m.by.array[[1]])) { calculate.efficiency <- FALSE @@ -624,41 +700,61 @@ migration <- function( release_nodes <- as.data.frame(table(bio$Group, bio$Release.site)) colnames(release_nodes) <- c("Group", "Release.site", "n") - release_nodes$Array <- spatial$release.sites$Array[match(release_nodes$Release.site, spatial$release.sites$Standard.name)] - release_nodes$Combined <- paste(release_nodes[, 1], release_nodes[, 2], sep = ".") + link <- match(release_nodes$Release.site, + spatial$release.sites$Standard.name) + release_nodes$Array <- spatial$release.sites$Array[link] + release_nodes$Combined <- paste(release_nodes[, 1], release_nodes[, 2], + sep = ".") - overall.CJS <- assembleArrayCJS(mat = the.matrices, CJS = CJS.list, arrays = arrays, releases = release_nodes, silent = FALSE) + overall.CJS <- assembleArrayCJS(mat = the.matrices, CJS = CJS.list, + arrays = arrays, releases = release_nodes, + silent = FALSE) if (!is.null(replicates)) { - intra.array.matrices <- getDualMatrices(replicates = replicates, CJS = overall.CJS, spatial = spatial, detections.list = valid.detections) - recipient <- includeIntraArrayEstimates(m = intra.array.matrices, CJS = overall.CJS) + intra_mats <- getDualMatrices(replicates = replicates, + CJS = overall.CJS, + spatial = spatial, + detections.list = valid.detections) + recipient <- includeIntraArrayEstimates(m = intra_mats, CJS = overall.CJS) overall.CJS <- recipient$CJS intra.array.CJS <- recipient$intra.CJS rm(recipient) } else { - intra.array.matrices <- NULL + intra_mats <- NULL intra.array.CJS <- NULL } - aux <- mbSplitCJS(mat = m.by.array, fixed.efficiency = overall.CJS$efficiency) + aux <- mbSplitCJS(mat = m.by.array, + fixed.efficiency = overall.CJS$efficiency) aux <- aux[names(the.matrices)] - split.CJS <- assembleSplitCJS(mat = the.matrices, CJS = aux, arrays = arrays, releases = release_nodes, intra.CJS = intra.array.CJS) - release.overview <- lapply(names(split.CJS), function(i, releases = spatial$release.sites) { + split.CJS <- assembleSplitCJS(mat = the.matrices, CJS = aux, + arrays = arrays, releases = release_nodes, + intra.CJS = intra.array.CJS) + + release.overview <- lapply(names(split.CJS), + function(i, releases = spatial$release.sites) { output <- split.CJS[[i]] - x <- unlist(stringr::str_split(i, "\\.", 2)) - output$Release <- rep(c(releases[releases$Standard.name == x[2], paste0("n.", x[1])], NA, NA), 2) + aux <- unlist(stringr::str_split(i, "\\.", 2)) + rows <- releases$Standard.name == aux[2] + cols <- paste0("n.", aux[1]) + output$Release <- rep(c(releases[rows, cols], NA, NA), 2) output <- output[, c(ncol(output), 1:(ncol(output) - 1))] return(output) }) names(release.overview) <- names(aux) rm(aux) - aux <- mbGroupCJS(mat = m.by.array, status.df = status.df, fixed.efficiency = overall.CJS$efficiency) - group.CJS <- assembleGroupCJS(mat = the.matrices, CJS = aux, arrays = arrays, releases = release_nodes, intra.CJS = intra.array.CJS) - group.overview <- lapply(names(group.CJS), function(i, releases = spatial$release.sites) { + aux <- mbGroupCJS(mat = m.by.array, status.df = status.df, + fixed.efficiency = overall.CJS$efficiency) + group.CJS <- assembleGroupCJS(mat = the.matrices, CJS = aux, + arrays = arrays, releases = release_nodes, + intra.CJS = intra.array.CJS) + group.overview <- lapply(names(group.CJS), + function(i, releases = spatial$release.sites) { output <- group.CJS[[i]] - x <- unlist(stringr::str_split(i, "\\.", 2))[1] - output$Release <- rep(c(sum(releases[, paste0("n.", x)]), NA, NA), 2) + aux <- unlist(stringr::str_split(i, "\\.", 2)) + cols <- paste0("n.", aux[1]) + output$Release <- rep(c(sum(releases[, cols]), NA, NA), 2) output <- output[, c(ncol(output), 1:(ncol(output) - 1))] return(output) }) @@ -670,10 +766,15 @@ migration <- function( if (!is.null(replicates)) { event(type = c("screen", "report"), "M: Calculating intra-array efficiency.") - intra.array.matrices <- getDualMatrices(replicates = replicates, CJS = overall.CJS, spatial = spatial, detections.list = valid.detections) - intra.array.CJS <- includeIntraArrayEstimates(m = intra.array.matrices, CJS = overall.CJS)$intra.CJS + intra_mats <- getDualMatrices(replicates = replicates, CJS = overall.CJS, + spatial = spatial, + detections.list = valid.detections) + intra.array.CJS <- includeIntraArrayEstimates(m = intra_mats, + CJS = overall.CJS) + # keep intra.CHS object only + intra.array.CJS <- intra.array.CJS$intra.CJS } else { - intra.array.matrices <- NULL + intra_mats <- NULL intra.array.CJS <- NULL } @@ -687,11 +788,15 @@ migration <- function( matrices <- the.matrices # extra info for potential RSP analysis - rsp.info <- list(analysis.type = "migration", analysis.time = the_time, bio = bio, - tz = tz, actel.version = utils::packageVersion("actel")) - - if (!is.null(override)) - override.fragment <- paste0('Manual mode has been triggered for **', length(override),'** tag(s).\n') + rsp.info <- list(analysis.type = "migration", analysis.time = the_time, + bio = bio, tz = tz, + actel.version = utils::packageVersion("actel")) + + if (!is.null(override)) { + override.fragment <- paste0('Manual mode has been', + ' triggered for **', length(override), + '** tag(s).\n') + } else override.fragment <- "" @@ -699,7 +804,8 @@ migration <- function( continue <- TRUE index <- 1 while (continue) { - if (file.exists(resultsname <- paste0("actel_migration_results.", index, ".RData"))) { + resultsname <- paste0("actel_migration_results.", index, ".RData") + if (file.exists(resultsname)) { index <- index + 1 } else { continue <- FALSE @@ -709,22 +815,34 @@ migration <- function( } if (interactive()) { # nocov start - decision <- userInput(paste0("Would you like to save a copy of the results to ", resultsname, "?(y/n) "), - choices = c("y", "n"), hash = "# save results?") + 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" } if (decision == "y") { # nocov start - event(type = c("screen", "report"), paste0("M: Saving results as '", resultsname, "'.")) + event(type = c("screen", "report"), + "M: Saving results as '", resultsname, "'.") + # These changes of name are here for consistency with earlier versions of + # actel. The exported names can be updated once we makde the big revamp + # in coding style (actel 2.0). + section.movements <- secmoves + intra.array.matrices <- intra_mats 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, - overall.CJS, intra.array.matrices, intra.array.CJS, times, rsp.info, dist.mat, file = resultsname) + 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, - overall.CJS, intra.array.matrices, intra.array.CJS, times, rsp.info, file = resultsname) + 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 event(type = c("screen", "report"), @@ -746,13 +864,18 @@ migration <- function( " the results, you can reload them using dataToList().") }) - if (dir.exists(paste0(tempdir(), "/actel_report_auxiliary_files"))) - unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), recursive = TRUE) + if (dir.exists(paste0(tempdir(), "/actel_report_auxiliary_files"))) { + unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), + recursive = TRUE) + } dir.create(paste0(tempdir(), "/actel_report_auxiliary_files")) - if (!getOption("actel.debug", default = FALSE)) - on.exit(unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), recursive = TRUE), add = TRUE) + if (!getOption("actel.debug", default = FALSE)) { + on.exit(add = TRUE, + unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), + recursive = TRUE)) + } biometric.fragment <- printBiometrics(bio = bio) @@ -795,10 +918,14 @@ migration <- function( circular.plots <- printCircular(times = timesToCircular(times), bio = bio) - if (nrow(section.overview) > 3) - survival.graph.size <- "width=90%" else survival.graph.size <- "height=4in" + if (nrow(section.overview) > 3) { + survival.graph.size <- "width=90%" + } else { + survival.graph.size <- "height=4in" + } - if (any(sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))))) { + check <- sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))) + if (any(check)) { sensor.plots <- printSensorData(detections = valid.detections, spatial = spatial, rsp.info = rsp.info, @@ -848,44 +975,52 @@ migration <- function( continue <- TRUE index <- 1 while (continue) { - if(file.exists(reportname <- paste0("actel_migration_report.", index, ".html"))) { + reportname <- paste0("actel_migration_report.", index, ".html") + if(file.exists(reportname)) { index <- index + 1 } else { continue <- FALSE } } - event(type = "screen", - "M: An actel report is already present in the current directory.\n", - " Saving new report as ", reportname, ".") + event(type = "screen", + "M: An actel report is already present in the current directory.\n", + " Saving new report as ", reportname, ".") rm(continue, index) } else { - event(type = "Screen", + event(type = "screen", "M: Saving actel report as 'actel_migration_report.html'.") } event(type = "debug", "Printing report rmd") - printMigrationRmd(override.fragment = override.fragment, - biometric.fragment = biometric.fragment, - section.overview = section.overview, - efficiency.fragment = efficiency.fragment, - display.progression = display.progression, - array.overview.fragment = array.overview.fragment, - survival.graph.size = survival.graph.size, - individual.plots = individual.plots, - circular.plots = circular.plots, - sensor.plots = sensor.plots, - spatial = spatial, - deployments = deployments, - valid.detections = valid.detections, - detections = detections, - detections.y.axis = detections.y.axis) + printMigrationRmd(override.fragment = override.fragment, + biometric.fragment = biometric.fragment, + section.overview = section.overview, + efficiency.fragment = efficiency.fragment, + display.progression = display.progression, + array.overview.fragment = array.overview.fragment, + survival.graph.size = survival.graph.size, + individual.plots = individual.plots, + circular.plots = circular.plots, + sensor.plots = sensor.plots, + spatial = spatial, + deployments = deployments, + valid.detections = valid.detections, + detections = detections, + detections.y.axis = detections.y.axis) event(type = "debug", "Converting report to html") - rmarkdown::render(input = paste0(tempdir(), "/actel_report_auxiliary_files/actel_migration_report.Rmd"), - output_dir = paste0(tempdir(), "/actel_report_auxiliary_files"), quiet = TRUE) + rmarkdown::render(input = paste0(tempdir(), + "/actel_report_auxiliary_files/", + "actel_migration_report.Rmd"), + output_dir = paste0(tempdir(), + "/actel_report_auxiliary_files"), + quiet = TRUE) event(type = "debug", "Moving report") - file.copy(paste0(tempdir(), "/actel_report_auxiliary_files/actel_migration_report.html"), reportname) + file.copy(from = paste0(tempdir(), + "/actel_report_auxiliary_files/", + "actel_migration_report.html"), + to = reportname) if (interactive() & auto.open) { # nocov start event(type = "debug", "Opening report.") browseURL(reportname) @@ -894,18 +1029,23 @@ migration <- function( trigger.report.error.message <- FALSE # ------------------ - jobname <- paste0(gsub(" |:", ".", as.character(Sys.time())), ".actel.log.txt") + 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) "), - choices = c("y", "n"), hash = "# save job log?") + 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" } if (decision == "y" | decision == "Y") { # nocov start event(type = "Screen", "M: Saving job log as '",jobname, "'.") - file.copy(paste(tempdir(), "temp_log.txt", sep = "/"), jobname) + file.copy(from = paste(tempdir(), "temp_log.txt", sep = "/"), + to = jobname) } # nocov end output <- list(detections = detections, @@ -915,20 +1055,21 @@ migration <- function( arrays = arrays, movements = movements, valid.movements = valid.movements, - section.movements = section.movements, + section.movements = secmoves, status.df = status.df, section.overview = section.overview, group.overview = group.overview, release.overview = release.overview, matrices = matrices, overall.CJS = overall.CJS, - intra.array.matrices = intra.array.matrices, + intra.array.matrices = intra_mats, intra.array.CJS = intra.array.CJS, times = times, rsp.info = rsp.info) - if (attributes(dist.mat)$valid) + if (attributes(dist.mat)$valid) { output$dist.mat <- dist.mat + } event(type = "screen", "M: Analysis completed!") @@ -941,44 +1082,64 @@ migration <- function( #' #' Creates a Rmd report and converts it to html. #' -#' @param override.fragment Rmarkdown string specifying the type of report for the header. -#' @param biometric.fragment Rmarkdown string specifying the biometric graphics drawn. -#' @param section.overview A summary table with the number of tags that disappeared/moved onwards at each section. -#' @param efficiency.fragment Rmarkdown string specifying the efficiency results. -#' @param display.progression Logical. If TRUE, the progression plot has been created and can be displayed. -#' @param array.overview.fragment Rmarkdown string specifying the array overview results. -#' @param survival.graph.size Rmarkdown string specifying the type size of the survival graphics. -#' @param individual.plots Rmarkdown string specifying the name of the individual plots. -#' @param circular.plots Rmarkdown string specifying the name of the circular plots. -#' @param sensor.plots Rmarkdown string specifying the name of the sensor plots. +#' @param override.fragment Rmarkdown string specifying the type of report for +#' the header. +#' @param biometric.fragment Rmarkdown string specifying the biometric graphics +#' drawn. +#' @param section.overview A summary table with the number of tags that +#' disappeared/moved onwards at each section. +#' @param efficiency.fragment Rmarkdown string specifying the efficiency +#' results. +#' @param display.progression Logical. If TRUE, the progression plot has been +#' created and can be displayed. +#' @param array.overview.fragment Rmarkdown string specifying the array +#' overview results. +#' @param survival.graph.size Rmarkdown string specifying the type size +#' of the survival graphics. +#' @param individual.plots Rmarkdown string specifying the name of the +#' individual plots. +#' @param circular.plots Rmarkdown string specifying the name of the +#' circular plots. +#' @param sensor.plots Rmarkdown string specifying the name of the sensor +#' plots. #' @inheritParams loadDetections #' #' @return No return value, called for side effects. #' #' @keywords internal #' -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, - detections, detections.y.axis){ +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, + detections, detections.y.axis){ event(type = "debug", "Running printMigrationRmd.") work.path <- paste0(tempdir(), "/actel_report_auxiliary_files/") if (!is.null(spatial$unknowns)) { - unknown.fragment <- paste0(' Number of relevant unknown receivers: **', sum(sapply(spatial$unknowns, length)), '** (of which ', length(spatial$unknowns$included),' were included)\n') + unknown.fragment <- paste0(' Number of relevant', + ' unknown receivers: **', + sum(sapply(spatial$unknowns, length)), + '** (of which ', + length(spatial$unknowns$included), + ' were included)\n') } else { unknown.fragment <- "" } if (!is.null(sensor.plots)) { - sensor.fragment <- paste0("### Sensor plots - -Note: - : The colouring in these plots will follow that of the individual detection plots, which can be modified using `detections.y.axis`. - : The data used for these graphics is stored in the `valid.detections` object. - : You can replicate these graphics and edit them as needed using the `plotSensors()` function. - -
\n", sensor.plots, "\n
") + sensor.fragment <- paste0("### Sensor plots\n\nNote:\n", + " : The colouring in these plots will follow", + " that of the individual detection plots, which", + " can be modified using `detections.y.axis`.\n", + " : The data used for these graphics is stored", + " in the `valid.detections` object.\n", + " : You can replicate these graphics and edit", + " them as needed using the `plotSensors()`", + " function.\n\n", + "
\n", sensor.plots, "\n
") } else { sensor.fragment <- NULL } @@ -987,14 +1148,18 @@ Note: report <- gsub("(\\\\|\")", "\\\\\\1", report) if (file.exists(paste0(tempdir(), '/temp_warnings.txt'))) { - warning.messages <- gsub("\\r", "", readr::read_file(paste0(tempdir(), '/temp_warnings.txt'))) + warning.messages <- readr::read_file(paste0(tempdir(), + '/temp_warnings.txt')) + warning.messages <- gsub("\\r", "", warning.messages) warning.messages <- gsub("(\\\\|\")", "\\\\\\1", warning.messages) } else { warning.messages <- 'No warnings were raised during the analysis.' } if (file.exists(paste0(tempdir(), '/temp_comments.txt'))) { - comment.fragment <- gsub("\\r", "", readr::read_file(paste0(tempdir(), '/temp_comments.txt'))) + comment.fragment <- readr::read_file(paste0(tempdir(), + '/temp_comments.txt')) + comment.fragment <- gsub("\\r", "", comment.fragment) comment.fragment <- gsub("(\\\\|\")", "\\\\\\1", comment.fragment) } else { comment.fragment <- 'No comments were included during the analysis.' @@ -1005,273 +1170,360 @@ Note: sink(paste0(work.path, "actel_migration_report.Rmd")) cat(paste0( -'--- -title: "Acoustic telemetry migration analysis" -author: "Actel R package (', utils::packageVersion("actel"), ')" -output: - html_document: - includes: - after_body: ', work.path, 'toc_menu_migration.html ---- - -### Summary - -Target folder: ', stringr::str_extract(pattern = '(?<=Target folder: )[^\r|^\n]*', string = report), ' - -Timestamp: **', stringr::str_extract(pattern = '(?<=Timestamp: )[^\r|^\n]*', string = report), '** - -Number of target tags: **`r I(nrow(status.df))`** - -', override.fragment,' - -Number of listed receivers: **', stringr::str_extract(pattern = '(?<=Number of ALS: )[0-9]*', string = report), '** (of which **', stringr::str_extract(pattern = '(?<=of which )[0-9]*', string = report), '** had no detections) - -', unknown.fragment,' - -Data time range: ', stringr::str_extract(pattern = '(?<=Data time range: )[^\r|^\n]*', string = report), ' - -Percentage of post-release valid detections: ', round(sum(unlist(lapply(valid.detections, nrow))) / sum(unlist(lapply(detections, nrow))) * 100, 2), '% - -Found a bug? [**Report it here.**](https://github.com/hugomflavio/actel/issues) - -Want to cite actel in a publication? Run `citation(\'actel\')` - -### Study area - -Arrays with the same background belong to the same section. Release sites are marked with "R.S.". Arrays connected with an arrow indicate that the animals can only pass in one direction. - - - -### Receiver stations - -', paste(knitr::kable(spatial$stations, row.names = FALSE), collapse = "\n"), ' - -### Deployments - -', paste(knitr::kable(deployments, row.names = FALSE), collapse = "\n"), ' - -### Release sites - -', paste(knitr::kable(spatial$release.sites, row.names = FALSE), collapse = "\n"), ' - -### Array forward efficiency - -', efficiency.fragment,' - -### Warning messages - -```{r warnings, echo = FALSE, comment = NA} -cat("', warning.messages, '") -``` - -### User comments - -```{r comments, echo = FALSE, comment = NA} -cat("', comment.fragment, '") -``` - -', ifelse(biometric.fragment == '', '', paste0('### Biometric graphics - -Note: - : The data used in this graphic is the data present in the biometrics.csv file. - -
-', biometric.fragment,' -
-')), ' - -### Section Survival - -Note: - : The data used in this table and graphic is stored in the `section.overview` object. - -', paste(knitr::kable(section.overview), collapse = "\n"), ' - -
-![](survival.png){ ',survival.graph.size ,' } -
- - -### Last Seen Arrays - -Note: - : The data used in this graphic is stored in the `status.df` object (\'Very.last.array\' column). - -
-![](last_arrays.png){ width=66% } -
- - -### Progression - -', ifelse(display.progression, paste0('Zoom in or open the figure in a new tab to clearly read the text within each circle. - -Note: - : The progression calculations **do not account for** backwards movements. This implies that the total number of animals to have been **last seen** at a given array **may be lower** than the displayed below. Please refer to the [section survival overview](#section-survival) and [last seen arrays](#last-seen-arrays) to find out how many animals were considered to have disappeared per section. - : The data used in this graphic is stored in the `overall.CJS` object, and the data used in the tables is stored in the `group.overview` object. You can find detailed progressions per release site in the `release.overview` object. - - - -'), 'Progression cannot be displayed if efficiencies are not calculated. See full log for more details.'), array.overview.fragment, ' - - -### Time of arrival at each Array - -Note: - : Coloured lines on the outer circle indicate the mean value for each group and the respective ranges show the standard error of the mean. Each group\'s bars sum to 100%. The number of data points in each group is presented between brackets in the legend of each pannel. - : You can replicate these graphics and edit them as needed using the `plotTimes()` function. - : The data used in these graphics is stored in the `times` object. - : To obtain reports with the legacy linear circular scale, run `options(actel.circular.scale = "linear")` before running your analyses. - -
-', circular.plots,' -
- - -### Dotplots - -Note: - : The **top** 10% of the values for each panel are marked in **red**. - : The **bottom** 10% of the values for each panel are marked in **blue**. - : The columns starting with "To" should be read as either "Average time to ..." or "Average speed to ...", depending on the unit used. The columns starting with "In" should be read as "Total time in ...". These reductions were made to keep the column headers as short as possible. - : The data used in these graphics is stored in the `status.df` object. - -
-![](', work.path, 'dotplots.png){ width=95% } -
- - -### Individual detection plots - -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 time of release. The vertical grey dashed lines show the assigned moments of entry and exit for each study area section. 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', ''), -' : Manually **edited** tag detections are highlighted with **yellow** graphic borders. - : Manually **overridden** tag detections are highlighted with **red** graphic borders. - : The ', ifelse(detections.y.axis == "stations", 'stations', 'arrays'), ' have been aligned by ', ifelse(detections.y.axis == "stations", 'array', 'section'), ', following the order provided ', ifelse(detections.y.axis == "stations", '', 'either '), 'in the spatial input', ifelse(detections.y.axis == "stations", '.', ' or the `section.order` argument.'), ' - : You can replicate these graphics and edit them as needed using the `plotDetections()` function. - : You can also see the movement events of multiple tags simultaneously using the `plotMoves()` function. - : The data used in these graphics is stored in the `detections` and `movements` objects (and respective valid counterparts). - -
-', individual.plots,' -
- -', sensor.fragment,' - -### Full log - -```{r log, echo = FALSE, comment = NA} -cat("', gsub("\\r", "", report), '") -``` - -'), fill = TRUE) -sink() - -sink(paste0(work.path, "toc_menu_migration.html")) -cat( -' - -
-

Index:

- Summary - Study area - Stations - Deployments - Release sites - Array efficiency - Warnings - Comments', - ifelse(biometric.fragment == '', '', '\n Biometrics'),' - Section survival - Last seen - Progression - Arrival times - Dotplots - Individual detections', - ifelse(is.null(sensor.fragment), '', '\n Sensor data'),' - Full log -
-', fill = TRUE) -sink() + "---\n", + "title: \"Acoustic telemetry migration analysis\"\n", + "author: \"Actel R package (", utils::packageVersion("actel"), ")\"\n", + "output:\n", + " html_document:\n", + " includes:\n", + " after_body: ", work.path, "toc_menu_migration.html\n", + "---\n", + "\n", + "### Summary\n", + "\n", + "Target folder: ", + stringr::str_extract(pattern = "(?<=Target folder: )[^\r|^\n]*", + string = report), "\n", + "\n", + "Timestamp: **", + stringr::str_extract(pattern = "(?<=Timestamp: )[^\r|^\n]*", + string = report), "**\n", + "\n", + "Number of target tags: **`r I(nrow(status.df))`**\n", + override.fragment, "\n", + "\n", + "Number of listed receivers: **", + stringr::str_extract(pattern = "(?<=Number of ALS: )[0-9]*", + string = report), + "** (of which **", + stringr::str_extract(pattern = "(?<=of which )[0-9]*", + string = report), + "** had no detections)\n", + "\n", + unknown.fragment, "\n", + "\n", + "Data time range: ", + stringr::str_extract(pattern = "(?<=Data time range: )[^\r|^\n]*", + string = report), "\n", + "\n", + "Percentage of post-release valid detections: ", + round(sum(unlist(lapply(valid.detections, nrow))) / + sum(unlist(lapply(detections, nrow))) * 100, 2), "%\n", + "\n", + "Found a bug? [**Report it here.**]", + "(https://github.com/hugomflavio/actel/issues)\n", + "\n", + "Want to cite actel in a publication? Run `citation(\"actel\")`\n", + "\n", + "### Study area\n", + "\n", + "Arrays with the same background belong to the same section. Release sites", + " are marked with \"R.S.\". Arrays connected with an arrow indicate that", + " the animals can only pass in one direction.\n", + "\n", + "\n", + "\n", + "### Receiver stations\n", + "\n", + paste(knitr::kable(spatial$stations, row.names = FALSE), + collapse = "\n"), "\n", + "\n", + "### Deployments\n", + "\n", + paste(knitr::kable(deployments, row.names = FALSE), collapse = "\n"), "\n", + "\n", + "### Release sites\n", + "\n", + paste(knitr::kable(spatial$release.sites, row.names = FALSE), + collapse = "\n"), "\n", + "\n", + "### Array forward efficiency\n", + "\n", + efficiency.fragment, "\n", + "\n", + "### Warning messages\n", + "\n", + "```{r warnings, echo = FALSE, comment = NA}\n", + "cat(\"", warning.messages, "\")\n", + "```\n", + "\n", + "### User comments\n", + "\n", + "```{r comments, echo = FALSE, comment = NA}\n", + "cat(\"", comment.fragment, "\")\n", + "```\n", + "\n", + ifelse(biometric.fragment == "", + "", + paste0("### Biometric graphics\n", + "\n", + "Note:\n", + " : The data used in this graphic is the data present in", + " the biometrics.csv file.\n", + "\n", + "
\n", + biometric.fragment, + "
\n") + ), "\n", + "\n", + "### Section Survival\n", + "\n", + "Note:\n", + ": The data used in this table and graphic is stored in the", + " `section.overview` object.\n", + "\n", + paste(knitr::kable(section.overview), collapse = "\n"), "\n", + "\n", + "
\n", + "![](survival.png){ ",survival.graph.size ," }\n", + "
\n", + "\n", + "### Last Seen Arrays\n", + "\n", + "Note:\n", + " : The data used in this graphic is stored in the `status.df` object", + " ('Very.last.array' column).\n", + "\n", + "
\n", + "![](last_arrays.png){ width=66% }\n", + "
\n", + "\n", + "### Progression\n", + "\n", + ifelse(display.progression, + paste0("Zoom in or open the figure in a new tab to clearly read the", + " text within each circle.\n", + "\n", + "Note:\n", + " : The progression calculations **do not account for**", + " backwards movements. This implies that the total number of", + " animals to have been **last seen** at a given array **may", + " be lower** than the displayed below. Please refer to the", + " [section survival overview](#section-survival) and [last", + " seen arrays](#last-seen-arrays) to find out how many", + " animals were considered to have disappeared per section.\n", + " : The data used in this graphic is stored in the", + " `overall.CJS` object, and the data used in the tables is", + " stored in the `group.overview` object. You can find", + " detailed progressions per release site in the", + " `release.overview` object.\n", + "\n", + "\n", + "\n"), + paste0("Progression cannot be displayed if efficiencies are not", + " calculated. See full log for more details.")), + array.overview.fragment, "\n", + "\n", + "### Time of arrival at each Array\n", + "\n", + "Note:\n", + " : Coloured lines on the outer circle indicate the mean value for each", + " group and the respective ranges show the standard error of the mean.", + " Each group's bars sum to 100%. The number of data points in each group", + " is presented between brackets in the legend of each pannel.\n", + " : You can replicate these graphics and edit them as needed using the", + " `plotTimes()` function.\n", + " : The data used in these graphics is stored in the `times` object.\n", + " : To obtain reports with the legacy linear circular scale, run", + " `options(actel.circular.scale = \"linear\")` before running", + " your analyses.\n", + "\n", + "
\n", + circular.plots, + "\n", + "
\n", + "\n", + "### Dotplots\n", + "\n", + "Note:\n", + " : The **top** 10% of the values for each panel are marked in **red**.\n", + " : The **bottom** 10% of the values for each panel", + " are marked in **blue**.\n", + " : The columns starting with \"To\" should be read as either \"Average", + " time to ...\" or \"Average speed to ...\", depending on the unit used.", + " The columns starting with \"In\" should be read as \"Total time in", + " ...\". These reductions were made to keep the column headers as short", + " as possible.\n", + " : The data used in these graphics is stored in the `status.df`", + " object.\n", + "\n", + "
\n", + "![](", work.path, "dotplots.png){ width=95% }\n", + "
\n", + "\n", + "### Individual detection plots\n", + "\n", + "Note:\n", + " : You can choose to plot detections by station or by array using the", + " `detections.y.axis` argument.\n", + " : The detections are coloured by ", + ifelse(detections.y.axis == "stations", "array", "section"), ".", + " The vertical black dashed line shows the time of release. The vertical", + " grey dashed lines show the assigned moments of entry and exit for each", + " study area section. The full dark-grey line shows the movement events", + " considered valid, while the dashed dark-grey line shows the movement", + " events considered invalid.\n", + ifelse(detections.y.axis == "stations", + paste0(" : 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"), + ""), + " : Manually **edited** tag detections are highlighted with", + " **yellow** graphic borders.\n", + " : Manually **overridden** tag detections are highlighted with", + " **red** graphic borders.\n", + " : The ", + ifelse(detections.y.axis == "stations", "stations", "arrays"), + " have been aligned by ", + ifelse(detections.y.axis == "stations", "array", "section"), + ", following the order provided ", + ifelse(detections.y.axis == "stations", "", "either "), + "in the spatial input", + ifelse(detections.y.axis == "stations", ".", + " or the `section.order` argument."), "\n", + " : You can replicate these graphics and edit them as needed using the", + " `plotDetections()` function.\n", + " : You can also see the movement events of multiple tags simultaneously", + " using the `plotMoves()` function.\n", + " : The data used in these graphics is stored in the `detections` and", + " `movements` objects (and respective valid counterparts).\n", + "\n", + "
\n", + individual.plots, + "\n", + "
\n", + "\n", + sensor.fragment, "\n", + "\n", + "### Full log\n", + "\n", + "```{r log, echo = FALSE, comment = NA}\n", + "cat(\"", gsub("\\r", "", report), "\")\n", + "```\n", + "\n" + ), fill = TRUE) + sink() + + sink(paste0(work.path, "toc_menu_migration.html")) + cat(paste0( + "\n", + "\n", + "
\n", + "

Index:

\n", + " Summary\n", + " Study area\n", + " Stations\n", + " Deployments\n", + " Release sites\n", + " Array efficiency\n", + " Warnings\n", + " Comments\n", + ifelse(biometric.fragment == "", + "", + " Biometrics\n"), + " Section survival\n", + " Last seen\n", + " Progression\n", + " Arrival times\n", + " Dotplots\n", + " Individual detections\n", + ifelse(is.null(sensor.fragment), + "", + " Sensor data\n"), + " Full log\n", + "
\n" + ), fill = TRUE) + sink() } #' Create the timetable #' -#' Crawls trough the movement events of each tag to find when it entered and left each section of the study area. +#' Crawls trough the movement events of each tag to find when it entered and +#' left each section of the study area. #' #' @inheritParams explore #' @inheritParams migration @@ -1283,16 +1535,19 @@ sink() #' @param valid.moves the valid array movements #' @param all.moves all array movements #' -#' @return A data frame containing the entering and leaving timestamps for each section per target tag +#' @return A data frame containing the entering and leaving timestamps +#' for each section per target tag #' #' @keywords internal #' -assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, bio, tz, - dist.mat, speed.method, if.last.skip.section, success.arrays) { +assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, + arrays, bio, tz, dist.mat, speed.method, + if.last.skip.section, success.arrays) { event(type = "debug", "Running assembleTimetable.") # NOTE: The NULL variables below are actually column names used by data.table. - # This definition is just to prevent the package check from issuing a note due unknown variables. + # This definition is just to prevent the package check from issuing a note due + # to unknown variables. Last.array <- NULL Last.time <- NULL Last.station <- NULL @@ -1346,19 +1601,21 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, if (grepl("first$", speed.method)) { time_end <- aux$First.time[i] - station_end <- gsub(" ", ".", aux$First.station[i]) # the gsub is just to match the column name in the distances matrix + station_end <- gsub(" ", ".", aux$First.station[i]) } else { time_end <- aux$Last.time[i] - station_end <- gsub(" ", ".", aux$Last.station[i]) # same as above + station_end <- gsub(" ", ".", aux$Last.station[i]) } - time_spent <- as.vector(difftime(time_end, time_start, units = "secs")) + time_spent <- as.vector(difftime(time_end, time_start, + units = "secs")) dist_went <- dist.mat[station_start, station_end] aux$Speed.until[i] <<- round(dist_went/time_spent, 6) - return(NULL) # we don't care about this lapply output. See <<- above. + # we don't care about this lapply output. See <<- above. + return(NULL) }) } return(aux) @@ -1373,18 +1630,32 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, recipient <- vector() if (attributes(dist.mat)$valid) { for (i in seq_len(length(sections))) { - recipient <- c(recipient, paste(c("Times.entered", "Average.time.until", "Average.speed.to", "First.array", "First.station", - "First.arrived", "Average.time.in", "Average.speed.in", "Last.array", "Last.station", "Last.left", "Total.time.in"), sections[i], sep = ".")) + recipient <- c(recipient, + paste(c("Times.entered", "Average.time.until", + "Average.speed.to", "First.array", "First.station", + "First.arrived", "Average.time.in", + "Average.speed.in", "Last.array", "Last.station", + "Last.left", "Total.time.in"), + sections[i], sep = ".")) } } else { for (i in seq_len(length(sections))) { - recipient <- c(recipient, paste(c("Times.entered", "Average.time.until", "First.array", "First.station", - "First.arrived", "Average.time.in", "Last.array", "Last.station", "Last.left", "Total.time.in"), sections[i], sep = ".")) + recipient <- c(recipient, + paste(c("Times.entered", "Average.time.until", + "First.array", "First.station", "First.arrived", + "Average.time.in", "Last.array", "Last.station", + "Last.left", "Total.time.in"), + sections[i], sep = ".")) } } - recipient <- c(recipient, "Very.last.array", "Very.last.time", "Status", "Valid.detections", "Valid.events", "Invalid.detections", "Invalid.events", "Backwards.movements", "Max.cons.back.moves", "P.type") - if (attributes(dist.mat)$valid && speed.method == "last to last") + recipient <- c(recipient, "Very.last.array", "Very.last.time", "Status", + "Valid.detections", "Valid.events", "Invalid.detections", + "Invalid.events", "Backwards.movements", + "Max.cons.back.moves", "P.type") + + if (attributes(dist.mat)$valid && speed.method == "last to last") { recipient <- recipient[!grepl("Average\\.speed\\.in", recipient)] + } timetable <- matrix(nrow = length(secmoves), ncol = length(recipient)) timetable <- as.data.frame(timetable) @@ -1404,42 +1675,64 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, names(recipient) <- colnames(timetable) 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.in.", names(aux)[i])] <- sum(total.time) - recipient[1, paste0("Average.time.in.", names(aux)[i])] <- mean(total.time) - - recipient[1, paste0("Times.entered.", names(aux)[i])] <- nrow(aux[[i]]) - - recipient[1, paste0("First.array.", names(aux)[i])] <- aux[[i]]$First.array[1] - recipient[1, paste0("First.station.", names(aux)[i])] <- aux[[i]]$First.station[1] - recipient[1, paste0("First.arrived.", names(aux)[i])] <- as.character(aux[[i]]$First.time[1]) - - recipient[1, paste0("Last.array.", names(aux)[i])] <- aux[[i]][.N, Last.array] - recipient[1, paste0("Last.station.", names(aux)[i])] <- aux[[i]][.N, Last.station] - recipient[1, paste0("Last.left.", names(aux)[i])] <- as.character(aux[[i]][.N, Last.time]) - - if (attributes(dist.mat)$valid && speed.method == "last to first") - recipient[1, paste0("Average.speed.in.", names(aux)[i])] <- round(mean(aux[[i]]$Speed.in.section.m.s), 6) + total.time <- apply(aux[[i]][, c("First.time", "Last.time")], 1, + function(x) difftime(x[2], x[1], units = "secs")) + + the_col <- paste0("Total.time.in.", names(aux)[i]) + recipient[1, the_col] <- sum(total.time) + + the_col <- paste0("Average.time.in.", names(aux)[i]) + recipient[1, the_col] <- mean(total.time) + + the_col <- paste0("Times.entered.", names(aux)[i]) + recipient[1, the_col] <- nrow(aux[[i]]) + + the_col <- paste0("First.array.", names(aux)[i]) + recipient[1, the_col] <- aux[[i]]$First.array[1] + + the_col <- paste0("First.station.", names(aux)[i]) + recipient[1, the_col] <- aux[[i]]$First.station[1] + + the_col <- paste0("First.arrived.", names(aux)[i]) + recipient[1, the_col] <- as.character(aux[[i]]$First.time[1]) + + the_col <- paste0("Last.array.", names(aux)[i]) + recipient[1, the_col] <- aux[[i]][.N, Last.array] + + the_col <- paste0("Last.station.", names(aux)[i]) + recipient[1, the_col] <- aux[[i]][.N, Last.station] + + the_col <- paste0("Last.left.", names(aux)[i]) + recipient[1, the_col] <- as.character(aux[[i]][.N, Last.time]) + + if (attributes(dist.mat)$valid && speed.method == "last to first") { + the_col <- paste0("Average.speed.in.", names(aux)[i]) + recipient[1, the_col] <- round(mean(aux[[i]]$Speed.in.section.m.s), 6) + } - recipient[1, paste0("Average.time.until.", names(aux)[i])] <- mean(decimalTime(aux[[i]]$Time.travelling, unit = "s")) + the_col <- paste0("Average.time.until.", names(aux)[i]) + recipient[1, the_col] <- mean(decimalTime(aux[[i]]$Time.travelling, + unit = "s")) - if (attributes(dist.mat)$valid) - recipient[1, paste0("Average.speed.to.", names(aux)[i])] <- round(mean(aux[[i]]$Speed.until), 6) + if (attributes(dist.mat)$valid) { + the_col <- paste0("Average.speed.to.", names(aux)[i]) + recipient[1, the_col] <- round(mean(aux[[i]]$Speed.until), 6) + } return(recipient) }) recipient <- as.data.frame(combine(recipient), stringsAsFactors = FALSE) # convert numbers to numeric and replace NAs where relevant - the.cols <- which(grepl("Times\\.entered\\.", colnames(recipient))) - recipient[, the.cols] <- as.numeric(recipient[, the.cols]) - recipient[, the.cols[which(is.na(recipient[, the.cols]))]] <- 0 + the_cols <- which(grepl("Times\\.entered\\.", colnames(recipient))) + recipient[, the_cols] <- as.numeric(recipient[, the_cols]) + recipient[, the_cols[which(is.na(recipient[, the_cols]))]] <- 0 - the.cols <- which(grepl("Average\\.speed\\.to\\.", colnames(recipient))) - recipient[, the.cols] <- as.numeric(recipient[, the.cols]) + the_cols <- which(grepl("Average\\.speed\\.to\\.", colnames(recipient))) + recipient[, the_cols] <- as.numeric(recipient[, the_cols]) - the.cols <- which(grepl("Average\\.speed\\.in\\.", colnames(recipient))) - recipient[, the.cols] <- as.numeric(recipient[, the.cols]) + the_cols <- which(grepl("Average\\.speed\\.in\\.", colnames(recipient))) + recipient[, the_cols] <- as.numeric(recipient[, the_cols]) # -- recipient$Very.last.array <- secmoves[[tag]][.N, Last.array] @@ -1469,14 +1762,17 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, not.last.section <- match(the.last.section, sections) != length(sections) edge.array <- arrays[[the.last.array]]$edge + # this will be a problem with parallel sections. if (if.last.skip.section && not.last.section && edge.array) { - recipient$Status <- paste("Disap. in", sections[match(the.last.section, sections) + 1]) + recipient$Status <- paste("Disap. in", + sections[match(the.last.section, sections) + 1]) } else { recipient$Status <- paste("Disap. in", the.last.section) } - if(!is.na(match(the.last.array, success.arrays))) + if(!is.na(match(the.last.array, success.arrays))) { recipient$Status <- "Succeeded" + } # deploy values event(type = "debug", "Deploy timetable values for tag ", tag, ".") @@ -1487,27 +1783,32 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, # Convert time and timestamp data for (section in sections) { - for (the.col in c("Average.time.until.", "Average.time.in.", "Total.time.in.")) { + cols <- paste0(c("Average.time.until.", "Average.time.in.", + "Total.time.in."), + section) + for (the_col in cols) { # convert to numeric - timetable[, paste0(the.col, section)] <- as.numeric(timetable[, paste0(the.col, section)]) + timetable[, the_col] <- as.numeric(timetable[, the_col]) # grab the mean for later use - aux <- mean(timetable[, paste0(the.col, section)], na.rm = TRUE) + aux <- mean(timetable[, the_col], na.rm = TRUE) # convert to difftime - timetable[, paste0(the.col, section)] <- as.difftime(timetable[, paste0(the.col, section)], units = "secs") - units(timetable[, paste0(the.col, section)]) <- "secs" + timetable[, the_col] <- as.difftime(timetable[, the_col], units = "secs") + units(timetable[, the_col]) <- "secs" if (!is.nan(aux)) { if (aux > 86400) - units(timetable[, paste0(the.col, section)]) <- "days" + units(timetable[, the_col]) <- "days" if (aux <= 86400 & aux > 3600) - units(timetable[, paste0(the.col, section)]) <- "hours" + units(timetable[, the_col]) <- "hours" if (aux <= 3600) - units(timetable[, paste0(the.col, section)]) <- "mins" + units(timetable[, the_col]) <- "mins" } - timetable[, paste0(the.col, section)] <- round(timetable[, paste0(the.col, section)], 3) + timetable[, the_col] <- round(timetable[, the_col], 3) } - for (the.col in c("First.arrived.", "Last.left.")) { + cols <- paste0(c("First.arrived.", "Last.left."), + section) + for (the_col in cols) { # convert to numeric posix - timetable[, paste0(the.col, section)] <- as.POSIXct(timetable[, paste0(the.col, section)], tz = tz) + timetable[, the_col] <- as.POSIXct(timetable[, the_col], tz = tz) } } @@ -1524,8 +1825,10 @@ assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, #' #' @return A list containing: #' \itemize{ -#' \item \code{sum.back.moves} The number of backwards movements for the target tag -#' \item \code{max.back.moves} The maximum number of consecutive backwards movements for the target tag +#' \item \code{sum.back.moves} The number of backwards movements for +#' the target tag +#' \item \code{max.back.moves} The maximum number of consecutive backwards +#' movements for the target tag #' } #' #' @keywords internal @@ -1543,15 +1846,18 @@ countBackMoves <- function(movements, arrays){ FALSE ) sum.back.moves <- sum(backwards.movements) - if (sum.back.moves > 0) - max.back.moves <- max(rle(backwards.movements)$lengths[which(rle(backwards.movements)$values == TRUE)]) - else + if (sum.back.moves > 0) { + aux <- rle(backwards.movements) + max.back.moves <- max(aux$lengths[which(aux$values)]) + } else { max.back.moves <- 0 + } } else { sum.back.moves <- 0 max.back.moves <- 0 } - return(list(sum.back.moves = sum.back.moves, max.back.moves = max.back.moves)) + return(list(sum.back.moves = sum.back.moves, + max.back.moves = max.back.moves)) } #' Create status.df @@ -1560,7 +1866,8 @@ countBackMoves <- function(movements, arrays){ #' #' @inheritParams explore #' @inheritParams migration -#' @param timetable A table of the entering and leaving points for each section per target tag, created by assembleTimetable. +#' @param timetable A table of the entering and leaving points for each +#' section per target tag, created by assembleTimetable. #' @inheritParams splitDetections #' @inheritParams simplifyMovements #' @inheritParams loadDetections @@ -1579,23 +1886,29 @@ assembleOutput <- function(timetable, bio, spatial, dist.mat, tz) { sections <- names(spatial$array.order) status.df$Status[is.na(status.df$Status)] <- paste("Disap. in", sections[1]) - status.df$Status <- factor(status.df$Status, levels = c(paste("Disap. in", sections), "Succeeded")) + status.df$Status <- factor(status.df$Status, + levels = c(paste("Disap. in", sections), + "Succeeded")) status.df$Very.last.array[is.na(status.df$Very.last.array)] <- "Release" - status.df$Very.last.array <- factor(status.df$Very.last.array, levels = c("Release", levels(spatial$stations$Array))) + status.df$Very.last.array <- factor(status.df$Very.last.array, + levels = c("Release", + levels(spatial$stations$Array))) status.df$P.type[is.na(status.df$P.type)] <- "Skipped" status.df$Valid.detections[is.na(status.df$Valid.detections)] <- 0 status.df$Invalid.detections[is.na(status.df$Invalid.detections)] <- 0 event(type = "debug", "Appending comments.") if (file.exists(paste0(tempdir(), "/temp_comments.txt"))) { # nocov start - temp <- read.table(paste0(tempdir(), "/temp_comments.txt"), header = FALSE, sep = "\t") + temp <- read.table(paste0(tempdir(), "/temp_comments.txt"), + header = FALSE, sep = "\t") status.df[, "Comments"] <- NA_character_ for (i in seq_len(nrow(temp))) { link <- match(temp[i, 1], status.df$Transmitter) if (is.na(status.df$Comments[link])) { status.df$Comments[link] <- paste(temp[i, 2]) } else { - status.df$Comments[link] <- paste(status.df$Comments[link], temp[i, 2], sep = "// ") + status.df$Comments[link] <- paste(status.df$Comments[link], + temp[i, 2], sep = "// ") } } } # nocov end @@ -1605,20 +1918,23 @@ assembleOutput <- function(timetable, bio, spatial, dist.mat, tz) { #' Create section.overview #' -#' Produces a table with the survival per group of animals present in the biometrics. +#' Produces a table with the survival per group of animals present in the +#' biometrics. #' #' @inheritParams explore #' @inheritParams migration #' @inheritParams simplifyMovements #' @inheritParams sectionMovements #' -#' @return A data frame containing the survival per group of animals present in the biometrics. +#' @return A data frame containing the survival per group of animals present +#' in the biometrics. #' #' @keywords internal #' assembleSectionOverview <- function(status.df, spatial) { event(type = "debug", "Running assembleSectionOverview.") - section.overview <- as.data.frame.matrix(with(status.df, table(Group, Status))) + section.overview <- with(status.df, table(Group, Status)) + section.overview <- as.data.frame.matrix(section.overview) section.overview$Total <- as.vector(with(status.df, table(Group))) colnames(section.overview) <- gsub(" ", ".", colnames(section.overview)) @@ -1627,10 +1943,12 @@ assembleSectionOverview <- function(status.df, spatial) { if (length(sections) >= 2) { to.col <- paste("Migrated.to", sections[2], sep = ".") from.col <- paste("Disap..in", sections[1], sep = ".") - section.overview[, to.col] <- section.overview$Total - section.overview[, from.col] + section.overview[, to.col] <- section.overview$Total - + section.overview[, from.col] recipient <- vector() for (i in 2:length(sections)) { - recipient <- c(recipient, paste(c("Migrated.to", "Disap..in"), sections[i], sep = ".")) + recipient <- c(recipient, paste(c("Migrated.to", "Disap..in"), + sections[i], sep = ".")) } } else { recipient <- NULL @@ -1640,9 +1958,11 @@ assembleSectionOverview <- function(status.df, spatial) { to.col <- paste("Migrated.to", sections[i], sep = ".") from.colA <- paste("Migrated.to", sections[i - 1], sep = ".") from.colB <- paste("Disap..in", sections[i - 1], sep = ".") - section.overview[, to.col] <- section.overview[, from.colA] - section.overview[, from.colB] + section.overview[, to.col] <- section.overview[, from.colA] - + section.overview[, from.colB] } } - recipient <- c("Total", paste("Disap..in", sections[1], sep = "."), recipient, "Succeeded") + recipient <- c("Total", paste("Disap..in", sections[1], sep = "."), + recipient, "Succeeded") return(section.overview[, recipient]) } diff --git a/R/residency.R b/R/residency.R index 57deccc..7cda510 100644 --- a/R/residency.R +++ b/R/residency.R @@ -473,7 +473,7 @@ residency <- function( dist.mat = dist.mat, GUI = GUI, save.tables.locally = save.tables.locally) } } else { - output <- overrideValidityChecks(moves = movements[[tag]], tag = tag, detections = detections.list[[tag]], # nocov + output <- overrideChecks(moves = movements[[tag]], tag = tag, detections = detections.list[[tag]], # nocov GUI = GUI, save.tables.locally = save.tables.locally, n = counter) # nocov } return(output) @@ -494,12 +494,21 @@ residency <- function( 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. + if (!is.null(aux)) { + # don't run the minimum total detections check here (i.e. set it to 0); + # that's already done when compiling the array movements. + aux <- checkMinimumN(movements = aux, tag = tag, min.total.detections = 0, 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, - save.tables.locally = save.tables.locally, n = counter) - return(output) + 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) + } else { + return(NULL) + } }) names(section.movements) <- names(movements) diff --git a/R/user_interaction.R b/R/user_interaction.R index 22e6cf5..fa97d5a 100644 --- a/R/user_interaction.R +++ b/R/user_interaction.R @@ -869,8 +869,8 @@ transferValidity <- function(from, to) { # nocov start #' #' @keywords internal #' -overrideValidityChecks <- function(moves, detections, tag, GUI, save.tables.locally, n) { # nocov start - event(type = "debug", "Starting overrideValidityChecks.") +overrideChecks <- function(moves, detections, tag, GUI, save.tables.locally, n) { # nocov start + event(type = "debug", "Starting overrideChecks.") trigger <- paste0("M: Override has been triggered for tag ", tag, " ", n, ". Entering full manual mode.") diff --git a/man/assembleOutput.Rd b/man/assembleOutput.Rd index c39d4d0..c3183a2 100644 --- a/man/assembleOutput.Rd +++ b/man/assembleOutput.Rd @@ -7,7 +7,8 @@ assembleOutput(timetable, bio, spatial, dist.mat, tz) } \arguments{ -\item{timetable}{A table of the entering and leaving points for each section per target tag, created by assembleTimetable.} +\item{timetable}{A table of the entering and leaving points for each +section per target tag, created by assembleTimetable.} \item{bio}{A table with the tags and biometrics of the studied animals.} diff --git a/man/assembleSectionOverview.Rd b/man/assembleSectionOverview.Rd index 1590a40..1da330f 100644 --- a/man/assembleSectionOverview.Rd +++ b/man/assembleSectionOverview.Rd @@ -10,9 +10,11 @@ assembleSectionOverview(status.df, spatial) \item{spatial}{The spatial list.} } \value{ -A data frame containing the survival per group of animals present in the biometrics. +A data frame containing the survival per group of animals present +in the biometrics. } \description{ -Produces a table with the survival per group of animals present in the biometrics. +Produces a table with the survival per group of animals present in the +biometrics. } \keyword{internal} diff --git a/man/assembleTimetable.Rd b/man/assembleTimetable.Rd index ac33a86..744e3a2 100644 --- a/man/assembleTimetable.Rd +++ b/man/assembleTimetable.Rd @@ -52,9 +52,11 @@ tag crosses one of these arrays, the respective animal is considered to have successfully migrated through the study area.} } \value{ -A data frame containing the entering and leaving timestamps for each section per target tag +A data frame containing the entering and leaving timestamps +for each section per target tag } \description{ -Crawls trough the movement events of each tag to find when it entered and left each section of the study area. +Crawls trough the movement events of each tag to find when it entered and +left each section of the study area. } \keyword{internal} diff --git a/man/checkFirstDetBackFromRelease.Rd b/man/checkFirstMove.Rd similarity index 93% rename from man/checkFirstDetBackFromRelease.Rd rename to man/checkFirstMove.Rd index 237fe90..eae6d07 100644 --- a/man/checkFirstDetBackFromRelease.Rd +++ b/man/checkFirstMove.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/check.R -\name{checkFirstDetBackFromRelease} -\alias{checkFirstDetBackFromRelease} +\name{checkFirstMove} +\alias{checkFirstMove} \title{Check for movements upstream of the release site.} \usage{ -checkFirstDetBackFromRelease( +checkFirstMove( movements, tag, bio, diff --git a/man/countBackMoves.Rd b/man/countBackMoves.Rd index 3df915b..f6a18df 100644 --- a/man/countBackMoves.Rd +++ b/man/countBackMoves.Rd @@ -14,8 +14,10 @@ countBackMoves(movements, arrays) \value{ A list containing: \itemize{ -\item \code{sum.back.moves} The number of backwards movements for the target tag -\item \code{max.back.moves} The maximum number of consecutive backwards movements for the target tag +\item \code{sum.back.moves} The number of backwards movements for +the target tag +\item \code{max.back.moves} The maximum number of consecutive backwards +movements for the target tag } } \description{ diff --git a/man/migration.Rd b/man/migration.Rd index 2d5b5f2..aff068c 100644 --- a/man/migration.Rd +++ b/man/migration.Rd @@ -170,40 +170,53 @@ to one of "stations" or "arrays".} \value{ A list containing: \itemize{ -\item \code{detections}: A list containing all detections for each target tag; -\item \code{valid.detections}: A list containing the valid detections for each target tag; -\item \code{spatial}: A list containing the spatial information used during the analysis; -\item \code{deployments}: A data frame containing the deployments of each receiver; -\item \code{arrays}: A list containing the array details used during the analysis; -\item \code{movements}: A list containing all movement events for each target tag; -\item \code{valid.movements}: A list containing the valid movement events for each target tag; -\item \code{section.movements}: A list containing the valid section shifts for each target tag; -\item \code{status.df}: A data.frame containing summary information for each tag, including the -following columns: +\item \code{detections}: A list containing all detections for each target +tag; +\item \code{valid.detections}: A list containing the valid detections for +each target tag; +\item \code{spatial}: A list containing the spatial information used during +the analysis; +\item \code{deployments}: A data frame containing the deployments of each +receiver; +\item \code{arrays}: A list containing the array details used during the +analysis; +\item \code{movements}: A list containing all movement events for each +target tag; +\item \code{valid.movements}: A list containing the valid movement events +for each target tag; +\item \code{section.movements}: A list containing the valid section shifts +for each target tag; +\item \code{status.df}: A data.frame containing summary information for each +tag, including the following columns: \itemize{ -\item \emph{Times.entered.[section]}: Number of times the tag was recorded -entering a given section. +\item \emph{Times.entered.[section]}: Number of times the tag was +recorded entering a given section. \item \emph{Average.time.until.[section]}: Time spent between release or leaving another section and reaching at the given section. -\item \emph{Average.speed.to.[section]}: Average speed from release or leaving -one section and reaching the given section (if speed.method = "last to first"), -or from release/leaving one section and leaving the given section (if speed.method -= "last to last"). +\item \emph{Average.speed.to.[section]}: Average speed from release or +leaving one section and reaching the given section (if +speed.method = "last to first"), or from release/leaving one +section and leaving the given section +(if speed.method = "last to last"). \item \emph{First.array.[section]}: Array in which the tag was first detected in a given section -\item \emph{First.station.[section]}: Standard name of the first station -where the tag was detected in a given section -\item \emph{First.arrived.[section]}: Very first arrival time at a given section -\item \emph{Average.time.in.[section]}: Average time spent within a given section -at each stay. -\item \emph{Average.speed.in.[section]}: Average speed within a given section -at each stay (only displayed if speed.method = "last to first"). +\item \emph{First.station.[section]}: Standard name of the first +station where the tag was detected in a given section +\item \emph{First.arrived.[section]}: Very first arrival time at a +given section +\item \emph{Average.time.in.[section]}: Average time spent within a +given section at each stay. +\item \emph{Average.speed.in.[section]}: Average speed within a given +section at each stay (only displayed if +speed.method = "last to first"). \item \emph{Last.array.[section]}: Array in which the tag was last detected in a given section \item \emph{Last.station.[section]}: Standard name of the last station where the tag was detected in a given section -\item \emph{Last.left.[section]}: Very last departure time from a given section -\item \emph{Total.time.in[section]}: Total time spent in a given section +\item \emph{Last.left.[section]}: Very last departure time from a +given section +\item \emph{Total.time.in[section]}: Total time spent in a given +section \item \emph{Very.last.array}: Last array where the tag was detected \item \emph{Status}: Fate assigned to the tag \item \emph{Valid.detections}: Number of valid detections @@ -221,17 +234,23 @@ changes to the validity of the events, } \item \emph{Comments}: Comments left by the user during the analysis } -\item \code{section.overview}: A data frame containing the number of tags that -disappeared in each section; +\item \code{section.overview}: A data frame containing the number of tags +that disappeared in each section; \item \code{group.overview}: A list containing the number of known and estimated tags to have passed through each array, divided by group; \item \code{release.overview}: A list containing the number of known and -estimated tags to have passed through each array, divided by group and release sites; -\item \code{matrices}: A list of CJS matrices used for the efficiency calculations; -\item \code{overall.CJS}: A list of CJS results of the inter-array CJS calculations; -\item \code{intra.array.CJS}: A list of CJS results of the intra-array CJS calculations; -\item \code{times}: A data frame containing all arrival times (per tag) at each array; -\item \code{rsp.info}: A list containing appendix information for the RSP package; +estimated tags to have passed through each array, divided by group +and release sites; +\item \code{matrices}: A list of CJS matrices used for the efficiency +calculations; +\item \code{overall.CJS}: A list of CJS results of the inter-array CJS +calculations; +\item \code{intra.array.CJS}: A list of CJS results of the intra-array CJS +calculations; +\item \code{times}: A data frame containing all arrival times (per tag) at +each array; +\item \code{rsp.info}: A list containing appendix information for the RSP +package; \item \code{dist.mat}: The distance matrix used in the analysis (if a valid distance matrix was supplied) } @@ -240,9 +259,9 @@ distance matrix was supplied) The \code{migration} analysis runs the same initial checks as \code{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 animal/tag has been acting -odd. Multiple options allow you to tweak the analysis to fit your study -perfectly. +migration. Additional plots help you find out if some animal/tag has been +acting odd. Multiple options allow you to tweak the analysis to fit your +study perfectly. } \examples{ \donttest{ diff --git a/man/overrideValidityChecks.Rd b/man/overrideChecks.Rd similarity index 90% rename from man/overrideValidityChecks.Rd rename to man/overrideChecks.Rd index fa6cc89..7369086 100644 --- a/man/overrideValidityChecks.Rd +++ b/man/overrideChecks.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/user_interaction.R -\name{overrideValidityChecks} -\alias{overrideValidityChecks} +\name{overrideChecks} +\alias{overrideChecks} \title{Skips all validity checks for a tag and allows the user to freely invalidate events} \usage{ -overrideValidityChecks(moves, detections, tag, GUI, save.tables.locally, n) +overrideChecks(moves, detections, tag, GUI, save.tables.locally, n) } \arguments{ \item{detections}{The detections data.frame for a specific tag.} diff --git a/man/parse_arg.Rd b/man/parse_arg.Rd new file mode 100644 index 0000000..ac0422f --- /dev/null +++ b/man/parse_arg.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helper.R +\name{parse_arg} +\alias{parse_arg} +\title{Parse argument and its value as a string} +\usage{ +parse_arg(arg, arg_val) +} +\arguments{ +\item{arg}{the argument to be parsed} + +\item{arg_val}{an optional argument, to use as the value of the argument +used in "arg". Used when arg is, in itself, a complex object provided +by the user. E.g. a datapack, or an argument of preload.} +} +\value{ +A string showing the argument and its value, as it would have been +inputted into the R console. +} +\description{ +used to store the calls of the main actel functions as a string +} +\keyword{internal} diff --git a/man/parse_list.Rd b/man/parse_list.Rd new file mode 100644 index 0000000..34b2408 --- /dev/null +++ b/man/parse_list.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/helper.R +\name{parse_list} +\alias{parse_list} +\title{Helper to parse list arguments} +\usage{ +parse_list(arg) +} +\arguments{ +\item{arg}{the argument to be parsed} +} +\value{ +A string showing the list as it would have been +inputted into the R console. +} +\description{ +Used inside \code{\link[=parse_arg]{parse_arg()}} to properly parse list arguments +} +\keyword{internal} diff --git a/man/printMigrationRmd.Rd b/man/printMigrationRmd.Rd index ddf5a43..074229b 100644 --- a/man/printMigrationRmd.Rd +++ b/man/printMigrationRmd.Rd @@ -23,25 +23,35 @@ printMigrationRmd( ) } \arguments{ -\item{override.fragment}{Rmarkdown string specifying the type of report for the header.} +\item{override.fragment}{Rmarkdown string specifying the type of report for +the header.} -\item{biometric.fragment}{Rmarkdown string specifying the biometric graphics drawn.} +\item{biometric.fragment}{Rmarkdown string specifying the biometric graphics +drawn.} -\item{section.overview}{A summary table with the number of tags that disappeared/moved onwards at each section.} +\item{section.overview}{A summary table with the number of tags that +disappeared/moved onwards at each section.} -\item{efficiency.fragment}{Rmarkdown string specifying the efficiency results.} +\item{efficiency.fragment}{Rmarkdown string specifying the efficiency +results.} -\item{display.progression}{Logical. If TRUE, the progression plot has been created and can be displayed.} +\item{display.progression}{Logical. If TRUE, the progression plot has been +created and can be displayed.} -\item{array.overview.fragment}{Rmarkdown string specifying the array overview results.} +\item{array.overview.fragment}{Rmarkdown string specifying the array +overview results.} -\item{survival.graph.size}{Rmarkdown string specifying the type size of the survival graphics.} +\item{survival.graph.size}{Rmarkdown string specifying the type size +of the survival graphics.} -\item{individual.plots}{Rmarkdown string specifying the name of the individual plots.} +\item{individual.plots}{Rmarkdown string specifying the name of the +individual plots.} -\item{circular.plots}{Rmarkdown string specifying the name of the circular plots.} +\item{circular.plots}{Rmarkdown string specifying the name of the +circular plots.} -\item{sensor.plots}{Rmarkdown string specifying the name of the sensor plots.} +\item{sensor.plots}{Rmarkdown string specifying the name of the sensor +plots.} } \value{ No return value, called for side effects. diff --git a/man/printResidencyRmd.Rd b/man/printResidencyRmd.Rd index 4fbd5c0..2cdd8e3 100644 --- a/man/printResidencyRmd.Rd +++ b/man/printResidencyRmd.Rd @@ -23,13 +23,17 @@ printResidencyRmd( ) } \arguments{ -\item{override.fragment}{Rmarkdown string specifying the type of report for the header.} +\item{override.fragment}{Rmarkdown string specifying the type of report for +the header.} -\item{biometric.fragment}{Rmarkdown string specifying the biometric graphics drawn.} +\item{biometric.fragment}{Rmarkdown string specifying the biometric graphics +drawn.} -\item{efficiency.fragment}{Rmarkdown string specifying the efficiency results.} +\item{efficiency.fragment}{Rmarkdown string specifying the efficiency +results.} -\item{sensor.plots}{Rmarkdown string specifying the name of the sensor plots.} +\item{sensor.plots}{Rmarkdown string specifying the name of the sensor +plots.} } \value{ No return value, called for side effects. diff --git a/tests/testthat/test_array_movement_checks.R b/tests/testthat/test_array_movement_checks.R index fe37028..64cd71b 100644 --- a/tests/testthat/test_array_movement_checks.R +++ b/tests/testthat/test_array_movement_checks.R @@ -176,18 +176,18 @@ test_that("checkInactiveness reacts as expected.", { expect_equal(output, xmoves) }) -test_that("checkFirstDetBackFromRelease reacts as expected.", { - tryCatch(x <- checkFirstDetBackFromRelease(movements = moves[[1]], tag = "R64K-4451", bio = bio, spatial = spatial, arrays = arrays, GUI = "never", n = "(1/1)"), +test_that("checkFirstMove reacts as expected.", { + tryCatch(x <- checkFirstMove(movements = moves[[1]], tag = "R64K-4451", bio = bio, spatial = spatial, arrays = arrays, GUI = "never", n = "(1/1)"), warning = function(w) stop("A warning was issued where it should not have been.")) xspatial <- spatial xspatial$release.sites$Array <- "A2" - expect_warning(checkFirstDetBackFromRelease(movements = moves[[1]], tag = "R64K-4451", bio = bio, spatial = xspatial, arrays = arrays, GUI = "never", n = "(1/1)"), + expect_warning(checkFirstMove(movements = moves[[1]], tag = "R64K-4451", bio = bio, spatial = xspatial, arrays = arrays, GUI = "never", n = "(1/1)"), "Tag R64K-4451 (1/1) was detected in an array that is not after its release site! Opening relevant data for inspection.\nExpected first array: A2", fixed = TRUE) xmoves <- moves[[1]] xmoves$Valid <- FALSE - tryCatch(output <- checkFirstDetBackFromRelease(movements = xmoves, tag = "R64K-4451", bio = bio, spatial = xspatial, arrays = arrays, GUI = "never", n = "(1/1)"), + tryCatch(output <- checkFirstMove(movements = xmoves, tag = "R64K-4451", bio = bio, spatial = xspatial, arrays = arrays, GUI = "never", n = "(1/1)"), warning = function(w) stop("A warning was issued where it should not have been.")) expect_equal(output, xmoves) }) diff --git a/tests/testthat/test_migration.R b/tests/testthat/test_migration.R index 1f0acc0..8a16eb0 100644 --- a/tests/testthat/test_migration.R +++ b/tests/testthat/test_migration.R @@ -147,6 +147,9 @@ test_that("migration is able to run speed and inactiveness checks.", { # n # n # n +# n +# n +# n # Throw in a fake report just to test the number appending code write(1, file = "actel_migration_report.html")