Merge pull request #23 from gnoblet/16-add-options-to-decrease-space-between-bars-in-bar

Tries and errors for backup

R/bar.R

@@ -16,13 +16,15 @@
 #' @param subtitle Plot subtitle. Default to NULL.
 #' @param caption Plot caption. Default to NULL.
 #' @param add_text TRUE or FALSE. Add the value as text.
+#' @param add_text_threshold_display Minimum value to add the text label.
+#' @param add_text_color Text color.
 #' @param add_text_suffix If percent is FALSE, should we add a suffix to the text label?
 #' @param theme Whatever theme. Default to theme_reach().
 #'
 #' @return A bar chart
 #'
 #' @export
-bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL, position = "dodge", alpha = 1,  x_title = NULL, y_title = NULL, group_title = NULL, title = NULL, subtitle = NULL, caption = NULL, add_text = FALSE, add_text_suffix = "", theme = theme_reach()){
+bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL, position = "dodge", alpha = 1,  x_title = NULL, y_title = NULL, group_title = NULL, title = NULL, subtitle = NULL, caption = NULL, width = 0.9, add_text = FALSE, add_text_threshold_display = 5, add_text_color = "white", add_text_suffix = "", theme = theme_reach()){
 
   # To do :
   # - automate bar width and text size, or at least give the flexibility and still center text
@@ -51,8 +53,8 @@ bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL
     fill = group_title
   )
 
