Further develop pf_simplify() with streamlined distance calculations …

…(for outputs from the fast Euclidean method) and write_history argument.

R/acdc_analyse_record.R

@@ -87,8 +87,9 @@ acdc_access_timesteps <- function(record){
 
 acdc_access_maps <- function(record, type = c("map_timestep", "map_cumulative"), select = NULL){
   check_class_acdc_record(record)
+  type <- match.arg(type)
   maps <- lapply(record$record, function(record_elm){
-    lapply(record_elm$spatial, function(spatial_elm) spatial_elm$map_cumulative)
+    lapply(record_elm$spatial, function(spatial_elm) spatial_elm[[type]])
   })
   maps <- unlist(maps)
   if(!is.null(select)) maps <- maps[select]

R/dists.R

@@ -1,3 +1,21 @@
+########################################
+########################################
+#### raster:::..planedist2()
+
+#' @title Calculate a matrix of Euclidean distances between points
+#' @param p1 A coordinate matrix.
+#' @param p2 A coordinate matrix.
+#' @details This function assumes that coordinates are in planar space.
+#' @source This function is an internal function in the \code{\link[raster]{raster}} package (https://rdrr.io/rforge/raster/src/R/pointdistance.R). It is defined separately in \code{\link[flapper]{flapper}} for stability.
+#' @keywords internal
+
+.planedist2 <- function(p1, p2){
+  z0 <- complex(, p1[, 1], p1[, 2])
+  z1 <- complex(, p2[, 1], p2[, 2])
+  outer(z0, z1, function(z0, z1) Mod(z0 - z1))
+}
+
+
 ########################################
 ########################################
 #### dist_btw_receivers()

R/lcps.R

@@ -1472,10 +1472,11 @@ lcp_over_surface <-
 #'
 #' ## Alternatively, we could re-implement the algorithm using shortest distances
 #' # Re-implement algorithm
-#' dcpf_args <- dat_dcpf_histories$args
+#' dcpf_args               <- dat_dcpf_histories$args
 #' dcpf_args$calc_distance <- "lcp"
-#' dcpf_history <- do.call(pf, dcpf_args)
-#' paths <- pf_simplify(dcpf_history)
+#' dcpf_args$n             <- 100
+#' dcpf_history            <- do.call(pf, dcpf_args)
+#' paths                   <- pf_simplify(dcpf_history)
 #' # Interpolate paths
 #' paths_interp_4 <- lcp_interp(paths, surface)
 #' # Show the probabilities reported by the DCPF algorithm are the same as those

R/pf.R

@@ -179,8 +179,6 @@
 #'            seed = 1)
 #' # Algorithm duration during testing ~0.04 minutes
 #'
-#' \dontrun{
-#'
 #' #### Example (4): Implement algorithm using shortest distances
 #' # Note the need for a surface with equal resolution if this option is implemented.
 #' # To speed up the initial stages of the algorithm, you can supply the graph
@@ -361,9 +359,12 @@
 #'                        timestep = 1:nrow(path_sim))
 #' path_sim$cell_z <- raster::extract(dat_gebco_planar, path_sim$cell_id)
 #' prettyGraphics::pretty_plot(path_sim$cell_z, type = "l")
+#' # Check simulated movements on the scale of the grid
+#' sp::spDists(raster::xyFromCell(dat_gebco_planar, path_sim$cell_id),
+#'             segments = TRUE)
 #' # Simulate 'observed' depth time series given some error
 #' # ... For illustration, we will make the error smaller in this example
-#' cde <- function(...) c(-2.5, 2.5)
+#' cde <- function(...) matrix(c(-2.5, 2.5), nrow = 2)
 #' depth_obs <- runif(length(path_sim$cell_z),
 #'                    path_sim$cell_z + cde(path_sim$cell_z)[1],
 #'                    path_sim$cell_z + cde(path_sim$cell_z)[2])
@@ -383,7 +384,8 @@
 #' # We will assume that the origin was known.
 #' # ... We will mostly use the default options.
 #' history_dcpf <-
-#'   pf(record = lapply(dc_out$archive$record, function(r) r$spatial[[1]]$map_timestep),
+#'   pf(record = acdc_access_maps(acdc_simplify(dc_out, type = "dc"),
+#'                                type = "map_timestep"),
 #'      origin = origin_sim,
 #'      calc_distance = "euclid",
 #'      mobility = 200,
@@ -394,17 +396,14 @@
 #' # ... The green area shows areas of the requisite depth at that time step and the
 #' # ... particles show sampled locations at that time step. The simulated path
 #' # ... is shown in black.
-#' plot_history <- FALSE
-#' if(plot_history){
-#'   pp <- graphics::par(mfrow = c(3, 4))
-#'   pf_plot_history(history_dcpf,
-#'                   add_particles = list(pch = 21),
-#'                   add_paths = list(x = path_sim$cell_x, path_sim$cell_y, length = 0.05),
-#'                   xlim = range(path_sim$cell_x), ylim = range(path_sim$cell_y),
-#'                   crop_spatial = TRUE,
-#'                   prompt = FALSE)
-#'   graphics::par(pp)
-#' }
+#' pp <- graphics::par(mfrow = c(3, 4))
+#' pf_plot_history(history_dcpf,
+#'                 add_particles = list(pch = 21),
+#'                 add_paths = list(x = path_sim$cell_x, path_sim$cell_y, length = 0.05),
+#'                 xlim = range(path_sim$cell_x), ylim = range(path_sim$cell_y),
+#'                 crop_spatial = TRUE,
+#'                 prompt = FALSE)
+#' graphics::par(pp)
 #'
 #' ## Assemble paths
 #' path_dcpf <- pf_simplify(history_dcpf, bathy = dat_gebco_planar)
@@ -416,11 +415,13 @@
 #' # ... of the movement model
 #' require(rlang)
 #' path_dcpf <-
-#'   path_dcpf %>% dplyr::group_by(.data$path_id) %>%
-#'   dplyr::mutate(cell_x2 = dplyr::lead(.data$cell_x),
-#'                 cell_y2 = dplyr::lead(.data$cell_y),
+#'   path_dcpf %>%
+#'   dplyr::group_by(.data$path_id) %>%
+#'   dplyr::mutate(cell_x2 = dplyr::lag(.data$cell_x),
+#'                 cell_y2 = dplyr::lag(.data$cell_y),
 #'                 dist_1 = sqrt((.data$cell_x2 - .data$cell_x)^2 +
 #'                                 (.data$cell_y2 -.data$ cell_y)^2))
+#' path_dcpf
 #' range(path_dcpf$dist_1, na.rm =TRUE)
 #'
 #' ## Visualise paths
@@ -440,8 +441,6 @@
 #'              prompt = TRUE)
 #' }
 #'
-#' }
-#'
 #' #### Example (11): Write a dataframe of sampled particles to file at each time step
 #' # Define directory in which to save files
 #' root <- paste0(tempdir(), "/pf/")
@@ -861,6 +860,12 @@ pf <- function(record,
         })
         cells_from_current_to_next <- compact(cells_from_current_to_next)
         cells_from_current_to_next <- do.call(rbind, cells_from_current_to_next)
+        if(is.null(cells_from_current_to_next)){
+          cells_from_current_to_next <- data.table::data.table(id_current = integer(),
+                                                               pr_current = numeric(),
+                                                               id_next = integer(),
+                                                               pr_next = numeric())
+        }
       }
 
       ## Processing