tm_text improved (just argument added)

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) {
 
 
 
+

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

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,18 +130,21 @@ 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,
  ...) {
 
  #if (FALSE) {
  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
 }
+

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 
 }
+

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)
 

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

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) {

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)
+
+