-  width <- 0.5
+  width <- width
-  dodge_width <- 0.5
+  dodge_width <- width
 
   # Should the graph use position_fill?
   if (position == "stack"){
@@ -108,27 +110,32 @@ bar <- function(df, x, y, group = NULL, flip = TRUE, percent = TRUE, wrap = NULL
 
   # Add text labels
   if (add_text) {
+
+    df <- dplyr::mutate(df, "y_threshold" = ifelse({{ y }} >= add_text_threshold_display, {{ y }}, NA ))
+
     if (percent) {
       g <- g + ggplot2::geom_text(
+        data = df,
         ggplot2::aes(
           label = scales::label_percent(
             accuracy     = 1,
             decimal.mark = ",",
-            suffix       = " %")({{ y }}),
+            suffix       = " %")(!!rlang::sym("y_threshold")),
           group = {{ group }}),
           hjust = hjust_flip,
           vjust = vjust_flip,
-        color = "white",
+        color = add_text_color,
         fontface = "bold",
         position = ggplot2::position_dodge(width = dodge_width))
     } else {
       g <- g + ggplot2::geom_text(
+        data = df,
         ggplot2::aes(
-          label = paste0(round({{ y }}), add_text_suffix),
+          label = paste0(round(!!rlang::sym("y_threshold")), add_text_suffix),
           group = {{ group }}),
         hjust = hjust_flip,
         vjust = vjust_flip,
-        color = "white",
+        color = add_text_color,
         fontface = "bold",
         position = ggplot2::position_dodge(width = dodge_width))
     }

R/donut.R

@@ -11,7 +11,7 @@
 #' @param arrange TRUE or FALSE. Arrange by highest percentage first.
 #' @param hole_size Hole size. Default to 3. If less than 2, back to a pie chart.
 #' @param add_text TRUE or FALSE. Add the value as text.
-#' @param add_text_treshold_display Minimum value to add the text label.
+#' @param add_text_threshold_display Minimum value to add the text label.
 #' @param add_text_color Text color.
 #' @param add_text_suffix If percent is FALSE, should we add a suffix to the text label?
 #' @param theme Whatever theme. Default to theme_reach().
@@ -30,7 +30,10 @@ donut <- function(df,
                   arrange = TRUE,
                   hole_size = 3,
                   add_text = TRUE,
-                  add_text_treshold_display = 5, add_text_color = "white", add_text_suffix = "", theme = theme_reach(legend_reverse = TRUE)){
+                  add_text_threshold_display = 5, 
+                  add_text_color = "white", 
+                  add_text_suffix = "", theme = theme_reach(legend_reverse = TRUE)){
+
 
   # Arrange by biggest prop first ?
   if (arrange) df <- dplyr::arrange(
@@ -60,7 +63,7 @@ donut <- function(df,
   # Add text labels
   if (add_text) {
 
-    df <- dplyr::mutate(df, y_treshold = ifelse({{ y }} >= add_text_treshold_display, {{ y }}, NA ))
+    df <- dplyr::mutate(df, y_treshold = ifelse({{ y }} >= add_text_threshold_display, {{ y }}, NA ))
 
     g <- g +
       ggplot2::geom_text(

R/internals.R

@@ -13,10 +13,10 @@ abort_bad_argument <- function(arg, must, not = NULL) {
   }
 
   rlang::abort("error_bad_argument",
-               message = msg,
+    message = msg,
-               arg = arg,
+    arg = arg,
-               must = must,
+    must = must,
-               not = not
+    not = not
   )
 }
 
@@ -30,11 +30,10 @@ abort_bad_argument <- function(arg, must, not = NULL) {
 #' @param arg Default to NULL.
 #'
 #' @return A stop statement
-if_not_in_stop <- function(.tbl, cols, df, arg = NULL){
+if_not_in_stop <- function(.tbl, cols, df, arg = NULL) {
   if (is.null(arg)) {
     msg <- glue::glue("The following column/s is/are missing in `{df}`:")
-  }
+  } else {
-  else {
     msg <- glue::glue("The following column/s from `{arg}` is/are missing in `{df}`:")
   }
   if (!all(cols %in% colnames(.tbl))) {
@@ -45,7 +44,8 @@ if_not_in_stop <- function(.tbl, cols, df, arg = NULL){
             msg,
             paste(
               subvec_not_in(cols, colnames(.tbl)),
-              collapse = ", ")
+              collapse = ", "
+            )
           )
       )
     )
@@ -62,11 +62,10 @@ if_not_in_stop <- function(.tbl, cols, df, arg = NULL){
 #' @param arg Default to NULL.
 #'
 #' @return A stop statement if some elements of vec are not in cols
-if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL){
+if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL) {
   if (is.null(arg)) {
     msg <- glue::glue("The following element/s is/are missing in `{vec_name}`:")
-  }
+  } else {
-  else {
     msg <- glue::glue("The following element/s from `{arg}` is/are missing in `{vec_name}`:")
   }
   if (!all(cols %in% vec)) {
@@ -77,7 +76,8 @@ if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL){
             msg,
             paste(
               subvec_not_in(cols, vec),
-              collapse = ", ")
+              collapse = ", "
+            )
           )
       )
     )
@@ -90,6 +90,388 @@ if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL){
 #' @param set A set-vector
 #'
 #' @return A subset of vector not in set
-subvec_not_in <- function(vector, set){
+subvec_not_in <- function(vector, set) {
   vector[!(vector %in% set)]
 }
+
+
+
+
+# Map helpers -------------------------------------------------------------
+
+
+# Thanks to https://github.com/r-tmap/tmap/blob/master/R/map_num2pal.R
+pretty_count <- function(x, n, ...) {
+  x <- na.omit(x)
+  if (!length(x)) {
+    return(x)
+  }
+
+  if (!is.integer(x)) x <- as.integer(x)
+
+
+  mn <- min(x)
+  mx <- max(x)
+
+  any0 <- any(x == 0)
+
+  if (mn < 0) {
+    n <- floor(n / 2)
+    pneg <- -rev(pretty_count(-x[x < 0], n = n, ...)) + 1L
+    pneg <- pneg[pneg != 0L]
+    x <- x[x > 0]
+    any0 <- TRUE
+  } else {
+    pneg <- integer()
+  }
+
+  if (any0) x <- x[x != 0L]
+
+  p <- pretty(x - 1L, n = n, ...) + 1L
+
+  p <- p[(p %% 1) == 0]
+  p <- p[p != 0L]
+
+  if (length(x) < 2) {
+    if (any0) {
+      return(c(0L, p))
+    } else {
+      return(p)
+    }
+  }
+
+
+  step <- p[2] - p[1]
+  if (p[length(p)] == mx) p <- c(p, mx + step)
+
+  if (any0) {
+    c(pneg, 0L, p)
+  } else {
+    c(pneg, p)
+  }
+}
+
+
+breaks <- pretty_count(indicator_admin1$opn_dfc, n = 5)
+style <- "fixed"
+#
+q <- num2breaks(indicator_admin1$opn_dfc, n = 5, style = style, breaks = breaks, interval.closure = "left", var = var, as.count = T, args = style.args)
+
+
+
+breaks_n <- function(breaks, as_count = TRUE)
+
+
+fancy_breaks(breaks, intervals = TRUE, as.count = TRUE)
+
+
+fancy_breaks <- function(vec, as.count = FALSE, intervals=FALSE, interval.closure="left", fun=NULL, scientific=FALSE, big.num.abbr = c("mln" = 6, "bln" = 9), prefix = "", suffix = "", text.separator="to", text.less.than=c("less", "than"), text.or.more=c("or", "more"), text.align="left", text.to.columns=FALSE, digits=NA, html.escape = TRUE, ...) {
+  args <- list(...)
+  n <- length(vec)
+
+  if (!is.null(fun)) {
+    x <- do.call(fun, list(vec))
+  } else if (all(is.infinite(vec))) {
+    x <- as.character(vec)
+  } else {
+    # calculate magnitude, needed to determine digits and big number abbreviations
+    vec_fin <- unique(vec[!is.infinite(vec)])
+    frm <- gsub(" ", "", sprintf("%20.10f", abs(vec_fin)))
+    mag <- max(nchar(frm)-11)
+
+    if (as.count) {
+      steps <- (vec[-1] - vec[-n])
+      vec <- c(vec, vec - 1L, vec + 1L) # needed for: {1, 2, ... 9}
+      digits <- 0
+    } else {
+      # get number of decimals (which is number of decimals in vec, which is reduced when mag is large)
+      ndec <- max(10 - nchar(frm) + nchar(sub("0+$","",frm)))
+      if (is.na(digits)) {
+        digits <- max(min(ndec, 4-mag), 0)
+
+        # add sign to frm
+        frm_sign <- unique(paste0(ifelse(vec_fin<0, "-", "+"), frm))
+
+        # test if number of digits is sufficient for unique labels
+        if (!scientific) {
+          while (anyDuplicated(substr(frm_sign, 1, nchar(frm_sign)-10 + digits)) && (digits < 10)) {
+            digits <- digits + 1
+          }
+        }
+
+      }
+    }
+
+    if (!scientific || as.count) {
+
+      # check whether big number abbrevations should be used
+      ext <- ""
+      if (!is.na(big.num.abbr[1])) {
+        big.num.abbr <- sort(big.num.abbr, decreasing = TRUE)
+        for (i in 1:length(big.num.abbr)) {
+          o <- unname(big.num.abbr[i])
+          if (mag>(o+2) || (mag > o && all(vec - floor(vec/(10^o))*(10^o) < 1))) {
+            vec <- vec / (10^o)
+            ext <- paste0(" ", names(big.num.abbr)[i])
+            break
+          }
+        }
+      }
+
+      # set default values
+      if (!("big.mark" %in% names(args))) args$big.mark <- ","
+      if (!("format" %in% names(args))) args$format <- "f"
+      if (!("preserve.width" %in% names(args))) args$preserve.width <- "none"
+      x <- paste(do.call("formatC", c(list(x=vec, digits=digits), args)), ext, sep="")
+      x <- paste0(prefix, x, suffix)
+
+
+    } else {
+      if (!("format" %in% names(args))) args$format <- "g"
+      x <- do.call("formatC", c(list(x=vec, digits=digits), args))
+    }
+
+    if (as.count) {
+      x1 <- x[1:(n-1)]
+      x2 <- x[(n+2):(2*n)]
+      x1p1 <- x[(2*n+1):(3*n-1)]
+    }
+    # x <- formatC(vec, format = "f", digits = 0)
+    # x1 <- x[-n]
+    # x2 <- formatC(vec[-1] - 1L, format = "f", digits = 0)
+    # xs <- (vec[-1] - vec[-n])
+    # x1p1 <- formatC(vec[-n] + 1L, format = "f", digits = 0)
+  }
+
+  if (intervals) {
+    if (scientific) {
+      if (as.count) {
+        # discrete
+        lbls <- paste("{", x1, "}", sep = "")
+        lbls[steps == 2] <- paste("{", x1[steps == 2], ", ", x2[steps == 2], "}", sep="")
+        lbls[steps > 2] <- paste("{", x1[steps > 2], ", ", x1p1[steps > 2], ", ..., ", x2[steps > 2], "}", sep="")
+      } else {
+        # continuous
+        if (interval.closure=="left") {
+          lbls <- paste("[", x[-n], ", ", x[-1], ")", sep="")
+          lbls[n-1] <- paste(substr(lbls[n-1], 1, nchar(lbls[n-1])-1), "]", sep="")
+        } else {
+          lbls <- paste("(", x[-n], ", ", x[-1], "]", sep="")
+          lbls[1] <- paste("[", substr(lbls[1], 2, nchar(lbls[1])), sep="")
+        }
+      }
+
+
+    } else {
+      if (as.count) {
+        lbls <- x1
+        lbls[steps>1] <- paste(x1[steps>1], x2[steps>1], sep = paste0(" ", text.separator, " "))
+        if (vec[n]==Inf) lbls[n-1] <- paste(x1[n-1], paste(text.or.more, collapse = " "), sep = " ")
+      } else {
+        x[vec==-Inf] <- ""
+
+        lbls <- paste(x[-n], x[-1], sep = paste0(" ", text.separator, " "))
+        if (vec[1]==-Inf) lbls[1] <- paste(paste(text.less.than, collapse = " "), x[2], sep = " ")
+        if (vec[n]==Inf) lbls[n-1] <- paste(x[n-1], paste(text.or.more, collapse = " "), sep = " ")
+      }
+
+      if (text.to.columns) {
+        #xtra <- as.numeric(!is.na(text.align) && text.align=="right")
+
+
+        nc1 <- nchar(paste(x[-n], " ", sep = "")) + 1
+        nc2 <- rep(nchar(paste(text.separator, " ", sep = "")), n-1)
+
+        lbls_breaks <- matrix(c(nc1, nc1+nc2), ncol=2)
+
+        if (vec[1]==-Inf) {
+          if (length(text.less.than)==1) {
+            lbls_breaks[1,] <- rep(nchar(paste(text.less.than[1], " ", sep = "")) + 1, 2)
+          } else {
+            lbls_breaks[1,] <- cumsum(c(nchar(paste(text.less.than[1], " ", sep = "")) + 1, nchar(text.less.than[2])+1))
+          }
+        }
+        if (vec[n]==Inf) {
+          if (length(text.or.more)==1) {
+            lbls_breaks[n-1,] <- rep(nchar(paste(x[n-1], " ", sep = "")) + 1, 2)
+          } else {
+            lbls_breaks[n-1,] <- cumsum(c(nchar(paste(x[n-1], " ", sep = "")) + 1, nchar(text.or.more[1])+1))
+          }
+
+        }
+        attr(lbls, "brks") <- lbls_breaks
+      }
+
+
+
+
+    }
+  }
+
+  y <- if (intervals) lbls else x
+  attr(y, "align") <- text.align
+  y
+}
+
+
+num2breaks <- function(x, n, style, breaks, approx=FALSE, interval.closure="left", var = NULL, as.count = FALSE, args = list()) {
+
+  tmapOptions = get("tmapOptions", envir = .TMAP_CACHE)
+  show.warnings <- tmapOptions$show.warnings
+
+  nobs <- sum(!is.na(x))
+  # create intervals and assign colors
+  if (style=="fixed") {
+    q <- list(var=x,
+              brks=breaks)
+    if (any(na.omit(x) < min(breaks)) && show.warnings) warning("Values have found that are less than the lowest break", call. = FALSE)
+    if (any(na.omit(x) > max(breaks)) && show.warnings) warning("Values have found that are higher than the highest break", call. = FALSE)
+    attr(q, "style") <- "fixed"
+    attr(q, "nobs") <- nobs
+    attr(q, "intervalClosure") <- interval.closure
+    class(q) <- "classIntervals"
+  } else {
+    if (nobs==0) {
+      if (!is.null(var)) {
+        stop("Numerical variable \"", var, "\" only contains missing values.", call.=FALSE)
+      } else {
+        stop("Numerical variable only contains missing values.", call.=FALSE)
+      }
+    }
+
+    nunique <- length(na.omit(unique(x)))
+
+
+    if (nunique == 1 && style!="pretty" && show.warnings) {
+      if (!is.null(var)) {
+        warning("Single unique value found for the variable \"", var, "\", so style set to \"pretty\"", call. = FALSE)
+      } else {
+        warning("Single unique value found, so style set to \"pretty\"", call. = FALSE)
+      }
+    }
+
+    tempx <- nunique <= n
+
+    if (tempx) {
+      x_orig <- x
+      if (length(na.omit(unique(x))) == 1) x <- pretty(x)
+      x <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)
+    }
+
+    q <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n, style= style, intervalClosure=interval.closure), args)))
+
+    if (tempx) q$var <- x_orig
+
+  }
+
+  if (approx && style != "fixed") {
+    if (n >= length(unique(x)) && style=="equal") {
+      # to prevent classIntervals to set style to "unique"
+      q <- list(var=x, brks=seq(min(x, na.rm=TRUE), max(x, na.rm=TRUE), length.out=n))
+      attr(q, "intervalClosure") <- interval.closure
+      class(q) <- "classIntervals"
+    } else {
+      brks <- q$brks
+
+      # to prevent ugly rounded breaks such as -.5, .5, ..., 100.5 for n=101
+      qm1 <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n-1, style= style, intervalClosure=interval.closure), args)))
+      brksm1 <- qm1$brks
+      qp1 <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n+1, style= style, intervalClosure=interval.closure), args)))
+      brksp1 <- qp1$brks
+      if (min(brksm1) > min(brks) && max(brksm1) < max(brks)) {
+        q <- qm1
+      } else if (min(brksp1) > min(brks) && max(brksp1) < max(brks)) {
+        q <- qp1
+      }
+    }
+  }
+  q
+}
+
+
+cont_breaks <- function(breaks, n=101) {
+  x <- round(seq(1, 101, length.out=length(breaks)))
+
+
+  unlist(lapply(1L:(length(breaks)-1L), function(i) {
+    y <- seq(breaks[i], breaks[i+1], length.out=x[i+1]-x[i]+1)
+    if (i!=1) y[-1] else y
+  }), use.names = FALSE)
+}
+
+
+num2breaks <- function(x, n, style = "fixed", breaks, approx = FALSE, interval.closure = "left", var = NULL, as.count = FALSE, args = list()) {
+
+  show.warnings <- TRUE
+
+  nobs <- sum(!is.na(x))
+  # create intervals and assign colors
+  if (style == "fixed") {
+    q <- list(
+      var = x,
+      brks = breaks
+    )
+    if (any(na.omit(x) < min(breaks)) && show.warnings) warning("Values have found that are less than the lowest break", call. = FALSE)
+    if (any(na.omit(x) > max(breaks)) && show.warnings) warning("Values have found that are higher than the highest break", call. = FALSE)
+    attr(q, "style") <- "fixed"
+    attr(q, "nobs") <- nobs
+    attr(q, "intervalClosure") <- interval.closure
+    class(q) <- "classIntervals"
+  } else {
+    if (nobs == 0) {
+      if (!is.null(var)) {
+        stop("Numerical variable \"", var, "\" only contains missing values.", call. = FALSE)
+      } else {
+        stop("Numerical variable only contains missing values.", call. = FALSE)
+      }
+    }
+
+    nunique <- length(na.omit(unique(x)))
+
+
+    if (nunique == 1 && style != "pretty" && show.warnings) {
+      if (!is.null(var)) {
+        warning("Single unique value found for the variable \"", var, "\", so style set to \"pretty\"", call. = FALSE)
+      } else {
+        warning("Single unique value found, so style set to \"pretty\"", call. = FALSE)
+      }
+    }
+
+    tempx <- nunique <= n
+
+    if (tempx) {
+      x_orig <- x
+      if (length(na.omit(unique(x))) == 1) x <- pretty(x)
+      x <- seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n + 1)
+    }
+
+    q <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n, style = style, intervalClosure = interval.closure), args)))
+
+    if (tempx) q$var <- x_orig
+  }
+
+  if (approx && style != "fixed") {
+    if (n >= length(unique(x)) && style == "equal") {
+      # to prevent classIntervals to set style to "unique"
+      q <- list(var = x, brks = seq(min(x, na.rm = TRUE), max(x, na.rm = TRUE), length.out = n))
+      attr(q, "intervalClosure") <- interval.closure
+      class(q) <- "classIntervals"
+    } else {
+      brks <- q$brks
+
+      # to prevent ugly rounded breaks such as -.5, .5, ..., 100.5 for n=101
+      qm1 <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n - 1, style = style, intervalClosure = interval.closure), args)))
+      brksm1 <- qm1$brks
+      qp1 <- suppressWarnings(do.call(classInt::classIntervals, c(list(x, n + 1, style = style, intervalClosure = interval.closure), args)))
+      brksp1 <- qp1$brks
+      if (min(brksm1) > min(brks) && max(brksm1) < max(brks)) {
+        q <- qm1
+      } else if (min(brksp1) > min(brks) && max(brksp1) < max(brks)) {
+        q <- qp1
+      }
+    }
+  }
+  q
+}
+
+breaks[length(breaks)] <- breaks[length(breaks)] + 1L

