feat: add parallel processing

- adds `n.core` - adds {mirai} as Suggested fixes #71
openair-project · Nov 25, 2024 · 4ab2191 · 4ab2191
1 parent dd9f5e4
commit 4ab2191
Show file tree

Hide file tree

Showing 18 changed files with 175 additions and 53 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Type: Package
 Package: openairmaps
 Title: Create Maps of Air Pollution Data
-Version: 0.9.1.9000
+Version: 0.9.1.9001
 Authors@R: c(
     person("Jack", "Davison", , "jack.davison@ricardo.com", role = c("cre", "aut"),
            comment = c(ORCID = "0000-0003-2653-6615")),
@@ -43,6 +43,7 @@ Suggests:
     httr,
     jsonlite,
     knitr,
+    mirai,
     rmarkdown,
     shiny,
     worldmet

diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,11 @@
 # openairmaps (development version)
 
+## New features
+
+* Polar marker functions have gained the `n.core` argument, which allows for the use of `{mirai}` for parallel plot creation. `{mirai}` is not imported by `{openairmaps}` by default, but users will be prompted to download it if they set `n.core` to be greater than `1L`.
+
+* The progress bar shown when `progress = TRUE` now better reflects the actual time until function completion.
+
 # openairmaps 0.9.1
 
 ## New features

diff --git a/R/addPolarMarkers.R b/R/addPolarMarkers.R
@@ -130,7 +130,8 @@ addPolarMarkers <-
         d.fig = d.fig,
         popup = popup,
         label = label,
-        dropcol = pollutant
+        dropcol = pollutant,
+        ncores = 1L
       )
 
     # work out width/height

