Nothing
#' Migration Analysis
#'
#' 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.
#'
#' @param section.order A vector containing the order by which sections should
#' be aligned in the results.
#' @param success.arrays The arrays that mark the end of the study area. If a
#' tag crosses one of these arrays, the respective animal is considered to have
#' successfully migrated through the study area.
#' @param if.last.skip.section Logical: Should a tag detected at the last array
#' of a given section be considered to have disappeared in the next section?
#' @param disregard.parallels Logical: Should the presence of parallel arrays
#' invalidate potential efficiency peers? See the vignettes for more details.
#' @param replicates A list containing, for each array to which intra-array
#' efficiency is to be calculated: The standard names of the stations to be
#' used as a replicate. See the vignettes for more details.
#' @inheritParams explore
#'
#' @examples
#' \donttest{
#' # Start by moving to a temporary directory
#' old.wd <- getwd()
#' setwd(tempdir())
#'
#' # Deploy the example workspace
#' exampleWorkspace("migration_example")
#'
#' # Move your R session into the example workspace
#' setwd("migration_example")
#'
#' # run the migration analysis. Ensure the tz argument
#' # matches the time zone of the study area and that the
#' # sections match your array names. The line below works
#' # for the example data.
#' results <- migration(tz = "Europe/Copenhagen")
#'
#' # to obtain an HTML report, run the analysis with report = TRUE
#'
#' # return to original working directory
#' setwd(old.wd)
#' rm(old.wd)
#' }
#'
#' @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:
#' \itemize{
#' \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{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{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{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
#' \item \emph{Invalid.detections}: Number of invalid detections
#' \item \emph{Backwards.movements}: Number of backward movement events
#' \item \emph{Max.cons.back.moves}: Longest successive backwards movements
#' \item \emph{P.type}: Type of processing:
#' \itemize{
#' \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,
#' \item 'Overridden' if the user listed the tag in the
#' \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{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;
#' \item \code{dist.mat}: The distance matrix used in the analysis (if a valid
#' distance matrix was supplied)
#' }
#'
#' @seealso \code{\link{explore}}, \code{\link{residency}}
#'
#' @export
#'
migration <- function(
tz = NULL,
section.order = NULL,
datapack = NULL,
success.arrays = NULL,
max.interval = 60,
minimum.detections,
min.total.detections = 2,
min.per.event = 1,
start.time = NULL,
stop.time = NULL,
speed.method = c("last to first", "last to last"),
speed.warning = NULL,
speed.error = NULL,
jump.warning = 2,
jump.error = 3,
inactive.warning = NULL,
inactive.error = NULL,
exclude.tags = NULL,
override = NULL,
report = FALSE,
auto.open = TRUE,
discard.orphans = FALSE,
discard.first = NULL,
save.detections = FALSE,
if.last.skip.section = TRUE,
replicates = NULL,
disregard.parallels = TRUE,
GUI = c("needed", "always", "never"),
save.tables.locally = FALSE,
print.releases = TRUE,
detections.y.axis = c("auto", "stations", "arrays"))
{
# check deprecated argument
if (!missing(minimum.detections))
stop("'minimum.detections' has been deprecated. Please use 'min.total.detections' and 'min.per.event' instead.", call. = FALSE)
# clean up any lost helpers
deleteHelpers()
if (file.exists(paste0(tempdir(), "/actel_debug_file.txt")))
file.remove(paste0(tempdir(), "/actel_debug_file.txt"))
# ------------------------
# debug lines
if (getOption("actel.debug", default = FALSE)) { # nocov start
on.exit(message("Debug: Progress log available at ", gsub("\\\\", "/", paste0(tempdir(), "/actel_debug_file.txt"))))
on.exit(message("Debug: Saving carbon copy to ", gsub("\\\\", "/", paste0(tempdir(), "/actel.debug.RData"))), add = TRUE)
on.exit(save(list = ls(), file = paste0(tempdir(), "/actel.debug.RData")), add = TRUE)
message("!!!--- Debug mode has been activated ---!!!")
} # nocov end
# ------------------------
# check arguments quality
if (!is.null(datapack)) {
checkToken(token = attributes(datapack)$actel.token,
timestamp = attributes(datapack)$timestamp)
}
aux <- checkArguments(dp = datapack,
tz = tz,
min.total.detections = min.total.detections,
min.per.event = min.per.event,
max.interval = max.interval,
speed.method = speed.method,
speed.warning = speed.warning,
speed.error = speed.error,
start.time = start.time,
stop.time = stop.time,
report = report,
auto.open = auto.open,
save.detections = save.detections,
jump.warning = jump.warning,
jump.error = jump.error,
inactive.warning = inactive.warning,
inactive.error = inactive.error,
exclude.tags = exclude.tags,
override = override,
print.releases = print.releases,
if.last.skip.section = if.last.skip.section,
replicates = replicates,
section.order = section.order,
detections.y.axis = detections.y.axis)
min.per.event <- aux$min.per.event
speed.method <- aux$speed.method
speed.warning <- aux$speed.warning
speed.error <- aux$speed.error
jump.warning <- aux$jump.warning
jump.error <- aux$jump.error
inactive.warning <- aux$inactive.warning
inactive.error <- aux$inactive.error
detections.y.axis <- aux$detections.y.axis
rm(aux)
GUI <- checkGUI(GUI, save.tables.locally)
# ------------------------
# 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, "'",
")")
appendTo("debug", the.function.call)
# --------------------
# Prepare clean-up before function ends
finished.unexpectedly <- TRUE
on.exit({if (interactive() & finished.unexpectedly) emergencyBreak(the.function.call)}, add = TRUE)
if (!getOption("actel.debug", default = FALSE))
on.exit(deleteHelpers(), add = TRUE)
on.exit(tryCatch(sink(), warning = function(w) {hide <- NA}), add = TRUE)
# --------------------------------------
# Final arrangements before beginning
appendTo("Report", paste0("Actel R package report.\nVersion: ", utils::packageVersion("actel"), "\n"))
appendTo(c("Report"), paste0("Target folder: ", getwd(), "\nTimestamp: ", the.time <- Sys.time(), "\nFunction: migration()\n"))
report <- checkReport(report = report)
# -----------------------------------
# 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)
} else {
appendTo(c("Screen", "Report"), paste0("M: Running analysis on preloaded data (compiled on ", attributes(datapack)$timestamp, ")."))
appendTo("Report", paste0("Messages displayed during preload:\n-------------------\n", paste0(attributes(datapack)$loading_messages, collapse = "\n"), "\n-------------------"))
study.data <- datapack
tz <- study.data$tz
disregard.parallels <- study.data$disregard.parallels
}
bio <- study.data$bio
deployments <- study.data$deployments
spatial <- study.data$spatial
dot <- study.data$dot
arrays <- study.data$arrays
dotmat <- study.data$dotmat
paths <- study.data$paths
dist.mat <- study.data$dist.mat
attributes(dist.mat)$speed.method <- speed.method
detections.list <- study.data$detections.list
# -------------------------------------
# Final quality checks
# Verify the existance of sections
if (all(!grepl("^Section$", colnames(spatial$stations))))
stopAndReport("To run migration(), please assign the arrays to their sections using a 'Section' column in the spatial input.")
# Verify that replicate information is valid
if (!is.null(replicates) && any(is.na(match(names(replicates), names(arrays)))))
stopAndReport("Some of the array names listed in the 'replicates' argument do not match the study's arrays.")
capture <- lapply(names(replicates), function(i) {
x <- replicates[[i]]
all.stations <- spatial$stations$Standard.name[spatial$stations$Array == i]
if (any(link <- !x %in% all.stations)) {
stopAndReport("In replicates: Station",
ifelse(sum(link) > 1, "s ", " "),
paste(x[link], collapse = ", "),
ifelse(sum(link) > 1, " are", " is"),
" not part of ", i, " (available stations: ",
paste(all.stations, collapse = ", "), ").")
}
})
if (any(!sapply(arrays, function(x) is.null(x$parallel)))) {
if (disregard.parallels)
appendTo(c("Screen", "Report"), "M: 'disregard.parallels' is set to TRUE; the presence of parallel arrays will not invalidate efficiency peers.")
else
appendTo(c("Screen", "Report"), "M: 'disregard.parallels' is set to FALSE; the presence of parallel arrays can potentially invalidate efficiency peers.")
}
if (is.null(success.arrays)) {
success.arrays <- names(arrays)[unlist(lapply(arrays, function(x) is.null(x$after)))]
if (length(success.arrays) == 1)
appendTo(c("Screen", "Warning", "Report"), paste0("'success.arrays' was not defined. Assuming success if the tags are last detected at array ", success.arrays, "."))
else
appendTo(c("Screen", "Warning", "Report"), paste0("'success.arrays' was not defined. Assuming success if the tags are last detected at arrays ", paste(success.arrays[-length(success.arrays)], collapse = ", "), " or ", tail(success.arrays, 1), "."))
} else {
if (any(link <- is.na(match(success.arrays, unlist(spatial$array.order))))) {
stopAndReport(ifelse(sum(link) > 1, "Arrays '", "Array '"), paste(success.arrays[link], collapse = "', '"),
ifelse(sum(link) > 1, "' are ", "' is "), "listed in the 'success.arrays' argument, but ",
ifelse(sum(link) > 1, "these arrays are", "this array is"), " not part of the study arrays.")
}
}
# CHECK ISSUE 79
checkIssue79(arrays, spatial)
# -------------------------------------
# Discard early detections, if required
if (!is.null(discard.first) && discard.first > 0)
detections.list <- discardFirst(input = detections.list, bio, trim = discard.first)
# Compile array movements
appendTo(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,
dist.mat = dist.mat)
if (is.null(discard.first)) {
aux <- names(movements)
movements <- lapply(names(movements), function(tag) {
speedReleaseToFirst(tag = tag, bio = bio, movements = movements[[tag]],
dist.mat = dist.mat, speed.method = speed.method)
})
names(movements) <- aux
rm(aux)
} else {
appendTo(c("Screen", "Report"), "M: Not calculating time/speed from release to first detection because 'discard.first' was set.")
}
appendTo(c("Screen", "Report"), "M: Checking movement events quality.")
do.checkSpeeds <- FALSE
if (is.null(speed.warning)) {
appendTo(c("Screen", "Report", "Warning"), "'speed.warning'/'speed.error' were not set, skipping speed checks.")
} else {
if(attributes(dist.mat)$valid)
do.checkSpeeds <- TRUE
else
appendTo(c("Screen", "Report", "Warning"), "'speed.warning'/'speed.error' were set, but a valid distance matrix is not present. Aborting speed checks.")
}
do.checkInactiveness <- FALSE
if (is.null(inactive.warning)) {
appendTo(c("Screen", "Report", "Warning"), "'inactive.warning'/'inactive.error' were not set, skipping inactivity checks.")
} else {
if (!attributes(dist.mat)$valid)
appendTo(c("Report", "Screen", "Warning"), "Running inactiveness checks without a distance matrix. Performance may be limited.")
do.checkInactiveness <- TRUE
}
movement.names <- names(movements) # this will be used further down to reinstate the names in the movements list.
# 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 (trigger_override_warning) {
appendTo(c("Screen", "Warning", "Report"), paste0("Override has been triggered for ",
ifelse(sum(link) == 1, "tag ", "tags "), paste(override[link], collapse = ", "), " but ",
ifelse(sum(link) == 1, "this signal was", "these signals were"), " not detected."))
override <- override[!link]
}
# convert numeric override to full tag override to prevent problems downstream
if (is.numeric(override))
override <- movement.names[match(override, extractSignals(movement.names))]
movements <- lapply(seq_along(movements), function(i) {
tag <- names(movements)[i]
counter <- paste0("(", i, "/", length(movements), ")")
appendTo("debug", paste0("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)
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)
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)
}
} else {
output <- overrideValidityChecks(moves = movements[[tag]], detections = detections.list[[tag]], n = counter, # nocov
tag = tag, GUI = GUI, save.tables.locally = save.tables.locally) # nocov
}
return(output)
})
names(movements) <- movement.names
rm(movement.names)
# -------------------------
# Compile section movements
appendTo(c("Screen", "Report"), "M: Compiling and checking section movements for the valid tags.")
section.movements <- lapply(seq_along(movements), function(i) {
tag <- names(movements)[i]
counter <- paste0("(", i, "/", length(movements), ")")
appendTo("debug", paste0("debug: Compiling section movements for tag ", tag,"."))
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.
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)
return(output)
} else {
return(NULL)
}
})
names(section.movements) <- names(movements)
section.movements <- section.movements[!sapply(section.movements, is.null)]
# Update array movements based on section movements validity
movements <- updateValidity(arrmoves = movements, secmoves = section.movements)
# compile valid movements
appendTo(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)
appendTo(c("Screen", "Report"), "M: Filtering valid section movements.")
section.movements <- assembleValidSecMoves(valid.moves = valid.movements, spatial = spatial,
valid.dist = attributes(dist.mat)$valid)
appendTo(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,
dist.mat = dist.mat, tz = tz)
appendTo(c("Screen", "Report"), "M: Compiling summary information tables.")
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")
rm(aux)
appendTo("Screen", "M: Validating detections.")
recipient <- validateDetections(detections.list = detections.list, movements = valid.movements)
detections <- recipient$detections
valid.detections <- recipient$valid.detections
rm(recipient)
# -------------------------------------
# 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
m.by.array <- breakMatricesByArray(m = the.matrices, arrays = arrays, type = "peers")
if (is.null(m.by.array[[1]])) {
calculate.efficiency <- FALSE
appendTo(c("Screen", "Report", "Warning"), "Aborting inter-array efficiency calculations (will limit the report's output).")
} else {
calculate.efficiency <- TRUE
}
if (calculate.efficiency) {
appendTo(c("Screen", "Report"), "M: Calculating array efficiency.")
CJS.list <- lapply(m.by.array, function(m) {
if (length(m) == 1)
simpleCJS(m[[1]])
else
combineCJS(m)
})
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 = ".")
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)
overall.CJS <- recipient$CJS
intra.array.CJS <- recipient$intra.CJS
rm(recipient)
} else {
intra.array.matrices <- NULL
intra.array.CJS <- NULL
}
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) {
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)
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) {
output <- group.CJS[[i]]
x <- unlist(stringr::str_split(i, "\\.", 2))[1]
output$Release <- rep(c(sum(releases[, paste0("n.", x)]), NA, NA), 2)
output <- output[, c(ncol(output), 1:(ncol(output) - 1))]
return(output)
})
names(group.overview) <- names(aux)
rm(aux)
} else {
overall.CJS <- NULL
if (!is.null(replicates)) {
appendTo(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
} else {
intra.array.matrices <- NULL
intra.array.CJS <- NULL
}
release.overview <- NULL
group.overview <- NULL
}
# -------------------------------------
# wrap up in-R objects
deployments <- do.call(rbind.data.frame, deployments)
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('<span style="color:red">Manual mode has been triggered for **', length(override),'** tag(s).</span>\n')
else
override.fragment <- ""
if (file.exists(resultsname <- "actel_migration_results.RData")) {
continue <- TRUE
index <- 1
while (continue) {
if (file.exists(resultsname <- paste0("actel_migration_results.", index, ".RData"))) {
index <- index + 1
} else {
continue <- FALSE
}
}
rm(continue, index)
}
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?")
} else { # nocov end
decision <- "n"
}
if (decision == "y") { # nocov start
appendTo(c("Screen", "Report"), paste0("M: Saving results as '", resultsname, "'."))
if (attributes(dist.mat)$valid) {
save(detections, valid.detections, spatial, deployments, arrays, movements, valid.movements,
section.movements, status.df, section.overview, group.overview, release.overview, matrices,
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)
}
} else { # nocov end
appendTo(c("Screen", "Report"), paste0("M: Skipping saving of the results."))
}
rm(decision)
# ------------
# Print graphics
trigger.report.error.message <- TRUE
if (report) {
appendTo(c("Screen", "Report"), "M: Producing the report.")
on.exit({if (trigger.report.error.message) message("M: Producing the report failed. If you have saved a copy of the results, you can reload them using dataToList().")}, add = TRUE)
if (dir.exists(paste0(tempdir(), "/actel_report_auxiliary_files")))
unlink(paste0(tempdir(), "/actel_report_auxiliary_files"), recursive = TRUE)
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)
biometric.fragment <- printBiometrics(bio = bio)
efficiency.fragment <- printEfficiency(CJS = overall.CJS,
intra.CJS = intra.array.CJS,
type = "migration")
printDotplots(status.df = status.df,
valid.dist = attributes(dist.mat)$valid)
printSurvivalGraphic(section.overview = section.overview)
printLastArray(status.df = status.df)
printDot(dot = dot,
spatial = spatial,
print.releases = print.releases)
if (calculate.efficiency) {
printProgression(dot = dot,
overall.CJS = overall.CJS,
spatial = spatial,
status.df = status.df,
print.releases = print.releases)
display.progression <- TRUE
array.overview.fragment <- printArrayOverview(group.overview)
} else {
display.progression <- FALSE
array.overview.fragment <- ""
}
individual.plots <- printIndividuals(detections.list = detections,
movements = movements,
valid.movements = valid.movements,
spatial = spatial,
status.df = status.df,
rsp.info = rsp.info,
y.axis = detections.y.axis)
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 (any(sapply(valid.detections, function(x) any(!is.na(x$Sensor.Value))))) {
sensor.plots <- printSensorData(detections = valid.detections,
spatial = spatial,
rsp.info = rsp.info,
colour.by = detections.y.axis)
} else {
sensor.plots <- NULL
}
}
# ---------------
# wrap up the txt report
appendTo("Report", "M: Analysis completed!\n\n-------------------")
if (file.exists(paste(tempdir(), "temp_comments.txt", sep = "/")))
appendTo("Report", paste0("User comments:\n-------------------\n", gsub("\t", ": ", gsub("\r", "", readr::read_file(paste(tempdir(), "temp_comments.txt", sep = "/")))), "-------------------")) # nocov
if (file.exists(paste(tempdir(), "temp_UD.txt", sep = "/")))
appendTo("Report", paste0("User interventions:\n-------------------\n", gsub("\r", "", readr::read_file(paste(tempdir(), "temp_UD.txt", sep = "/"))), "-------------------")) # nocov
if (!is.null(datapack))
appendTo("Report", paste0("Preload function call:\n-------------------\n", attributes(datapack)$function_call, "\n-------------------"))
appendTo("Report", paste0("Migration function call:\n-------------------\n", the.function.call, "\n-------------------"))
# ------------------
# print html report
if (report) {
if (file.exists(reportname <- "actel_migration_report.html")) {
continue <- TRUE
index <- 1
while (continue) {
if(file.exists(reportname <- paste0("actel_migration_report.", index, ".html"))) {
index <- index + 1
} else {
continue <- FALSE
}
}
appendTo("Screen", paste0("M: An actel report is already present in the current directory.\n Saving new report as ", reportname, "."))
rm(continue, index)
} else {
appendTo("Screen", "M: Saving actel report as 'actel_migration_report.html'.")
}
appendTo("debug", "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)
appendTo("debug", "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)
appendTo("debug", "debug: Moving report")
file.copy(paste0(tempdir(), "/actel_report_auxiliary_files/actel_migration_report.html"), reportname)
if (interactive() & auto.open) { # nocov start
appendTo("debug", "debug: Opening report.")
browseURL(reportname)
} # nocov end
}
trigger.report.error.message <- FALSE
# ------------------
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?")
} else { # nocov end
decision <- "n"
}
if (decision == "y" | decision == "Y") { # nocov start
appendTo("Screen", paste0("M: Saving job log as '",jobname, "'."))
file.copy(paste(tempdir(), "temp_log.txt", sep = "/"), jobname)
} # nocov end
output <- list(detections = detections,
valid.detections = valid.detections,
spatial = spatial,
deployments = deployments,
arrays = arrays,
movements = movements,
valid.movements = valid.movements,
section.movements = section.movements,
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.CJS = intra.array.CJS,
times = times,
rsp.info = rsp.info)
if (attributes(dist.mat)$valid)
output$dist.mat <- dist.mat
appendTo("Screen", "M: Analysis completed!")
finished.unexpectedly <- FALSE
return(output)
}
#' Print Rmd report
#'
#' 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.
#' @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){
work.path <- paste0(tempdir(), "/actel_report_auxiliary_files/")
if (!is.null(spatial$unknowns)) {
unknown.fragment <- paste0('<span style="color:red"> Number of relevant unknown receivers: **', sum(sapply(spatial$unknowns, length)), '** (of which ', length(spatial$unknowns$included),' were included)</span>\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.
<center>\n", sensor.plots, "\n</center>")
} else {
sensor.fragment <- NULL
}
report <- readr::read_file(paste0(tempdir(), "/temp_log.txt"))
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 <- 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 <- gsub("(\\\\|\")", "\\\\\\1", comment.fragment)
} else {
comment.fragment <- 'No comments were included during the analysis.'
}
oldoptions <- options(knitr.kable.NA = "-")
on.exit(options(oldoptions), add = TRUE)
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.
<img src=', work.path, ifelse(file.exists(paste0(work.path, "mb_arrays.svg")), "mb_arrays.svg", "mb_arrays.png"), ' style="padding-top: 15px;"/>
### 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.
<center>
', biometric.fragment,'
</center>
')), '
### 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"), '
<center>
![](survival.png){ ',survival.graph.size ,' }
</center>
### Last Seen Arrays
Note:
: The data used in this graphic is stored in the `status.df` object (\'Very.last.array\' column).
<center>
![](last_arrays.png){ width=66% }
</center>
### 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.
<img src=', work.path, ifelse(file.exists(paste0(work.path, "mb_efficiency.svg")), "mb_efficiency.svg", "mb_efficiency.png"), ' style="padding-top: 15px; padding-bottom: 15px;"/>
'), '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.
<center>
', circular.plots,'
</center>
### 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.
<center>
![](', work.path, 'dotplots.png){ width=95% }
</center>
### 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).
<center>
', individual.plots,'
</center>
', 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(
'<style>
h3 {
padding-top: 25px;
padding-bottom: 15px;
}
h4 {
padding-top: 25px;
padding-bottom: 15px;
}
img[src*="#diagram"] {
width = 100%;
padding-top = 200px;
padding-bottom = 15px;
}
/* The sidebar menu */
.sidenav {
height: 100%;
width: 110px;
position: fixed;
z-index: 1;
top: 0;
left: 0;
background-color: #fcfcfc;
overflow-x: hidden;
padding-top: 20px;
}
/* The navigation menu links */
.sidenav a {
padding: 6px 8px 6px 16px;
text-decoration: none;
/*font-size: 25px;*/
color: #818181;
display: block;
}
.sidenav p {
padding: 6px 8px 6px 16px;
text-decoration: none;
font-size: 25px;
color: #818181;
display: block;
}
.sidenav a:hover {
background-color: #52a548;
color: #f1f1f1;
}
.fluid-row {
margin-left: 110px; /* Same as the width of the sidebar */
padding: 0px 10px;
}
.section {
margin-left: 110px; /* Same as the width of the sidebar */
padding: 0px 10px;
}
.level4 {
margin-left: 0px; /* Same as the width of the sidebar */
padding: 0px 0px;
}
/* On smaller screens, where height is less than 450px, change the style of the sidebar (less padding and a smaller font size) */
@media screen and (max-height: 450px) {
.sidenav {padding-top: 15px;}
.sidenav a {font-size: 18px;}
}
</style>
<div class="sidenav">
<p>Index:</p>
<a href="#summary">Summary</a>
<a href="#study-area">Study area</a>
<a href="#receiver-stations">Stations</a>
<a href="#deployments">Deployments</a>
<a href="#release-sites">Release sites</a>
<a href="#array-forward-efficiency">Array efficiency</a>
<a href="#warning-messages">Warnings</a>
<a href="#user-comments">Comments</a>',
ifelse(biometric.fragment == '', '', '\n <a href="#biometric-graphics">Biometrics</a>'),'
<a href="#section-survival">Section survival</a>
<a href="#last-seen-arrays">Last seen</a>
<a href="#progression">Progression</a>
<a href="#time-of-arrival-at-each-array">Arrival times</a>
<a href="#dotplots">Dotplots</a>
<a href="#individual-detection-plots">Individual detections</a>',
ifelse(is.null(sensor.fragment), '', '\n <a href="#sensor-plots">Sensor data</a>'),'
<a href="#full-log">Full log</a>
</div>
', 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.
#'
#' @inheritParams explore
#' @inheritParams migration
#' @inheritParams simplifyMovements
#' @inheritParams loadDetections
#' @inheritParams groupMovements
#' @inheritParams assembleArrayCJS
#' @param secmoves the section-movements
#' @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
#'
#' @keywords internal
#'
assembleTimetable <- function(secmoves, valid.moves, all.moves, spatial, arrays, bio, tz,
dist.mat, speed.method, if.last.skip.section, success.arrays) {
appendTo("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.
Last.array <- NULL
Last.time <- NULL
Last.station <- NULL
Section <- NULL
Valid <- NULL
Array <- NULL
Detections <- NULL
# temporarily calculate inter-section speeds
if (attributes(dist.mat)$valid) {
aux <- names(secmoves)
secmoves <- lapply(names(secmoves), function(tag) {
# cat(tag, "\n")
aux <- secmoves[[tag]]
aux$Speed.until <- NA
the.row <- match(tag, bio$Transmitter)
origin.time <- bio[the.row, "Release.date"]
origin.place <- as.character(bio[the.row, "Release.site"])
if (origin.time <= aux$First.time[1]) {
a.sec <- as.vector(difftime(aux$First.time[1], origin.time, units = "secs"))
my.dist <- dist.mat[aux$First.station[1], origin.place]
aux$Speed.until[1] <- round(my.dist/a.sec, 6)
}
if (nrow(aux) > 1) {
capture <- lapply(2:nrow(aux), function(i) {
if (speed.method == "last to first"){
a.sec <- as.vector(difftime(aux$First.time[i], aux$Last.time[i - 1], units = "secs"))
my.dist <- dist.mat[aux$First.station[i], gsub(" ", ".", aux$Last.station[i - 1])]
}
if (speed.method == "last to last"){
a.sec <- as.vector(difftime(aux$Last.time[i], aux$Last.time[i - 1], units = "secs"))
my.dist <- dist.mat[aux$Last.station[i], gsub(" ", ".", aux$Last.station[i - 1])]
}
aux$Speed.until[i] <<- round(my.dist/a.sec, 6)
rm(a.sec, my.dist)
})
}
return(aux)
})
names(secmoves) <- aux
rm(aux)
}
sections <- names(spatial$array.order)
# Create the timetable
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 = "."))
}
} 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, "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)
colnames(timetable) <- recipient
rm(recipient)
rownames(timetable) <- names(secmoves)
# Start filling it up
capture <- lapply(names(secmoves), function(tag) {
# cat(tag, "\n")
aux <- split(secmoves[[tag]], secmoves[[tag]]$Section)
appendTo("debug", paste0("Assembling timetable values for tag ", tag, "."))
recipient <- lapply(seq_along(aux), function(i) {
# cat(i, "\n")
recipient <- rep(NA, ncol(timetable))
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)
recipient[1, paste0("Average.time.until.", names(aux)[i])] <- 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)
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("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])
# --
recipient$Very.last.array <- secmoves[[tag]][.N, Last.array]
recipient$Very.last.time <- as.character(secmoves[[tag]][.N, Last.time])
recipient$Valid.detections <- sum(secmoves[[tag]]$Detections)
recipient$Valid.events <- nrow(valid.moves[[tag]])
if (any(!all.moves[[tag]]$Valid)) {
recipient$Invalid.detections <- sum(all.moves[[tag]][!(Valid)]$Detections)
recipient$Invalid.events <- sum(!all.moves[[tag]]$Valid)
} else {
recipient$Invalid.detections <- 0
recipient$Invalid.events <- 0
}
recipient$P.type <- attributes(secmoves[[tag]])$p.type
aux <- countBackMoves(movements = valid.moves[[tag]], arrays = arrays)
recipient$Backwards.movements <- aux[[1]]
recipient$Max.cons.back.moves <- aux[[2]]
recipient$P.type <- attributes(valid.moves[[tag]])$p.type
# assign fate
the.last.section <- secmoves[[tag]][.N, Section]
the.last.array <- secmoves[[tag]][.N, Last.array]
recipient$Status <- paste0("Disap. in ", the.last.section)
not.last.section <- match(the.last.section, sections) != length(sections)
edge.array <- arrays[[the.last.array]]$edge
if (if.last.skip.section && not.last.section && edge.array) {
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)))
recipient$Status <- "Succeeded"
# deploy values
appendTo("debug", paste0("Deploy timetable values for tag ", tag, "."))
timetable[tag, ] <<- recipient
return(NULL)
})
# Convert time and timestamp data
for (section in sections) {
for (the.col in c("Average.time.until.", "Average.time.in.", "Total.time.in.")) {
# convert to numeric
timetable[, paste0(the.col, section)] <- as.numeric(timetable[, paste0(the.col, section)])
# grab the mean for later use
aux <- mean(timetable[, paste0(the.col, section)], 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"
if (!is.nan(aux)) {
if (aux > 86400)
units(timetable[, paste0(the.col, section)]) <- "days"
if (aux <= 86400 & aux > 3600)
units(timetable[, paste0(the.col, section)]) <- "hours"
if (aux <= 3600)
units(timetable[, paste0(the.col, section)]) <- "mins"
}
timetable[, paste0(the.col, section)] <- round(timetable[, paste0(the.col, section)], 3)
}
for (the.col in c("First.arrived.", "Last.left.")) {
# convert to numeric posix
timetable[, paste0(the.col, section)] <- as.POSIXct(timetable[, paste0(the.col, section)], tz = tz)
}
}
timetable$Very.last.time <- as.POSIXct(timetable$Very.last.time, tz = tz)
timetable$Transmitter <- rownames(timetable)
return(timetable)
}
#' Count backwards movements
#'
#' @inheritParams simplifyMovements
#' @inheritParams assembleArrayCJS
#'
#' @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
#' }
#'
#' @keywords internal
#'
countBackMoves <- function(movements, arrays){
appendTo("debug", "Starting countBackMoves.")
if (nrow(movements) > 1) {# Determine number of backwards movements
aux <- data.frame(
A = movements$Array[-nrow(movements)],
B = movements$Array[-1])
backwards.movements <- apply(aux, 1, function(x)
if(x[1] != x[2])
is.na(match(x[2], arrays[[x[1]]]$all.after))
else
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
max.back.moves <- 0
} else {
sum.back.moves <- 0
max.back.moves <- 0
}
appendTo("debug", "Terminating countBackMoves.")
return(list(sum.back.moves = sum.back.moves, max.back.moves = max.back.moves))
}
#' Create status.df
#'
#' Combines the timetable and the original biometrics.
#'
#' @inheritParams explore
#' @inheritParams migration
#' @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
#' @inheritParams groupMovements
#' @inheritParams sectionMovements
#'
#' @return A data frame containing all the final data for each tag.
#'
#' @keywords internal
#'
assembleOutput <- function(timetable, bio, spatial, dist.mat, tz) {
appendTo("debug", "Merging 'bio' and 'timetable'.")
status.df <- merge(bio, timetable, by = "Transmitter", all = TRUE)
appendTo("debug", "Completing entries for tags that were never detected.")
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$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$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
appendTo("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")
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 = "// ")
}
}
} # nocov end
appendTo("debug", "Done.")
return(status.df)
}
#' Create section.overview
#'
#' 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.
#'
#' @keywords internal
#'
assembleSectionOverview <- function(status.df, spatial) {
appendTo("debug", "Starting assembleSectionOverview.")
section.overview <- as.data.frame.matrix(with(status.df, table(Group, Status)))
section.overview$Total <- as.vector(with(status.df, table(Group)))
colnames(section.overview) <- gsub(" ", ".", colnames(section.overview))
sections <- names(spatial$array.order)
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]
recipient <- vector()
for (i in 2:length(sections)) {
recipient <- c(recipient, paste(c("Migrated.to", "Disap..in"), sections[i], sep = "."))
}
} else {
recipient <- NULL
}
if (length(sections) > 2) {
for (i in 3:length(sections)) {
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]
}
}
recipient <- c("Total", paste("Disap..in", sections[1], sep = "."), recipient, "Succeeded")
appendTo("debug", "Terminating assembleSectionOverview.")
return(section.overview[, recipient])
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.