R/map.R

@@ -1,47 +1,38 @@
-
+#' Wrapper around `ggplot2::geom_sf()` with sane defaults for plotting choropleth
-
-#' Wrapper around `tmap::tm_polygons()` with sane defaults for plotting indicator values
 #'
 #' @param poly Multipolygon shape defined by sf package.
 #' @param col Numeric attribute to map.
-#' @param buffer A buffer, either one value or a vector of 4 values (left, bottom, right, top).
 #' @param n The desire number of classes.
-#' @param style Method to process the color scale for continuous numerical variables. See `classInt::classIntervals()` for details.
+#' @param initiative One of "reach", "agora", or "default"
 #' @param palette Vector of fill colors as hexadecimal values. For REACH color palettes, it is possible to use `pal_reach()`. For now,'palette' must be changed manually, accordingly to the number of drawn classes.
-#' @param as_count Boolean. When col is a numeric variable, should it be processed as a count variable? For instance, 0, 1-10, 11-20.
+#' @param style Method to process the color scale for continuous numerical variables. See `classInt::classIntervals()` for details.
-#' @param color_na Fill color for missing data.
+#' @param intervals Boolean. TRUE, let's make classes. FALSE, let's use a gradient.
-#' @param text_na Legend text for missing data.
+#' @param font_family Font family.
 #' @param legend_title Legend title.
