Restructure acdc_ and pf_ .R script files for easier editing.

R/acdc_simplify.R

@@ -0,0 +1,129 @@
+######################################
+######################################
+#### acdc_simplify()
+
+#' @title Simplify the outputs of the AC/DC algorithms
+#' @description This function simplifies the output of \code{\link[flapper]{ac}}, \code{\link[flapper]{dc}} and \code{\link[flapper]{acdc}}, by processing information from the 'archive' elements of a \code{\link[flapper]{acdc_archive-class}} object that hold the results of calls to the workhorse routines. This is especially useful if the algorithm(s) have been applied chunk-wise, in which case the results for each chunk are returned in a list. The function aggregates information across chunks to generate a continuous time series of results and a map of where the individual could have spend more or less time over the entire time series.
+#' @param archive An \code{\link[flapper]{acdc_archive-class}} object returned by \code{\link[flapper]{ac}}, \code{\link[flapper]{dc}} or \code{\link[flapper]{acdc}}.
+#' @param type A character that defines whether the function should be implemented for the outputs of a call to an AC* algorithm (\code{\link[flapper]{ac}} or \code{\link[flapper]{acdc}}), in which case \code{type = "acs"}, or the DC algorithm, in which case \code{type = "dc"}.
+#' @param mask (optional) A spatial mask (e.g., the argument passed to \code{bathy} in \code{\link[flapper]{ac}}, \code{\link[flapper]{dc}} or \code{\link[flapper]{acdc}}) to mask areas (e.g., land) from the overall map. If implemented, cells in masked areas are assigned NAs rather than a score of 0.
+#' @param normalise A logical input that defines whether or not to normalise the overall map so that cell scores sum to one.
+#' @param keep_chunks A logical variable that defines whether or not to retain all chunk-specific information.
+#' @param ... Additional arguments (none implemented).
+#' @return The function returns an object of class \code{\link[flapper]{acdc_record-class}}.
+#' @details If the \code{\link[flapper]{ac}}, \code{\link[flapper]{dc}} or \code{\link[flapper]{acdc}} function was implemented step-wise, this function simply extracts the necessary information and re-packages it into an \code{\link[flapper]{acdc_record-class}} object. For a chunk-wise implementation, the function (a) computes the map of where the individual could have spent more or less time by aggregating the chunk-specific maps (accounting for the overlap between chunks for AC* algorithm(s)); (b) simplifies chunk-specific records into a single contiguous time series, with re-defined time stamps from the start to the end of the time series (for AC* algorithm(s)) to (c) return an \code{\link[flapper]{acdc_record-class}} object.
+#' @seealso The AC, DC and ACDC algorithms are implemented by \code{\link[flapper]{ac}}, \code{\link[flapper]{dc}} and \code{\link[flapper]{acdc}}. After simplification, \code{\link[flapper]{acdc_plot_record}} and \code{\link[flapper]{acdc_animate_record}} can be implemented to visualise time-specific results.
+#' @author Edward Lavender
+#' @export
+#'
+
+acdc_simplify <- function(archive, type = c("acs", "dc"), mask = NULL, normalise = FALSE, keep_chunks = FALSE,...) {
+
+  #### Checks
+  if(!(inherits(archive, "acdc_archive") | !inherits(archive, "acdc_record"))){
+    stop("Object of class 'acdc_archive' expected.")
+  }
+  if(inherits(archive, "acdc_archive")) {
+    "class(archive) == 'acdc_archive': 'archive' returned unchanged."
+    return(archive)
+  }
+  type <- match.arg(type)
+  message("acdc_simplify() implemented for type = '", type, "'.")
+
+  #### Set up
+  out <- list(map = NULL, record = NULL, time = archive$time, args = archive$args, chunks = NULL, simplify = TRUE)
+
+  #### Simplify extract outputs the algorithm has only been implemented for a single chunk
+  if(length(archive$archive) == 1){
+
+    out$map <- archive$archive[[1]]$map
+    out$record <- archive$archive[[1]]$record
+
+    #### Otherwise aggregate information across chunks
+  } else{
+
+    if(type == "dc"){
+
+      #### Get cumulative map from each chunk
+      maps <- lapply(archive$archive, function(chunk) chunk$map)
+
+      #### Simplify records
+      out$record <- lapply(archive$archive, function(chunk) chunk$record)
+
+    } else if(type == "acs"){
+
+      #### Get cumulative map from each chunk
+      # Get the first map of each chunk
+      maps_first <- lapply(archive$archive, function(chunk) {
+        map_1 <- chunk$record[[1]]$spatial[[1]]$map_timestep
+        if(is.null(map_1)) {
+          stop("chunk$record[[1]]$spatial[[1]]$map_timestep is NULL. In flapper::acdc(), save_record_spatial = 1L (or greater/NULL) is required to return the necessary spatial information to correct for overlapping detection time series across chunks in the summation of chunk-specific maps.")
+        }
+        return(map_1)
+      })
+      # Get the cumulative map from each chunk
+      maps_last <- lapply(archive$archive, function(chunk) chunk$map)
+      # Correct for the repeated influence of the first map due to the overlapping detection time series
+      maps <- lapply(2:length(maps_last), function(i){
+        map <- sum(maps_last[[i]], -maps_first[[i]], na.rm = TRUE)
+        return(map)
+      })
+      # Create the list of cumulative (adjusted) maps
+      maps <- append(list(maps_last[[1]]), maps)
+
+      #### Simplify records
+      ## Add chunk-specific records
+      out$record <- lapply(archive$archive, function(chunk) chunk$record)
+      ## Delete the last element of each chunk (except the last chunk) since chunks are overlapping
+      out$record <- lapply(out$record, function(chunk) chunk[1:(length(chunk)-1)])
+      ## Define a dataframe to adjust the time stamps recorded for each chunks
+      # For chunks 2:n_chunks, we will add the time stamps reached by the previous chunk
+      # ... up to the current chunk
+      adjust_timestep <- lapply(out$record, function(chunk_record){
+        # chunk_record <- out$record[[1]]
+        dat <- chunk_record[[length(chunk_record)]]$dat
+        adjustment <- dat[nrow(dat), c("timestep_cumulative", "timestep_detection")]
+        return(adjustment)
+      })
+      adjust_timestep <- do.call(rbind, adjust_timestep)
+      adjust_timestep$timestep_cumulative <- cumsum(adjust_timestep$timestep_cumulative)
+      adjust_timestep$timestep_detection <- cumsum(adjust_timestep$timestep_detection)
+      ## Adjust time stamps and add the chunk to the dataframe for each time stamp
+      out$record <- lapply(1:length(out$record), function(i) {
+        chunk_record <- out$record[[i]]
+        if(i == 1) {
+          adjustment <- data.frame(timestep_cumulative = 0, timestep_detection = 0)
+        } else{
+          adjustment <- adjust_timestep[i-1, ]
+        }
+        chunk_record <- lapply(chunk_record, function(t){
+          t$dat$timestep_cumulative <- t$dat$timestep_cumulative + adjustment$timestep_cumulative
+          t$dat$timestep_detection <- t$dat$timestep_detection + adjustment$timestep_detection
+          t$dat$chunk <- i
+          return(t)
+        })
+        return(chunk_record)
+      })
+    }
+
+    #### Sum the adjusted maps across chunks
+    out$map <- raster::brick(maps)
+    out$map <- raster::calc(out$map, sum, na.rm = TRUE)
+
+    #### Flatten record list across chunks
+    out$record <- purrr::flatten(out$record)
+
+  }
+
+  #### Mask and normalise the final map
+  if(!is.null(mask)) out$map <- raster::mask(out$map, mask)
+  if(normalise) out$map <- out$map/raster::cellStats(out$map, "sum")
+
+  #### Keep chunk-specific information, if requested
+  if(keep_chunks) out$chunks <- archive$archive
+
+  #### Return outputs
+  class(out) <- c(class(out), "acdc_record")
+  return(out)
+
+}