diff --git a/R/polar_annulusMap.R b/R/polar_annulusMap.R
@@ -62,6 +62,7 @@ annulusMap <- function(data,
                        static = FALSE,
                        static.nrow = NULL,
                        progress = TRUE,
+                       n.core = 1L,
                        ...,
                        control = NULL) {
   # check basemap providers are valid
@@ -197,7 +198,8 @@ annulusMap <- function(data,
       d.fig = d.fig,
       popup = popup,
       label = label,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (static) {

diff --git a/R/polar_diffMap.R b/R/polar_diffMap.R
@@ -34,7 +34,7 @@
 #'  The colours used for plotting, passed to [openair::openColours()].  It is
 #'  recommended to use a "diverging" colour palette (along with a symmetrical
 #'  `limit` scale) for effective visualisation.
-#' 
+#'
 #' @inheritDotParams openair::polarPlot -mydata -pollutant -x -limits -type
 #'   -cols -key -key.footer -key.header -key.position -units -angle.scale -alpha
 #'   -plot
@@ -82,6 +82,7 @@ diffMap <- function(before,
                     static = FALSE,
                     static.nrow = NULL,
                     progress = TRUE,
+                    n.core = 1L,
                     ...,
                     control = NULL) {
   # check basemap providers are valid

diff --git a/R/polar_freqMap.R b/R/polar_freqMap.R
@@ -85,6 +85,7 @@ freqMap <- function(data,
                     static = FALSE,
                     static.nrow = NULL,
                     progress = TRUE,
+                    n.core = 1L,
                     ...,
                     control = NULL) {
   # check basemap providers are valid
@@ -216,7 +217,8 @@ freqMap <- function(data,
       d.fig = d.fig,
       popup = popup,
       label = label,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (static) {

diff --git a/R/polar_percentileMap.R b/R/polar_percentileMap.R
@@ -71,6 +71,7 @@ percentileMap <- function(data,
                           static = FALSE,
                           static.nrow = NULL,
                           progress = TRUE,
+                          n.core = 1L,
                           ...,
                           control = NULL) {
   # check basemap providers are valid
@@ -189,7 +190,8 @@ percentileMap <- function(data,
       d.fig = d.fig,
       popup = popup,
       label = label,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (static) {

diff --git a/R/polar_polarMap.R b/R/polar_polarMap.R
@@ -276,6 +276,15 @@
 #'   creating individual polar markers. This option allows this to be turned
 #'   off, if desired.
 #'
+#' @param n.core *Number of cores to use in parallel processing.*
+#'
+#'  *default:* `1L` | *scope:* dynamic & static
+#'
+#'   By default, each polar marker is drawn and saved sequentially. For big maps
+#'   with a lot of markers, this can be slow. Adjusting `n.core` to a number
+#'   greater than `1` will use [mirai][mirai::mirai-package] to create markers
+#'   in parallel.
+#'
 #' @param control **Deprecated.** Please use `type`.
 #'
 #' @inheritDotParams openair::polarPlot -mydata -pollutant -x -limits -type
@@ -325,6 +334,7 @@ polarMap <- function(data,
                      static = FALSE,
                      static.nrow = NULL,
                      progress = TRUE,
+                     n.core = 1L,
                      ...,
                      control = NULL) {
   # list pairwise statistics
@@ -482,7 +492,8 @@ polarMap <- function(data,
       popup = popup,
       label = label,
       dropcol = funpoll,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (!static) {

diff --git a/R/polar_pollroseMap.R b/R/polar_pollroseMap.R
@@ -74,6 +74,7 @@ pollroseMap <- function(data,
                         static = FALSE,
                         static.nrow = NULL,
                         progress = TRUE,
+                        n.core = 1L,
                         ...,
                         control = NULL) {
   # check basemap providers are valid
@@ -169,7 +170,8 @@ pollroseMap <- function(data,
       d.fig = d.fig,
       popup = popup,
       label = label,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (static) {

diff --git a/R/polar_windroseMap.R b/R/polar_windroseMap.R
@@ -78,6 +78,7 @@ windroseMap <- function(data,
                         static = FALSE,
                         static.nrow = NULL,
                         progress = TRUE,
+                        n.core = 1L,
                         ...,
                         control = NULL) {
   # check basemap providers are valid
@@ -175,7 +176,8 @@ windroseMap <- function(data,
       d.fig = d.fig,
       popup = popup,
       label = label,
-      progress = progress
+      progress = progress,
+      ncores = n.core
     )
 
   if (static) {

diff --git a/R/utils-map.R b/R/utils-map.R
@@ -84,7 +84,7 @@ checkMapPrep <-
       if (wd %in% Names & is.numeric(mydata[, wd])) {
         ## check for wd <0 or > 360
         if (any(sign(mydata[[wd]][!is.na(mydata[[wd]])]) == -1 |
-          mydata[[wd]][!is.na(mydata[[wd]])] > 360)) {
+                mydata[[wd]][!is.na(mydata[[wd]])] > 360)) {
           warning("Wind direction < 0 or > 360; removing these data")
           mydata[[wd]][mydata[[wd]] < 0] <- NA
           mydata[[wd]][mydata[[wd]] > 360] <- NA
@@ -234,7 +234,7 @@ assume_latlon <- function(data, latitude, longitude) {
     len <- length(out)
     if (len > 1) {
       cli::cli_abort("Cannot identify {name}: Multiple possible matches ({out})",
-        call = NULL
+                     call = NULL
       )
       return(NULL)
     } else if (len == 0) {
@@ -325,8 +325,8 @@ make_leaflet_map <-
     }
     for (i in seq_along(provider)) {
       map <- leaflet::addProviderTiles(map,
-        provider[[i]],
-        group = names(provider)[[i]]
+                                       provider[[i]],
+                                       group = names(provider)[[i]]
       )
     }
 
@@ -424,7 +424,8 @@ create_polar_markers <-
            label = NULL,
            d.fig,
            dropcol = "conc",
-           progress = TRUE) {
+           progress = TRUE,
+           ncores) {
     # make temp directory
     dir <- tempdir()
 
@@ -467,22 +468,19 @@ create_polar_markers <-
 
     # create plots
     plots_df <-
-      nested_df %>%
-      dplyr::mutate(
-        plot = purrr::map(data, fun, .progress = ifelse(progress, "Creating Polar Markers", FALSE)),
-        url = paste0(
-          dir,
-          "/",
-          .data[[latitude]],
-          "_",
-          .data[[longitude]],
-          "_",
-          rm_illegal_chars(.data[[split_col]]),
-          "_",
-          id,
-          ".png"
-        )
-      )
+      dplyr::mutate(nested_df,
+                    url = paste0(
+                      dir,
+                      "/",
+                      .data[[latitude]],
+                      "_",
+                      .data[[longitude]],
+                      "_",
+                      rm_illegal_chars(.data[[split_col]]),
+                      "_",
+                      id,
+                      ".png"
+                    ))
 
     # work out w/h
     if (length(d.fig) == 1) {
@@ -493,29 +491,53 @@ create_polar_markers <-
       height <- d.fig[[2]]
     }
 
-    purrr::pwalk(
-      list(
-        plots_df[[latitude]],
-        plots_df[[longitude]],
-        rm_illegal_chars(plots_df[[split_col]]),
-        plots_df$plot
-      ),
-      .f = ~ {
-        grDevices::png(
-          filename = paste0(dir, "/", ..1, "_", ..2, "_", ..3, "_", id, ".png"),
-          width = width * 300,
-          height = height * 300,
-          res = 300,
-          bg = "transparent",
-          type = "cairo",
-          antialias = "none"
-        )
+    save_plot <- function(data, url) {
+      grDevices::pdf(NULL)
+
+      plot <- fun(data)
+
+      grDevices::png(
+        filename = url,
+        width = width * 300,
+        height = height * 300,
+        res = 300,
+        bg = "transparent",
+        type = "cairo",
+        antialias = "none"
+      )
 
-        plot(..4)
+      print(plot)
 
-        grDevices::dev.off()
+      grDevices::dev.off()
+
+      return(plot)
+    }
+
+    if (ncores == 1L) {
+      plots_df$plot <- purrr::pmap(
+        .l = dplyr::select(plots_df, "data", "url"),
+        .f = save_plot,
+        .progress = progress
+      )
+    } else {
+      rlang::check_installed("mirai")
+      if (progress) {
+        plots_df$plot <-
+          with(mirai::daemons(ncores),
+               mirai::mirai_map(
+                 .x = dplyr::select(plots_df, "data", "url"),
+                 .f = save_plot
+               )[mirai::.progress_cli, mirai::.stop])
+
+      } else {
+        plots_df$plot <-
+          with(mirai::daemons(ncores),
+               mirai::mirai_map(
+                 .x = dplyr::select(plots_df, "data", "url"),
+                 .f = save_plot
+               )[mirai::.stop])
       }
-    )
+    }
 
     return(plots_df)
   }
@@ -598,7 +620,7 @@ create_static_map <-
       ggplot2::labs(x = NULL, y = NULL)
 
     if (length(pollutant) > 1 |
-      !is.null(facet)) {
+        !is.null(facet)) {
       plt <-
         plt + ggplot2::facet_wrap(ggplot2::vars(.data[[split_col]]), nrow = facet.nrow) +
         ggplot2::theme(strip.text = ggtext::element_markdown())
@@ -735,8 +757,8 @@ check_legendposition <- function(position, static) {
   } else {
     position <- position %||% "topright"
     rlang::arg_match(position,
-      c("topright", "topleft", "bottomright", "bottomleft"),
-      multiple = TRUE
+                     c("topright", "topleft", "bottomright", "bottomleft"),
+                     multiple = TRUE
     )
   }
   return(position)

diff --git a/man/annulusMap.Rd b/man/annulusMap.Rd
diff --git a/man/diffMap.Rd b/man/diffMap.Rd