-#' @param legend_text_separator Text separator for classes. E.g. " to " will give 0, 1 to 10, 11 to 20.
+#' @param legend_positin Legend position.
-#' @param border_alpha Transparency of the border.
+#' @param drop Boolean. Drop missing data?
-#' @param border_col Color of the border.
+#' @param text_na Legend text for missing data.
-#' @param lwd Linewidth of the border.
+#' @param color_na Fill color for missing data.
-#' @param ... Other arguments to pass to `tmap::tm_polygons()`.
+#'
+#' @return A ggplot base choropleth.
 #'
-#' @return A tmap layer.
 #' @export
-#'
+add_indicator_layer <- function(poly,
-add_indicator_layer <- function(
+                                col,
-    poly,
+                                n = 5,
-    col,
+                                initiative = "reach",
-    buffer = NULL,
+                                palette = "red_5",
-    n = 5,
+                                style = "pretty",
-    style = "pretty",
+                                intervals = TRUE,
-    palette = pal_reach("red_5"),
+                                font_family = "segoeui",
-    as_count = TRUE,
+                                legend_title = "Proportion (%)",
-    color_na = cols_reach("white"),
+                                legend_position = c(0, 0.95),
-    text_na = "Missing data",
+                                drop = FALSE,
-    legend_title = "Proportion (%)",
+                                text_na = "Missing data",
-    legend_text_separator = " - ",
+                                color_na = cols_reach("white")){
-    border_alpha = 1,
-    border_col = cols_reach("lt_grey_1"),
-    lwd = 1,
-    ...){
 
   #------ Checks and make valid
 
-  rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_indicator_layer()` to work. Please install it.")
-
   poly <- sf::st_make_valid(poly)
 
   #------ Other checks
@@ -54,29 +45,43 @@ add_indicator_layer <- function(
 
   #------ Prepare data
 
-  if(!is.null(buffer)){ buffer <- buffer_bbox(poly, buffer) } else { buffer <- NULL }
+  if (intervals) {
 
+     classes <- classInt::classIntervals(poly[[col_name]], n = n, style = style)
+    col_class_name <- paste0(col_name, "_class")
 
-  #------ Polygon layer
+    poly <- poly |>
+      dplyr::mutate("{col_class_name}" := cut({{ col }}, classes$brks, include.lowest = TRUE))
 
-  layer <- tmap::tm_shape(
+    legend_labels <- c(levels(poly[[col_class_name]]), text_na)
-    poly,
+
-    bbox = buffer
+    discrete <- TRUE
-  ) +
+
-    tmap::tm_polygons(
+    layer <- ggplot2::ggplot() +
-      col = col_name,
+      ggplot2::geom_sf(data = poly, ggplot2::aes(fill = !!rlang::sym(col_class_name)), color = "transparent") +
-      n = n,
+      scale_fill(initiative = initiative, palette = palette, discrete = discrete, reverse_guide = FALSE, name = legend_title, labels = legend_labels, drop = drop, na.value = color_na)
-      style = style,
+
-      palette = palette,
+  } else {
-      as.count = as_count,
+
-      colorNA = color_na,
+    discrete <- FALSE
-      textNA = text_na,
+
-      title = legend_title,
+    layer <- ggplot2::ggplot() +
-      legend.format = list(text.separator = legend_text_separator),
+      ggplot2::geom_sf(data = poly, ggplot2::aes(fill = !!rlang::sym(col_name)), color = "transparent") +
-      borderl.col = border_col,
+      scale_fill(initiative = initiative, palette = palette, discrete = discrete, reverse_guide = FALSE, name = legend_title, na.value = color_na)
-      border.alpha = border_alpha,
+
-      lwd = lwd,
+  }
-      ...
+
+  #------ Make map layer
+
+ layer <- layer +
+    ggplot2::theme_void() +
+    ggplot2::theme(
+      # legend.justification defines the edge of the legend that the legend.position coordinates refer to
+      legend.justification = c(0, 1),
+      # Set the legend flush with the left side of the plot, and just slightly below the top of the plot
+      legend.position = legend_position,
+      # Set fontfamily
+      text = ggplot2::element_text(family = font_family)
     )
 
   return(layer)
@@ -88,6 +93,7 @@ add_indicator_layer <- function(
 
 #' Add admin boundaries (lines) and the legend
 #'
+#' @param map Is there a previous map layer? Default to NULL.
 #' @param lines List of multiline shape defined by sf package.
 #' @param colors Vector of hexadecimal codes. Same order as lines.
 #' @param labels Vector of labels in the legend. Same order as lines.
@@ -99,13 +105,10 @@ add_indicator_layer <- function(
 #' @return A tmap layer.
 #' @export
 #'
-add_admin_boundaries <- function(lines, colors, labels, lwds, title = "", buffer = NULL, ...){
+add_admin_boundaries <- function(map = NULL, lines, colors, labels, lwds, legend_title = ""){
 
 
-  #------ Package check
+  if(is.null(map)) map <- ggplot2::ggplot()
-
-  rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_admin_boundaries()` to work. Please install it.")
-
 
   #------ Check that the length of vectors is identical between arguments
 
@@ -120,40 +123,38 @@ add_admin_boundaries <- function(lines, colors, labels, lwds, title = "", buffer
   lines <- lapply(lines, \(x) sf::st_make_valid(x))
 
 
-  #------ Prepare legend
-  legend_lines <- tmap::tm_add_legend("line",
-                                      title = title,
-                                      col = colors,
-                                      lwd = lwds,
-                                      labels = labels)
-
-
   #------ Let's go with all line shapes
 
-  if(!is.null(buffer)){ buffer <- buffer_bbox(lines[[1]], buffer) } else { buffer <- NULL }
+  for (i in 1:length(lines)) {
+    lines[[i]] <- lines[[i]] |>
+      dplyr::mutate(color = colors[[i]],
+                    label = labels[[i]],
+                    lwd = lwds[[i]])
+  }
 
 
-  layers <- tmap::tm_shape(lines[[1]], bbox = buffer) +
+  layers <- map + ggplot2::geom_sf(data = lines[[1]], ggplot2::aes(color = .data[["label"]], linewidth = .data[["label"]]))
-    tmap::tm_lines(lwd = lwds[[1]], col = colors[[1]], ...)
 
-  if (length(lines) == 1) {
+  if (length(lines) > 1){
-
-    layers <- layers + legend_lines
-
-    return(layers)
-
-  } else {
 
     for(i in 2:length(lines)){
 
-      layers <- layers + tmap::tm_shape(shp = lines[[i]]) + tmap::tm_lines(lwd = lwds[[i]], col = colors[[i]], ...)
+      data <- lines[[i]]
+      color <- labels[[i]]
+      size <- labels[[i]]
+
+      layers <- layers + ggplot2::geom_sf(data = data, ggplot2::aes(color = .data[["label"]], linewidth = .data[["label"]]))
+
     }
-
-    layers <- layers + legend_lines
-
-    return(layers)
-
   }
+  #
+  layers <- layers +
+    ggplot2::scale_color_manual(name = legend_title, values = setNames(colors, labels), breaks = labels) +
+    ggplot2::scale_discrete_manual("linewidth", name = legend_title, values = setNames(lwds, labels), breaks = labels)
+
+
+  return(layers)
+
 }
 
 
@@ -225,39 +226,39 @@ add_layout <- function(
 #' @return A tmap layer.
 #' @export
 #'
-add_admin_labels <- function(point,
+add_text_labels <- function(map = NULL,
-                             text,
+                            point,
-                             size = 0.5,
+                            text,
-                             fontface = "bold",
+                            size = 0.5,
-                             fontfamily = "Leelawadee",
+                            fontface = "bold",
-                             shadow = TRUE,
+                            fontfamily = "Leelawadee",
-                             auto_placement = FALSE,
+                            halo_radius = 0.15,
-                             remove_overlap = FALSE,
+                            halo_color = "white",
-                             ...){
+                            angle = 0,
+                            force = 0,
+                            force_pull = 0){
 
+  if(is.null(map)) map <- ggplot()
 
-  #------ Restrictive sf checks (might not be necessary depending on the desired behaviour)
+  col_name <- rlang::as_name(rlang::enquo(text))
 
-  rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_indicator_layer()` to work. Please install it.")
+  layer <- map +
+    ggspatial::geom_spatial_text_repel(
+      data = point,
+      ggplot2::aes(
+        x = X,
+        y = Y,
+        label = !!rlang::sym(col_name)),
+      crs = sf::st_crs(point)$input,
+      force = force,
+      force_pull = force_pull,
+      size = 3,
+      angle = angle,
+      fontface = fontface,
+      family = fontfamily,
+      bg.r = halo_radius,
+      bg.color = halo_color)
 
-  point <- sf::st_make_valid(point)
-
-  #------ Other checks
-
-  text_name <- rlang::as_name(rlang::enquo(text))
-  if_not_in_stop(point, text_name, "point", "text")
-
-  #------ Point text layer
-
-  layer <- tmap::tm_shape(point) +
-    tmap::tm_text(text = text_name,
-                  size = size,
-                  fontface = fontface,
-                  fontfamily = fontfamily,
-                  shadow = shadow,
-                  auto.placement = auto_placement,
-                  remove.overlap = remove_overlap,
-                  ...)
 
   return(layer)
 

R/treemap.R

@@ -0,0 +1,79 @@
+#' @title Simple treemap chart
+#'
+#' @param df A data frame.
+#' @param x A character column or coercible as a character column. Will give the treemap's fill color and text.
+#' @param y A numeric column of proportions (0 to 100 or 0 to 1).
+#' @param tile_border_size Size of the inter-tile space (default to 2).
+#' @param tile_start The corner in which to start placing the tiles. One of 'bottomleft' (the default), 'topleft', 'topright' or 'bottomright'. See `treemapify::geom_treemap()`.
+#' @param tile_corner_radius The corner radius (defaults to `grid::unit(0, "pt")`). See `treemapify::geom_treemap()`.
+#' @param tile_text Boolean. If true, add a text label to each tile (the default). If false, use a side legend only.
+#' @param tile_text_size A size (defaults to 20).
+#' @param tile_text_color A color (defaults to "white").
+#' @param tile_text_threshold_display Minimum value to add the text label to the tile (defaults to 4).
+#' @param tile_text_place Where inside the box to place the text. Default is 'bottom'; other options are 'topleft', 'top', 'topright', etc. See `treemapify::geom_treemap()`.
+#' @param x_title The x scale title. Default to NULL.
+#' @param title Plot title. Default to NULL.
+#' @param subtitle Plot subtitle. Default to NULL.
+#' @param caption Plot caption. Default to NULL.
+#' @param theme Whatever theme. Default to theme_reach().
+#'
+#' @return A waffle chart
+#'
+#' @export
+treemap <- function(df,
+                   x,
+                   y,
+                   tile_border_size = 2,
+                   tile_start = "topleft",
+                   tile_corner_radius = grid::unit(0, "pt"),
+                   tile_text = TRUE,
+                   tile_text_size = 20,
+                   tile_text_color = "white",
+                   tile_text_threshold_display = 4,
+                   tile_text_place = "middle",
+                   x_title = NULL,
+                   title = NULL,
+                   subtitle = NULL,
+                   caption = NULL,
+                   theme = theme_reach(reverse = TRUE, panel_border = FALSE, axis_x = FALSE, axis_y = FALSE)
+                   ){
+
+  # Make plot
+  g <- ggplot2::ggplot(
+    data = df,
+    ggplot2::aes(area = {{ y }}, fill = {{ x }}, label = {{ x }}))
+
+  # Add tile
+  g <- g + treemapify::geom_treemap(
+    size = tile_border_size,
+    radius = tile_corner_radius,
+    color = "white",
+    start = tile_start
+    )
+
+  # Add title, subtitle, caption, x_title, y_title
+  g <- g + ggplot2::labs(
+    title = title,
+    subtitle = subtitle,
+    caption = caption,
+    fill = x_title,
+  )
+
+  # Theme
+  g <- g + theme
+
+  # If tile_text, show text on tiles and remove legend
+  if (tile_text) {
+    g <- g + treemapify::geom_treemap_text(
+      place = tile_text_place,
+      start = tile_start,
+      min.size = tile_text_threshold_display,
+      color = tile_text_color,
+      size = tile_text_size
+    ) +
+      ggplot2::theme(legend.position = "none")
+  }
+
+  return(g)
+
+}

README.Rmd

@@ -168,7 +168,8 @@ donut(df,
       add_text_treshold_display = 5,
       x_title = "Displacement status", 
       title = "% of HHs by displacement status", 
-      theme = theme_reach(legend_reverse = TRUE))
+      theme = theme_reach(legend_reverse = TRUE,
+                          axis_x = FALSE))
 ```