feat: add alpha (transparency) for all types in mf_map() and mf_raster()

fix #78

R/mf_base.R

@@ -5,7 +5,9 @@
 #' @eval my_params(c(
 #' 'col',
 #' 'border',
-#' 'lwd', 'pch',
+#' 'lwd',
+#' 'pch',
+#' 'alpha',
 #' 'add'))
 #' @param cex point size
 #' @param bg background color
@@ -23,6 +25,7 @@
 mf_base <- function(x,
                     col = "grey80",
                     border = "grey20",
+                    alpha = NULL,
                     bg = "white",
                     cex = 1,
                     pch = 20,
@@ -40,16 +43,54 @@ mf_base <- function(x,
   }
 
   xtype <- get_geom_type(x)
-  if (xtype != "POLYGON" && missing(col)) {
-    col <- "grey20"
+
+  if (xtype == "LINE") {
+    if (missing(col)) {
+      col <- "grey20"
+    }
+    if (!is.null(alpha)) {
+      col <- get_hex_pal(col, alpha)
+    }
+    plot(
+      st_geometry(x),
+      col = col, lwd = lwd, lty = lty,
+      add = TRUE, ...
+    )
+  }
+
+  if (xtype == "POLYGON") {
+    if (!is.null(alpha)) {
+      col <- get_hex_pal(col, alpha)
+    }
+    plot(
+      st_geometry(x),
+      col = col, border = border, lwd = lwd, lty = lty,
+      add = TRUE, ...
+    )
   }
 
-  plot(st_geometry(x),
-    col = col, border = border,
-    lwd = lwd, add = add, pch = pch,
-    bg = bg, lty = lty, cex = cex,
-    ...
-  )
+  if (xtype == "POINT") {
+    if (missing(col)) {
+      col <- "grey20"
+    }
+    if (!is.null(alpha)) {
+      col <- get_hex_pal(col, alpha)
+    }
+    if (pch %in% 21:25) {
+      if (missing(border)) {
+        border <- "grey80"
+      }
+      mycolspt <- border
+    } else {
+      mycolspt <- col
+    }
+    mycolsptbg <- col
+    plot(
+      st_geometry(x),
+      col = mycolspt, bg = mycolsptbg, cex = cex, pch = pch,
+      lwd = lwd, add = TRUE, ...
+    )
+  }
 
   return(invisible(x))
 }

R/mf_choro.R

@@ -57,7 +57,7 @@
 #' )
 mf_choro <- function(x, var,
                      pal = "Mint",
-                     alpha = 1,
+                     alpha = NULL,
                      rev = FALSE,
                      breaks = "quantile",
                      nbreaks,

R/mf_doc_utils.R

@@ -54,13 +54,10 @@ my_params <- function(x) {
       "whether the ordering of the colors should be reversed (TRUE)",
       " or not (FALSE)"
     ),
-    alpha = paste0(
-      "alpha if \\code{pal} is a \\link{hcl.colors} palette name, ",
-      "the alpha-transparency level in the range [0,1]"
-    ),
+    alpha = "alpha opacity, in the range [0,1]",
     col_na = "col_na color for missing values",
-    cex_na = "cex_na cex (point size) for NA values",
-    pch_na = "pch_na pch (point type) for NA values",
+    cex_na = "cex_na point size for NA values",
+    pch_na = "pch_na point type for NA values",
     val_max = "val_max maximum value used for proportional symbols",
     breaks = paste0(
       "breaks either a numeric vector with the actual breaks, ",

R/mf_get_pal.R

@@ -4,22 +4,17 @@
 #' Diverging color palettes can be dissymmetric (different number of colors in
 #' each of the two gradients).
 #' @name mf_get_pal
-#' @param n the number of colors (>= 1) to be in the palette.
-#' @param palette a valid palette name (one of hcl.pals()). The name is matched
-#' to
-#' the list of available palettes, ignoring upper vs. lower case, spaces,
-#' dashes,
-#' etc. in the matching.
+#' @param n the number of colors (>= 1) to be in the palette
+#' @param palette a valid palette name. See \link{hcl.pals} to get available
+#' palette names. The name is matched
+#' to the list of available palettes, ignoring upper vs. lower case, spaces,
+#' dashes, etc. in the matching.
 #' @param alpha an alpha-transparency level in the range [0,1] (0 means
-#' transparent and 1 means opaque), see argument alpha in hsv and hcl,
-#' respectively.
+#' transparent and 1 means opaque)
 #' @param rev	logical indicating whether the ordering of the colors should be
-#' reversed.
+#' reversed
 #' @param neutral a color, if two gradients are used, the 'neutral' color can be
-#' added between them.
-#' @details See \link{hcl.pals} to get available palette names.
-#' If two gradients are used, the 'neutral' color can be added between them.
-#'
+#' added between them
 #' @return A vector of colors.
 #' @importFrom grDevices hcl.colors
 #' @export

R/mf_grad.R

@@ -9,6 +9,7 @@
 #' 'pch',
 #' 'add' ,
 #' 'col',
+#' 'alpha',
 #' 'leg_pos',
 #' 'leg_title',
 #' 'leg_title_cex',
@@ -44,6 +45,7 @@ mf_grad <- function(x,
                     breaks = "quantile",
                     nbreaks = 3,
                     col = "tomato4",
+                    alpha = NULL,
                     border = getOption("mapsf.fg"),
                     pch = 21,
                     cex,
@@ -67,6 +69,10 @@ mf_grad <- function(x,
   on.exit(par(op))
   xout <- x
 
+  if (!is.null(alpha)) {
+    col <- get_hex_pal(col, alpha)
+  }
+
   # data prep
   x <- x[!is.na(x = x[[var]]), ]
   x <- x[order(x[[var]], decreasing = TRUE), ]

R/mf_map.R

@@ -29,16 +29,16 @@
 #' ## Relevant arguments and default values for each map types:
 #' **base**: displays sf objects geometries.
 #' \preformatted{
-#' mf_map(x, col = "grey80", pch = 20, cex = 1, border = "grey20", lwd = 0.7,
-#'        expandBB, add = FALSE, ...)
+#' mf_map(x, col = "grey80", pch = 20, cex = 1, border = "grey20",
+#'        lwd = 0.7, alpha = NULL, expandBB, add = FALSE, ...)
 #'        }
 #'
 #' **prop**: displays symbols with areas proportional to a quantitative
 #' variable (stocks). `inches` is used to set symbols sizes.
 #' \preformatted{
 #' mf_map(x, var, type = "prop", inches = 0.3, val_max, symbol = "circle",
-#'        col = "tomato4", lwd_max = 20, border = getOption("mapsf.fg"),
-#'        lwd = 0.7, expandBB, add = TRUE,
+#'        col = "tomato4", alpha = NULL, lwd_max = 20,
+#'        border = getOption("mapsf.fg"), lwd = 0.7, expandBB, add = TRUE,
 #'        leg_pos = mf_get_leg_pos(x), leg_title = var,
 #'        leg_title_cex = 0.8, leg_val_cex = 0.6, leg_val_rnd = 0,
 #'        leg_frame = FALSE, leg_frame_border = getOption("mapsf.fg"),
@@ -54,7 +54,7 @@
 #' can use palette names from `hcl.pals()`.
 #' \preformatted{
 #' mf_map(x, var, type = "choro", breaks = "quantile", nbreaks, pal = "Mint",
-#'        alpha = 1, rev = FALSE, pch = 21, cex = 1,
+#'        alpha = NULL, rev = FALSE, pch = 21, cex = 1,
 #'        border = getOption("mapsf.fg"), lwd = 0.7, col_na = "white",
 #'        cex_na = 1, pch_na = 4, expandBB, add = FALSE,
 #'        leg_pos = mf_get_leg_pos(x), leg_title = var, leg_title_cex = 0.8,
@@ -68,7 +68,7 @@
 #' **typo**: displays a typology map of a qualitative variable.
 #' `val_order` is used to set modalities order in the legend.
 #' \preformatted{
-#' mf_map(x, var, type = "typo", pal = "Dynamic", alpha = 1, rev = FALSE,
+#' mf_map(x, var, type = "typo", pal = "Dynamic", alpha = NULL, rev = FALSE,
 #'        val_order,border = getOption("mapsf.fg"), pch = 21, cex = 1,
 #'        lwd = 0.7, cex_na = 1, pch_na = 4, col_na = "white",
 #'        leg_pos = mf_get_leg_pos(x), leg_title = var, leg_title_cex = 0.8,
@@ -82,7 +82,7 @@
 #' **symb**: displays the different modalities of a qualitative variable as
 #' symbols.
 #' \preformatted{
-#' mf_map(x, var, type = "symb", pal = "Dynamic", alpha = 1, rev = FALSE,
+#' mf_map(x, var, type = "symb", pal = "Dynamic", alpha = NULL, rev = FALSE,
 #'        border = getOption("mapsf.fg"), pch, cex = 1, lwd = 0.7,
 #'        col_na = "grey", pch_na = 4, cex_na = 1, val_order,
 #'        leg_pos = mf_get_leg_pos(x), leg_title = var, leg_title_cex = 0.8,
@@ -96,7 +96,7 @@
 #' `breaks` and `nbreaks`. Symbol sizes are set with `cex`.
 #' \preformatted{
 #' mf_map(x, var, type = "grad", breaks = "quantile", nbreaks = 3, col = "tomato4",
-#'        border = getOption("mapsf.fg"), pch = 21, cex, lwd,
+#'        alpha = NULL, border = getOption("mapsf.fg"), pch = 21, cex, lwd,
 #'        leg_pos = mf_get_leg_pos(x), leg_title = var, leg_title_cex = 0.8,
 #'        leg_val_cex = 0.6, leg_val_rnd = 2, leg_frame = FALSE,
 #'        leg_adj = c(0, 0), leg_size = 1, leg_border = border,
@@ -110,7 +110,7 @@
 #' quantitative variable.
 #' \preformatted{
 #' mf_map(x, var, type = "prop_choro", inches = 0.3, val_max, symbol = "circle",
-#'        pal = "Mint", alpha = 1, rev = FALSE, breaks = "quantile", nbreaks,
+#'        pal = "Mint", alpha = NULL, rev = FALSE, breaks = "quantile", nbreaks,
 #'        border = getOption("mapsf.fg"), lwd = 0.7, col_na = "white",
 #'        leg_pos = mf_get_leg_pos(x, 1), leg_title = var,
 #'        leg_title_cex = c(0.8, 0.8), leg_val_cex = c(0.6, 0.6),
@@ -127,7 +127,7 @@
 #' variable.
 #' \preformatted{
 #' mf_map(x, var, type = "prop_typo", inches = 0.3, val_max, symbol = "circle",
-#'        pal = "Dynamic", alpha = 1, rev = FALSE, val_order,
+#'        pal = "Dynamic", alpha = NULL, rev = FALSE, val_order,
 #'        border = getOption("mapsf.fg"), lwd = 0.7, lwd_max = 15,
 #'        col_na = "white",
 #'        leg_pos = mf_get_leg_pos(x, 1), leg_title = var,
@@ -144,7 +144,7 @@
 #' variable as symbols colored to reflect the classification of a second
 #' quantitative variable.
 #' \preformatted{
-#' mf_map(x, var, type = "symb_choro", pal = "Mint", alpha = 1, rev = FALSE,
+#' mf_map(x, var, type = "symb_choro", pal = "Mint", alpha = NULL, rev = FALSE,
 #'        breaks = "quantile", nbreaks, border = getOption("mapsf.fg"),
 #'        pch, cex = 1, lwd = 0.7, pch_na = 4, cex_na = 1, col_na = "white",
 #'        val_order,

R/mf_map_utils.R

@@ -5,19 +5,46 @@
 #' @param alpha alpha
 #' @noRd
 #' @importFrom grDevices hcl.pals hcl.colors
-get_the_pal <- function(pal, nbreaks, alpha = 1, rev = TRUE) {
+get_the_pal <- function(pal, nbreaks, alpha, rev = TRUE) {
   if (length(pal) == 1) {
     if (pal %in% hcl.pals()) {
-      cols <- hcl.colors(n = nbreaks, palette = pal, alpha = alpha, rev = rev)
+      cols <- hcl.colors(n = nbreaks, palette = pal, rev = rev)
     } else {
       cols <- rep(pal, nbreaks)
     }
   } else {
     cols <- pal[1:nbreaks]
   }
+  if (!is.null(alpha)) {
+    cols <- get_hex_pal(cols, alpha)
+  }
+
   return(cols)
 }
 
+get_hex_pal <- function(pal, alpha) {
+  pal <- grDevices::col2rgb(pal, alpha = FALSE)
+  ffun <- function(x) {
+    grDevices::rgb(pal[1, x],
+      pal[2, x],
+      pal[3, x],
+      maxColorValue = 255
+    )
+  }
+  paste0(sapply(seq_len(ncol(pal)), ffun), get_alpha(alpha))
+}
+
+get_alpha <- function(alpha) {
+  if (alpha < 0) {
+    alpha <- 0
+  }
+  if (alpha > 1) {
+    alpha <- 1
+  }
+  sprintf("%02X", as.integer(255.999 * alpha))
+}
+
+
 get_col_vec <- function(x, breaks, pal, jen = FALSE) {
   if (jen) {
     itv <- apply(array(apply(outer(x, breaks, ">"), 1, sum)), 1, max, 1)

R/mf_prop.R

@@ -4,6 +4,7 @@
 #' 'x',
 #' 'var',
 #' 'col',
+#' 'alpha',
 #' 'border',
 #' 'lwd',
 #' 'add' ,
@@ -48,6 +49,7 @@ mf_prop <- function(x,
                     lwd_max = 20,
                     symbol = "circle",
                     col = "tomato4",
+                    alpha = NULL,
                     border = getOption("mapsf.fg"),
                     lwd = .7,
                     leg_pos = mf_get_leg_pos(x),
@@ -67,6 +69,10 @@ mf_prop <- function(x,
   op <- par(mar = getOption("mapsf.mar"), no.readonly = TRUE)
   on.exit(par(op))
 
+  if (!is.null(alpha)) {
+    col <- get_hex_pal(col, alpha)
+  }
+
   xtype <- get_geom_type(x)
   # linestring special case
   if (xtype == "LINE") {

R/mf_prop_choro.R

@@ -68,7 +68,7 @@ mf_prop_choro <- function(x,
                           val_max,
                           symbol = "circle",
                           pal = "Mint",
-                          alpha = 1,
+                          alpha = NULL,
                           rev = FALSE,
                           breaks = "quantile",
                           nbreaks,

R/mf_prop_typo.R

@@ -54,7 +54,7 @@ mf_prop_typo <- function(x, var,
                          val_max,
                          symbol = "circle",
                          pal = "Dynamic",
-                         alpha = 1,
+                         alpha = NULL,
                          rev = FALSE,
                          val_order,
                          border = getOption("mapsf.fg"),

R/mf_raster.R

@@ -84,7 +84,7 @@ mf_raster <- function(x,
                       val_order,
                       pal,
                       expandBB = rep(0, 4),
-                      alpha = 1,
+                      alpha = NULL,
                       rev = FALSE,
                       leg_pos = "right",
                       leg_title = names(x),
@@ -102,6 +102,9 @@ mf_raster <- function(x,
                       leg_size = 1,
                       add = FALSE,
                       ...) {
+  op <- par(xpd = TRUE, no.readonly = TRUE)
+  on.exit(par(op))
+
   # test for terra
   if (!requireNamespace("terra", quietly = TRUE)) {
     stop(paste0(
@@ -126,6 +129,7 @@ mf_raster <- function(x,
   ops$axes <- FALSE
   ops$box <- FALSE
   ops$mar <- NA
+  ops$alpha <- alpha
 
   # Multiband Raster
   if (terra::nlyr(x) >= 2) {
@@ -152,8 +156,7 @@ mf_raster <- function(x,
 
     if (ops$type == "interval") {
       mf_raster_interval(
-        ops, ops_leg, pal, breaks, nbreaks, alpha, rev, add,
-        expandBB
+        ops, ops_leg, pal, breaks, nbreaks, alpha, rev, add, expandBB
       )
     }