From f26fdc78957a14dc456b8ab7fa4f50ddf904754f Mon Sep 17 00:00:00 2001 From: mtennekes Date: Tue, 19 Mar 2024 13:05:28 +0100 Subject: [PATCH] tm_text improved (just argument added) --- R/misc_other.R | 60 +++++++++++++++++++++++++++++++++++++++++ R/step2_helper_data.R | 8 +++--- R/tm_layers_text.R | 42 ++++++++++++++++++----------- R/tmapGrid_layers.R | 61 +++++++++++++++++++++++++++++------------- R/tmapScaleRGB.R | 4 +++ R/tmapScale_defaults.R | 6 +++-- R/tmapScale_misc.R | 5 +++- examples/tm_text.R | 37 ++++++++++++++++++++++++- man/tm_text.Rd | 48 +++++++++++++++++++++++++++++++-- 9 files changed, 227 insertions(+), 44 deletions(-) diff --git a/R/misc_other.R b/R/misc_other.R index 3bc727a9..04848f3f 100644 --- a/R/misc_other.R +++ b/R/misc_other.R @@ -245,6 +245,65 @@ get_midpoint <- function (coords) { } +# copied from tmap3, may need updating +process_just <- function(just, interactive) { + show.messages <- get("tmapOptions", envir = .TMAP)$show.messages + show.warnings <- get("tmapOptions", envir = .TMAP)$show.warnings + + n <- length(just) + isnum <- is_num_string(just) + + if (!all(isnum | (just %in% c("left", "right", "top", "bottom", "center", "centre"))) && show.warnings) { + warning("wrong specification of argument just", call. = FALSE) + } + + just[just == "centre"] <- "center" + + if (interactive) { + just <- just[1] + if (n > 1 && show.messages) message("In interactive mode, the just argument should be one element") + + if (isnum[1]) { + justnum <- as.numeric(just) + just <- ifelse(justnum < .25, "left", + ifelse(justnum > .75, "right", "center")) + if (show.messages) message("In interactive mode, just cannot be a numeric value. Therefore, ", justnum, " has been cenverted to \"", just, "\".") + } + } else { + if (n > 2 && show.warnings) warning("The just argument should be a single value or a vector of 2 values.", call. = FALSE) + if (n == 1) { + if (just %in% c("top", "bottom")) { + just <- c("center", just) + isnum <- c(FALSE, isnum) + } else { + just <- c(just, "center") + isnum <- c(isnum, FALSE) + } + } + + x <- ifelse(isnum[1], as.numeric(just[1]), + ifelse(just[1] == "left", 0, + ifelse(just[1] == "right", 1, + ifelse(just[1] == "center", .5, NA)))) + if (is.na(x)) { + if (show.warnings) warning("wrong specification of argument just", call. = FALSE) + x <- .5 + } + + y <- ifelse(isnum[2], as.numeric(just[2]), + ifelse(just[2] == "bottom", 0, + ifelse(just[2] == "top", 1, + ifelse(just[2] == "center", .5, NA)))) + if (is.na(y)) { + if (show.warnings) warning("wrong specification of argument just", call. = FALSE) + y <- .5 + } + just <- c(x, y) + } + just +} + + @@ -375,3 +434,4 @@ native_to_npc_to_native <- function(x, scale) { + diff --git a/R/step2_helper_data.R b/R/step2_helper_data.R index 5286a334..17f0039a 100644 --- a/R/step2_helper_data.R +++ b/R/step2_helper_data.R @@ -97,11 +97,13 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) # constant values (take first value (of possible tm_mv per facet) if (any(nvari) > 1) warning("Aesthetic values considered as direct visual variables, which cannot be used with tm_mv", call. = FALSE) val1 = sapply(vars, "[[", 1, USE.NAMES = FALSE) - check_fun = paste0("tmapValuesCheck_", unm) - if (!do.call(check_fun, list(x = val1))) { + check = do.call(check_fun, list(x = val1)) + if (!check) { # to do: add "layer" name e.g. tm_fill is still "polygons" and not "fill" - stop("Visual values used for the variable, \"", unm, "\" of layer function \"tm_", layer[1], "\" are incorrect.", call. = FALSE) + info = attr(check, "info") + + stop("Visual values used for the variable, \"", unm, "\" of layer function \"tm_", layer[1], "\" are incorrect.", info, call. = FALSE) } val1 = do.call(sfun, list(x = val1, scale = o$scale)) diff --git a/R/tm_layers_text.R b/R/tm_layers_text.R index b426fff0..db0e9d24 100644 --- a/R/tm_layers_text.R +++ b/R/tm_layers_text.R @@ -60,10 +60,13 @@ #' the text. See details. #' @param angle,angle.scale,angle.legend,angle.chart,angle.free Rotation angle #' @param points.only should only point geometries of the shape object (defined in [tm_shape()]) be plotted? By default `"ifany"`, which means `TRUE` in case a geometry collection is specified. +#' @param just justification of the text relative to the point coordinates. Either one of the following values: \code{"left"} , \code{"right"}, \code{"center"}, \code{"bottom"}, and \code{"top"}, or a vector of two values where first value specifies horizontal and the second value vertical justification. Besides the mentioned values, also numeric values between 0 and 1 can be used. 0 means left justification for the first value and bottom justification for the second value. Note that in view mode, only one value is used. #' @param along.lines logical that determines whether labels are rotated along the spatial lines. Only applicable if a spatial lines shape is used. +#' @param bg.padding The padding of the background in terms of line heights. #' @param clustering value that determines whether the text labels are clustered in \code{"view"} mode. One of: \code{TRUE}, \code{FALSE}, or the output of \code{\link[leaflet:markerClusterOptions]{markerClusterOptions}}. #' @param point.label logical that determines whether the labels are placed automatically. #' @param point.label.gap numeric that determines the gap between the point and label +#' @param point.label.method the optimization method, either `"SANN"` for simulated annealing (the default) or `"GA"` for a genetic algorithm. #' @param remove.overlap logical that determines whether the overlapping labels are removed #' @param ... to catch deprecated arguments from version < 4.0 #' @example ./examples/tm_text.R @@ -127,10 +130,13 @@ tm_text = function(text = tm_const(), group = NA, group.control = "check", points.only = "ifany", + just = "center", along.lines = FALSE, + bg.padding = 0.4, clustering = FALSE, point.label = FALSE, point.label.gap = 0, + point.label.method = "SANN", remove.overlap = FALSE, ...) { @@ -138,7 +144,7 @@ tm_text = function(text = tm_const(), args = list(...) trans.args = list(points.only = points.only, along.lines = along.lines) - mapping.args = list(clustering = clustering, point.label = point.label, remove.overlap = remove.overlap, point.label.gap = point.label.gap) + mapping.args = list(clustering = clustering, point.label = point.label, remove.overlap = remove.overlap, point.label.gap = point.label.gap, point.label.method = point.label.method, just = just, bg.padding = bg.padding) # dput(names(formals("tm_text"))) v3 = c("root", "clustering", "size.lim", "sizes.legend", @@ -148,7 +154,7 @@ tm_text = function(text = tm_const(), "contrast", "colorNA", "textNA", "showNA", "colorNULL", "fontface", "fontfamily", "alpha", "case", "bg.alpha", "size.lowerbound", "print.tiny", "scale", "auto.placement", - "along.lines", "overwrite.lines", "just", "xmod", "ymod", "title.size", + "along.lines", "overwrite.lines", "xmod", "ymod", "title.size", "title.col", "legend.size.show", "legend.col.show", "legend.format", "legend.size.is.portrait", "legend.col.is.portrait", "legend.size.reverse", "legend.col.reverse", "legend.hist", "legend.hist.title", "legend.size.z", @@ -242,18 +248,7 @@ tm_text = function(text = tm_const(), tm_element_list(tm_element( layer = "text", trans.fun = tmapTransCentroid, - trans.aes = list(xmod = tmapScale(aes = "xmod", - value = xmod, - scale = xmod.scale, - legend = xmod.legend, - chart = xmod.chart, - free = xmod.free), - ymod = tmapScale(aes = "ymod", - value = ymod, - scale = ymod.scale, - legend = ymod.legend, - chart = ymod.chart, - free = ymod.free)), + trans.aes = list(), trans.args = trans.args, trans.isglobal = FALSE, mapping.aes = list( @@ -304,7 +299,19 @@ tm_text = function(text = tm_const(), scale = fontface.scale, legend = fontface.legend, chart = fontface.chart, - free = fontface.free)), + free = fontface.free), + xmod = tmapScale(aes = "xmod", + value = xmod, + scale = xmod.scale, + legend = xmod.legend, + chart = xmod.chart, + free = xmod.free), + ymod = tmapScale(aes = "ymod", + value = ymod, + scale = ymod.scale, + legend = ymod.legend, + chart = ymod.chart, + free = ymod.free)), gpar = tmapGpar(fill = NA, col = "__col", @@ -323,6 +330,8 @@ tm_text = function(text = tm_const(), lineend = NA, bgcol = "__bgcol", bgcol_alpha = "__bgcol_alpha", + xmod = "__xmod", + ymod = "__ymod", angle = "__angle", shadow = shadow), tpar = tmapTpar(), @@ -400,7 +409,7 @@ tm_labels = function(text = tm_const(), group = NA, group.control = "check", points.only = "ifany", - along.lines = FALSE, + along.lines = TRUE, clustering = FALSE, point.label = TRUE, point.label.gap = 0.3, @@ -411,3 +420,4 @@ tm_labels = function(text = tm_const(), tm[[1]]$layer = c("labels", "text") tm } + diff --git a/R/tmapGrid_layers.R b/R/tmapGrid_layers.R index 09ade187..d5d59c74 100644 --- a/R/tmapGrid_layers.R +++ b/R/tmapGrid_layers.R @@ -350,22 +350,36 @@ tmapGridText = function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id # calculate native per line - wIn = g$colsIn[g$cols_facet_ids[facet_col]] - hIn = g$rowsIn[g$rows_facet_ids[facet_row]] - - wNative = bbx[3] - bbx[1] - hNative = bbx[4] - bbx[2] - - xIn = wNative / wIn - yIn = hNative / hIn - - - lineIn = convertHeight(unit(1, "lines"), "inch", valueOnly = TRUE) - #xnpl = (wNative / wIn) / lineIn - #ynpl = (hNative / hIn) / lineIn + wIn = g$colsIn[g$cols_facet_ids[facet_col]] + hIn = g$rowsIn[g$rows_facet_ids[facet_row]] + + wNative = bbx[3] - bbx[1] + hNative = bbx[4] - bbx[2] + + xIn = wNative / wIn + yIn = hNative / hIn + + + lineIn = convertHeight(unit(1, "lines"), "inch", valueOnly = TRUE) + #xnpl = (wNative / wIn) / lineIn + #ynpl = (hNative / hIn) / lineIn #} + just = process_just(args$just, interactive = FALSE) + if (args$point.label) { + if (!all(just == 0.5)) { + just = c(0.5, 0.5) + if (get("tmapOptions", envir = .TMAP)$show.messages) message("Point labeling is enabled. Therefore, just will be ignored.") + + } + } + + + # apply xmod and ymod + coords[,1] = coords[,1] + xIn * lineIn * gp$cex * gp$xmod + coords[,2] = coords[,2] + yIn * lineIn * gp$cex * gp$ymod + # specials vv (later on lost after gp_to_gpar) bgcol = gp$bgcol bgcol_alpha = gp$bgcol_alpha @@ -386,10 +400,11 @@ tmapGridText = function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id gps = split_gp(gp, n) grobTextList = mapply(function(txt, x , y, gp, a) { - grid::textGrob(x = grid::unit(x, "native"), y = grid::unit(y, "native"), label = txt, gp = gp, rot = a) #, name = paste0("text_", id)) + grid::textGrob(x = grid::unit(x, "native"), y = grid::unit(y, "native"), label = txt, gp = gp, rot = a, just = just) #, name = paste0("text_", id)) }, dt$text, coords[,1], coords[, 2], gps, angle, SIMPLIFY = FALSE, USE.NAMES = FALSE) + if (with_bg || args$remove.overlap) { tGH = vapply(grobTextList, function(grb) { convertHeight(grobHeight(grb), "inch", valueOnly = TRUE) @@ -399,11 +414,18 @@ tmapGridText = function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id convertWidth(grobWidth(grb), "inch", valueOnly = TRUE) }, FUN.VALUE = numeric(1), USE.NAMES = FALSE) * xIn - tGX = unit(coords[,1], "native") - tGY = unit(coords[,2], "native") + justx <- .5 - just[1] + justy <- .5 - just[2] - tGH = unit(tGH , "native") - tGW = unit(tGW, "native") + #tGX <- grobText$x + unit(tGW * justx, "native") + #tGY <- grobText$y + unit(tGH * justy, "native") + + + tGX = unit(coords[,1] + justx * tGW, "native") + tGY = unit(coords[,2] + justy * tGH, "native") + + tGH = unit(tGH + args$bg.padding * yIn * lineIn, "native") + tGW = unit(tGW + args$bg.padding * xIn * lineIn, "native") grobTextBGList = mapply(function(x, y, w, h, b, a) { rectGrob(x=x, y=y, width=w, height=h, gp=gpar(fill=b, alpha = a, col=NA)) @@ -430,7 +452,7 @@ tmapGridText = function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id rect = do.call(rbind, lapply(s, get_rect_coords)) - res = pointLabel2(x = rect[,1], y = rect[,2], width = rect[,3], height = rect[,4], bbx = bbx, gap = yIn * lineIn * args$point.label.gap, method = "SANN") + res = pointLabel2(x = rect[,1], y = rect[,2], width = rect[,3], height = rect[,4], bbx = bbx, gap = yIn * lineIn * args$point.label.gap, method = args$point.label.method) sx = res$x - rect[,1] sy = res$y - rect[,2] @@ -506,3 +528,4 @@ tmapGridText = function(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id assign("gts", gts, envir = .TMAP_GRID) NULL } + diff --git a/R/tmapScaleRGB.R b/R/tmapScaleRGB.R index 5a64387b..e6a37887 100644 --- a/R/tmapScaleRGB.R +++ b/R/tmapScaleRGB.R @@ -59,6 +59,10 @@ tmapScaleAsIs = function(x1, scale, legend, chart, o, aes, layer, layer_args, so scale = "AsIs", show = FALSE) + x1h = head(x1, 100) + check_values(layer, aes, x1h) + + sfun = paste0("tmapValuesScale_", aes) cfun = paste0("tmapValuesColorize_", aes) diff --git a/R/tmapScale_defaults.R b/R/tmapScale_defaults.R index 5e4c5c4e..f44e7894 100644 --- a/R/tmapScale_defaults.R +++ b/R/tmapScale_defaults.R @@ -42,10 +42,12 @@ tmapValuesCheck_lty = function(x) { tmapValuesCheck_xmod = tmapValuesCheck_ymod = function(x) { # to do - TRUE + res = all(x >= -50 & x <= 50) + if (!res) attr(res, "info") = " Values found that are outside the [-50,50] range. Note that the default scale for xmod and ymod is tm_scale_asis." + res } -tmapValuesCheck_angle = tmapValuesCheck_ymod = function(x) { +tmapValuesCheck_angle = function(x) { # to do is.numeric(x) } diff --git a/R/tmapScale_misc.R b/R/tmapScale_misc.R index 217e7366..c4b8e7f3 100644 --- a/R/tmapScale_misc.R +++ b/R/tmapScale_misc.R @@ -2,7 +2,10 @@ check_values = function(layer, aes, values) { fun_check = paste0("tmapValuesCheck_", aes) are_valid = do.call(fun_check, args = list(x = values)) - if (!are_valid) stop("Incorrect values for layer ", layer, ", aesthetic ", aes, "; values should conform visual variable \"", aes, "\"", call. = FALSE) + if (!are_valid) { + info = attr(are_valid, "info") + stop("Incorrect values for layer ", layer, ", aesthetic ", aes, "; values should conform visual variable \"", aes, "\".", info, call. = FALSE) + } } get_scale_defaults = function(scale, o, aes, layer, cls, ct = NULL) { diff --git a/examples/tm_text.R b/examples/tm_text.R index 40d5d5bf..5429b9d0 100644 --- a/examples/tm_text.R +++ b/examples/tm_text.R @@ -45,7 +45,7 @@ tm_shape(DE) + tm_polygons() + tm_shape(rivers_DE) + tm_lines(lwd = "strokelwd", lwd.scale = tm_scale_asis()) + - tm_text("name", along.lines = TRUE) + tm_labels("name") metroAfrica = sf::st_intersection(metro, World[World$continent == "Africa", ]) @@ -62,3 +62,38 @@ tm_shape(metroAfrica) + tm_shape(metroAfrica) + tm_labels("name", bgcol = "yellow") + tm_dots("red") + +##### v3 examples + +current.mode <- tmap_mode("plot") + +data(World, metro) + +tm_shape(World) + + tm_text("name", size="AREA") + + +tm_shape(World) + + tm_text("name", size="pop_est", col="continent", palette="Dark2", + title.size = "Population", title.col="Continent") + + tm_legend(outside = TRUE) + +tmap_mode("view") + +\dontrun{ + require(tmaptools) + metro_aus <- crop_shape(metro, bb("Australia")) + + tm_shape(metro_aus) + + tm_dots() + + tm_text("name", just = "top") + + # alternative + tm_shape(metro_aus) + + tm_markers(text = "name") +} + +# restore current mode +tmap_mode(current.mode) + + diff --git a/man/tm_text.Rd b/man/tm_text.Rd index f31e4a8a..4bd59d58 100644 --- a/man/tm_text.Rd +++ b/man/tm_text.Rd @@ -63,10 +63,13 @@ tm_text( group = NA, group.control = "check", points.only = "ifany", + just = "center", along.lines = FALSE, + bg.padding = 0.4, clustering = FALSE, point.label = FALSE, point.label.gap = 0, + point.label.method = "SANN", remove.overlap = FALSE, ... ) @@ -129,7 +132,7 @@ tm_labels( group = NA, group.control = "check", points.only = "ifany", - along.lines = FALSE, + along.lines = TRUE, clustering = FALSE, point.label = TRUE, point.label.gap = 0.3, @@ -187,14 +190,20 @@ and \code{"none"} for no control (the group cannot be (de)selected).} \item{points.only}{should only point geometries of the shape object (defined in \code{\link[=tm_shape]{tm_shape()}}) be plotted? By default \code{"ifany"}, which means \code{TRUE} in case a geometry collection is specified.} +\item{just}{justification of the text relative to the point coordinates. Either one of the following values: \code{"left"} , \code{"right"}, \code{"center"}, \code{"bottom"}, and \code{"top"}, or a vector of two values where first value specifies horizontal and the second value vertical justification. Besides the mentioned values, also numeric values between 0 and 1 can be used. 0 means left justification for the first value and bottom justification for the second value. Note that in view mode, only one value is used.} + \item{along.lines}{logical that determines whether labels are rotated along the spatial lines. Only applicable if a spatial lines shape is used.} +\item{bg.padding}{The padding of the background in terms of line heights.} + \item{clustering}{value that determines whether the text labels are clustered in \code{"view"} mode. One of: \code{TRUE}, \code{FALSE}, or the output of \code{\link[leaflet:markerClusterOptions]{markerClusterOptions}}.} \item{point.label}{logical that determines whether the labels are placed automatically.} \item{point.label.gap}{numeric that determines the gap between the point and label} +\item{point.label.method}{the optimization method, either \code{"SANN"} for simulated annealing (the default) or \code{"GA"} for a genetic algorithm.} + \item{remove.overlap}{logical that determines whether the overlapping labels are removed} \item{...}{to catch deprecated arguments from version < 4.0} @@ -277,7 +286,7 @@ tm_shape(DE) + tm_polygons() + tm_shape(rivers_DE) + tm_lines(lwd = "strokelwd", lwd.scale = tm_scale_asis()) + - tm_text("name", along.lines = TRUE) + tm_labels("name") metroAfrica = sf::st_intersection(metro, World[World$continent == "Africa", ]) @@ -294,4 +303,39 @@ tm_shape(metroAfrica) + tm_shape(metroAfrica) + tm_labels("name", bgcol = "yellow") + tm_dots("red") + +##### v3 examples + +current.mode <- tmap_mode("plot") + +data(World, metro) + +tm_shape(World) + + tm_text("name", size="AREA") + + +tm_shape(World) + + tm_text("name", size="pop_est", col="continent", palette="Dark2", + title.size = "Population", title.col="Continent") + + tm_legend(outside = TRUE) + +tmap_mode("view") + +\dontrun{ + require(tmaptools) + metro_aus <- crop_shape(metro, bb("Australia")) + + tm_shape(metro_aus) + + tm_dots() + + tm_text("name", just = "top") + + # alternative + tm_shape(metro_aus) + + tm_markers(text = "name") +} + +# restore current mode +tmap_mode(current.mode) + + }