gnoblet/visualizeR
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'gen-dev' into 16-add-options-to-decrease-space-between-bars-in-bar

Browse source
This commit is contained in:
Guillaume NOBLET 2023-08-06 16:37:28 +03:00 • committed by GitHub
commit 897d0bd886
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 592 additions and 126 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
R/donut.R
View file

@ -30,7 +30,10 @@ donut <- function(df,
arrange = TRUE,
hole_size = 3,
add_text = TRUE,
add_text_threshold_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(

394
R/internals.R
View file

@ -33,8 +33,7 @@ abort_bad_argument <- function(arg, must, not = 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 = ", "
)
)
)
)
@ -65,8 +65,7 @@ if_not_in_stop <- function(.tbl, cols, df, 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 = ", "
)
)
)
)
@ -93,3 +93,385 @@ if_vec_not_in_stop <- function(vec, cols, vec_name, arg = NULL){
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

203
R/map.R
View file

@ -1,47 +1,38 @@
#' Wrapper around `tmap::tm_polygons()` with sane defaults for plotting indicator values
#' Wrapper around `ggplot2::geom_sf()` with sane defaults for plotting choropleth
#'
#' @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 color_na Fill color for missing data.
#' @param text_na Legend text for missing data.
#' @param style Method to process the color scale for continuous numerical variables. See `classInt::classIntervals()` for details.
#' @param intervals Boolean. TRUE, let's make classes. FALSE, let's use a gradient.
#' @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 border_alpha Transparency of the border.
#' @param border_col Color of the border.
#' @param lwd Linewidth of the border.
#' @param ... Other arguments to pass to `tmap::tm_polygons()`.
#' @param legend_positin Legend position.
#' @param drop Boolean. Drop missing data?
#' @param text_na Legend text for missing data.
#' @param color_na Fill color for missing data.
#'
#' @return A ggplot base choropleth.
#'
#' @return A tmap layer.
#' @export
#'
add_indicator_layer <- function(
poly,
add_indicator_layer <- function(poly,
col,
buffer = NULL,
n = 5,
initiative = "reach",
palette = "red_5",
style = "pretty",
palette = pal_reach("red_5"),
as_count = TRUE,
color_na = cols_reach("white"),
text_na = "Missing data",
intervals = TRUE,
font_family = "segoeui",
legend_title = "Proportion (%)",
legend_text_separator = " - ",
border_alpha = 1,
border_col = cols_reach("lt_grey_1"),
lwd = 1,
...){
legend_position = c(0, 0.95),
drop = FALSE,
text_na = "Missing data",
color_na = cols_reach("white")){
#------ 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(
poly,
bbox = buffer
) +
tmap::tm_polygons(
col = col_name,
n = n,
style = style,
palette = palette,
as.count = as_count,
colorNA = color_na,
textNA = text_na,
title = legend_title,
legend.format = list(text.separator = legend_text_separator),
borderl.col = border_col,
border.alpha = border_alpha,
lwd = lwd,
...
legend_labels <- c(levels(poly[[col_class_name]]), text_na)
discrete <- TRUE
layer <- ggplot2::ggplot() +
ggplot2::geom_sf(data = poly, ggplot2::aes(fill = !!rlang::sym(col_class_name)), color = "transparent") +
scale_fill(initiative = initiative, palette = palette, discrete = discrete, reverse_guide = FALSE, name = legend_title, labels = legend_labels, drop = drop, na.value = color_na)
} else {
discrete <- FALSE
layer <- ggplot2::ggplot() +
ggplot2::geom_sf(data = poly, ggplot2::aes(fill = !!rlang::sym(col_name)), color = "transparent") +
scale_fill(initiative = initiative, palette = palette, discrete = discrete, reverse_guide = FALSE, name = legend_title, na.value = color_na)
}
#------ 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
rlang::check_installed("tmap", reason = "Package \"tmap\" needed for `add_admin_boundaries()` to work. Please install it.")
if(is.null(map)) map <- ggplot2::ggplot()
#------ Check that the length of vectors is identical between arguments
@ -120,41 +123,39 @@ 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) +
tmap::tm_lines(lwd = lwds[[1]], col = colors[[1]], ...)
layers <- map + ggplot2::geom_sf(data = lines[[1]], ggplot2::aes(color = .data[["label"]], linewidth = .data[["label"]]))
if (length(lines) == 1) {
layers <- layers + legend_lines
return(layers)
} else {
if (length(lines) > 1){
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 +
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)
layers <- layers + legend_lines
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,
point,
text,
size = 0.5,
fontface = "bold",
fontfamily = "Leelawadee",
shadow = TRUE,
auto_placement = FALSE,
remove_overlap = FALSE,
...){
halo_radius = 0.15,
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.")
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,
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,
fontfamily = fontfamily,
shadow = shadow,
auto.placement = auto_placement,
remove.overlap = remove_overlap,
...)
family = fontfamily,
bg.r = halo_radius,
bg.color = halo_color)
return(layer)

79
R/treemap.R Normal file
View file

@ -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)
}

3
README.Rmd
View file

@ -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))
```