355 lines
11 KiB
R
355 lines
11 KiB
R
#' 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 n The desire number of classes.
|
|
#' @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 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_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.
|
|
#'
|
|
#' @export
|
|
add_indicator_layer <- function(poly,
|
|
col,
|
|
n = 5,
|
|
initiative = "reach",
|
|
palette = "red_5",
|
|
style = "pretty",
|
|
intervals = TRUE,
|
|
font_family = "segoeui",
|
|
legend_title = "Proportion (%)",
|
|
legend_position = c(0, 0.95),
|
|
drop = FALSE,
|
|
text_na = "Missing data",
|
|
color_na = cols_reach("white")){
|
|
|
|
#------ Checks and make valid
|
|
|
|
poly <- sf::st_make_valid(poly)
|
|
|
|
#------ Other checks
|
|
|
|
col_name <- rlang::as_name(rlang::enquo(col))
|
|
if_not_in_stop(poly, col_name, "poly", "col")
|
|
|
|
if (!is.numeric(poly[[col_name]])) rlang::abort(glue::glue("{col_name} is not numeric."))
|
|
|
|
|
|
#------ Prepare data
|
|
|
|
if (intervals) {
|
|
|
|
classes <- classInt::classIntervals(poly[[col_name]], n = n, style = style)
|
|
col_class_name <- paste0(col_name, "_class")
|
|
|
|
poly <- poly |>
|
|
dplyr::mutate("{col_class_name}" := cut({{ col }}, classes$brks, include.lowest = TRUE))
|
|
|
|
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)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' 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.
|
|
#' @param lwds Vector of line widths. Same order as lines.
|
|
#' @param title Legend title.
|
|
#' @param buffer A buffer, either one value or a vector of 4 values (left, bottom, right, top).
|
|
#' @param ... Other arguments to pass to each shape in `tmap::tm_lines()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_admin_boundaries <- function(map = NULL, lines, colors, labels, lwds, legend_title = ""){
|
|
|
|
|
|
if(is.null(map)) map <- ggplot2::ggplot()
|
|
|
|
#------ Check that the length of vectors is identical between arguments
|
|
|
|
if(!inherits(lines, "list")) rlang::abort("Please provide a list for lines.")
|
|
|
|
ll <- list(lines, colors, labels, lwds)
|
|
if (!all(sapply(ll,length) == length(ll[[1]]))) rlang::abort("lines, colors, labels, lwds do not all have the same length.")
|
|
|
|
|
|
#------ Make valid
|
|
|
|
lines <- lapply(lines, \(x) sf::st_make_valid(x))
|
|
|
|
|
|
#------ Let's go with all line shapes
|
|
|
|
for (i in 1:length(lines)) {
|
|
lines[[i]] <- lines[[i]] |>
|
|
dplyr::mutate(color = colors[[i]],
|
|
label = labels[[i]],
|
|
lwd = lwds[[i]])
|
|
}
|
|
|
|
|
|
layers <- map + ggplot2::geom_sf(data = lines[[1]], ggplot2::aes(color = .data[["label"]], linewidth = .data[["label"]]))
|
|
|
|
if (length(lines) > 1){
|
|
|
|
for(i in 2:length(lines)){
|
|
|
|
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)
|
|
|
|
|
|
return(layers)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' Basic defaults based on `tmap::tm_layout()`
|
|
#'
|
|
#' @param title Map title.
|
|
#' @param legend_position Legend position. Not above the map is a good start.
|
|
#' @param frame Boolean. Legend frame?
|
|
#' @param legend_frame Legend frame color.
|
|
#' @param legend_text_size Legend text size in 'pt'.
|
|
#' @param legend_title_size Legend title size in 'pt'.
|
|
#' @param title_size Title text size in 'pt'.
|
|
#' @param title_fontface Title fontface. Bold if you wanna exemplify a lot what it is about.
|
|
#' @param title_color Title font color.
|
|
#' @param fontfamily Overall fontfamily. Leelawadee is your precious.
|
|
#' @param ... Other arguments to pass to `tmap::tm_layout()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_layout <- function(
|
|
title = NULL,
|
|
legend_position = c(0.02, 0.5),
|
|
frame = FALSE,
|
|
legend_frame = cols_reach("main_grey"),
|
|
legend_text_size = 0.6,
|
|
legend_title_size = 0.8,
|
|
title_size = 0.9,
|
|
title_fontface = "bold",
|
|
title_color = cols_reach("main_grey"),
|
|
# check.and.fix = TRUE,
|
|
fontfamily = "Leelawadee",
|
|
...){
|
|
|
|
layout <- tmap::tm_layout(
|
|
title = title,
|
|
legend.position = legend_position,
|
|
legend.frame = legend_frame,
|
|
frame = FALSE,
|
|
legend.text.size = legend_text_size,
|
|
legend.title.size = legend_title_size,
|
|
title.size = title_size,
|
|
title.fontface = title_fontface,
|
|
title.color = title_color,
|
|
fontfamily = fontfamily,
|
|
...)
|
|
|
|
return(layout)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' Wrapper around `tmap::tm_text()` with sane defaults for plotting admin labels.
|
|
#'
|
|
#' @param point Multipoint shape defined by sf package.
|
|
#' @param text Text labels column.
|
|
#' @param size Relative size of the text labels.
|
|
#' @param fontface Fontface.
|
|
#' @param fontfamily Fontfamily. Leelawadee is your precious.
|
|
#' @param shadow Boolean. Add a shadow around text labels. Issue opened on Github to request.
|
|
#' @param auto_placement Logical that determines whether the labels are placed automatically.
|
|
#' @param remove_overlap Logical that determines whether the overlapping labels are removed.
|
|
#' @param ... Other arguments to pass to `tmap::tm_text()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_text_labels <- function(map = NULL,
|
|
point,
|
|
text,
|
|
size = 0.5,
|
|
fontface = "bold",
|
|
fontfamily = "Leelawadee",
|
|
halo_radius = 0.15,
|
|
halo_color = "white",
|
|
angle = 0,
|
|
force = 0,
|
|
force_pull = 0){
|
|
|
|
if(is.null(map)) map <- ggplot()
|
|
|
|
col_name <- rlang::as_name(rlang::enquo(text))
|
|
|
|
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)
|
|
|
|
|
|
return(layer)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' Add a compass
|
|
#'
|
|
#' @param text_size Relative font size.
|
|
#' @param position Position of the compass. Vector of two values, specifying the x and y coordinates.
|
|
#' @param color_dark Color of the dark parts of the compass.
|
|
#' @param text_color color of the text.
|
|
#' @param type Compass type, one of: "arrow", "4star", "8star", "radar", "rose".
|
|
#' @param ... Other arguments to pass to `tmap::tm_compass()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_compass <- function(text_size = 0.6,
|
|
position = c("right", 0.8),
|
|
color_dark = cols_reach("black"),
|
|
text_color = cols_reach("black"),
|
|
type = "4star",
|
|
...){
|
|
|
|
compass <- tmap::tm_compass(
|
|
text.size = text_size,
|
|
position = position,
|
|
color.dark = color_dark,
|
|
type = type,
|
|
text.color = text_color
|
|
)
|
|
|
|
return(compass)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' Add a scale bar
|
|
#'
|
|
#' @param text_size Relative font size.
|
|
#' @param position Position of the compass. Vector of two values, specifying the x and y coordinates.
|
|
#' @param color_dark Color of the dark parts of the compass.
|
|
#' @param breaks Breaks of the scale bar. If not specified, breaks will be automatically be chosen given the prefered width of the scale bar. Example: c(0, 50, 100).
|
|
#' @param ... Other arguments to pass to `tmap::tm_compass()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_scale_bar <- function(text_size = 0.6,
|
|
position = c("left", 0.01),
|
|
color_dark = cols_reach("black"),
|
|
breaks = c(0, 50, 100),
|
|
...){
|
|
|
|
scale_bar <- tmap::tm_scale_bar(
|
|
text.size = text_size,
|
|
position = position,
|
|
color.dark = color_dark,
|
|
breaks = breaks,
|
|
...
|
|
)
|
|
|
|
return(scale_bar)
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
#' Do you want to credit someone or some institution?
|
|
#'
|
|
#' @param text Text.
|
|
#' @param size Relative text size.
|
|
#' @param bg_color Background color.
|
|
#' @param position Position. Vector of two coordinates. Usually somewhere down.
|
|
#' @param ... Other arguments to pass to `tmap::tm_credits()`.
|
|
#'
|
|
#' @return A tmap layer.
|
|
#' @export
|
|
#'
|
|
add_credits <- function(text, size = 0.4, bg_color = NA, position = c(0.75, 0.02), ...){
|
|
|
|
tmap::tm_credits(text,
|
|
size = size,
|
|
bg.color = bg_color,
|
|
position = position,
|
|
...)
|
|
}
|
|
|