Merged upstream/master into cleanup

R/process_meta.R

@@ -208,30 +208,41 @@ process_meta = function(o, d, cdt, aux) {
  rep(0, 4)
  }
 
- grid.margins = if (grid.show && !grid.labels.inside.frame) {
-
+
+
+ grid.labels.show = rep(grid.labels.show, length.out = 2) # also happens in tmapGridGridPrep
+ if (grid.show && any(grid.labels.show) && !grid.labels.inside.frame) {
  proj = sf::st_crs(bbx)
  if (!is.na(o$grid.crs)) {
  bbx_orig <- bbx
  bbx <- suppressWarnings(bb(bbx, current.projection = proj, projection = o$grid.crs))
  }
 
- gridx = pretty30(bbx[c(1,3)], n=5, longlat = !is.na(o$grid.crs) && sf::st_is_longlat(proj))
- gridy = pretty30(bbx[c(2,4)], n=5, longlat = !is.na(o$grid.crs) && sf::st_is_longlat(proj))
-
- xbbstringWin <- max(convertWidth(stringWidth(do.call("fancy_breaks", c(list(vec=gridx, intervals=FALSE), grid.labels.format))), "inch", valueOnly = TRUE)) * grid.labels.size
- ybbstringWin <- max(convertWidth(stringWidth(do.call("fancy_breaks", c(list(vec=gridy, intervals=FALSE), grid.labels.format))), "inch", valueOnly = TRUE)) * grid.labels.size
-
  lineHin <- convertHeight(unit(grid.labels.size, "lines"), "inch", valueOnly=TRUE)
 
- xgridHin <- ifelse(!is.na(grid.labels.space.x), grid.labels.space.x * lineHin, ifelse(grid.labels.rot[1] %in% c(0, 180), 1.375 * lineHin, xbbstringWin + lineHin * .75) + grid.labels.margin.x * lineHin)
- ygridWin <- ifelse(!is.na(grid.labels.space.y), grid.labels.space.y * lineHin, ifelse(grid.labels.rot[2] %in% c(0, 180), ybbstringWin + lineHin * .75, 1.375 * lineHin) + grid.labels.margin.y * lineHin)
+ if (grid.labels.show[1]) {
+ gridx = pretty30(bbx[c(1,3)], n=5, longlat = !is.na(o$grid.crs) && sf::st_is_longlat(proj))
+ xbbstringWin <- max(convertWidth(stringWidth(do.call("fancy_breaks", c(list(vec=gridx, intervals=FALSE), grid.labels.format))), "inch", valueOnly = TRUE)) * grid.labels.size
+ xgridHin <- ifelse(!is.na(grid.labels.space.x), grid.labels.space.x * lineHin, ifelse(grid.labels.rot[1] %in% c(0, 180), 1.375 * lineHin, xbbstringWin + lineHin * .75) + grid.labels.margin.x * lineHin)
+
+ } else {
+ xgridHin = 0
+ }
+
+ if (grid.labels.show[2]) {
+ gridy = pretty30(bbx[c(2,4)], n=5, longlat = !is.na(o$grid.crs) && sf::st_is_longlat(proj))
+ ybbstringWin <- max(convertWidth(stringWidth(do.call("fancy_breaks", c(list(vec=gridy, intervals=FALSE), grid.labels.format))), "inch", valueOnly = TRUE)) * grid.labels.size
+ ygridWin <- ifelse(!is.na(grid.labels.space.y), grid.labels.space.y * lineHin, ifelse(grid.labels.rot[2] %in% c(0, 180), ybbstringWin + lineHin * .75, 1.375 * lineHin) + grid.labels.margin.y * lineHin)
+ } else {
+ ygridWin = 0
+ }
 
  marks_new = c(xgridHin, ygridWin, xgridHin, ygridWin) / lin 
- as.integer(c("bottom", "left", "top", "right") %in% grid.labels.pos) * marks_new * c(lineH, lineW, lineH, lineW)
+ grid.margins = as.integer(c("bottom", "left", "top", "right") %in% grid.labels.pos) * marks_new * c(lineH, lineW, lineH, lineW)
  } else {
- rep(0, 4)
+ grid.margins = rep(0, 4)
  }
+
  between.marginH = between.margin * lineH
  between.marginW = between.margin * lineW
 

R/step1_helper_facets.R

@@ -163,7 +163,7 @@ step1_rearrange_facets = function(tmo, o) {
  } else if (identical(popup.vars, FALSE)) {
  popup.vars = character(0)
  } else if (is.na(popup.vars[1])) {
- popup.vars = get("used_vars", envir = .TMAP)
+ popup.vars = setdiff(get("used_vars", envir = .TMAP), c("AREA", "LENGTH", "MAP_COLORS"))
  if (!length(popup.vars)) popup.vars = smeta$vars
  }
  popup.format = process_label_format(popup.format, o$label.format)

R/step4_plot.R

@@ -274,11 +274,12 @@ step4_plot = function(tm, vp, return.asp, show) {
 
 
  ## place components top left
- cdt$comp = lapply(cdt$comp, function(cc) {
- cc$position = l = complete_options(tm_pos_in("left", "top"), o$legend.position)
- cc
- })
-
+ if (o$legend.only) {
+ cdt$comp = lapply(cdt$comp, function(cc) {
+ cc$position = l = complete_options(tm_pos_in("left", "top"), o$legend.position)
+ cc
+ })
+ }
 
 
  if (nrow(cdt)) cdt = process_components(cdt, o)
@@ -616,10 +617,10 @@ step4_plot = function(tm, vp, return.asp, show) {
 
  # plot grid labels
  if (o$grid.show && !o$grid.labels.inside.frame) {
- if ((o$grid.labels.pos[1] == "left" && d$col[i] == 1) || (o$grid.labels.pos[1] == "right" && d$col[i] == o$ncols)) {
+ if (o$grid.labels.show[2] && ((o$grid.labels.pos[1] == "left" && d$col[i] == 1) || (o$grid.labels.pos[1] == "right" && d$col[i] == o$ncols))) {
  do.call(FUNgridylab, list(bi = d$bi[i], bbx = bbx, facet_row = d$row[i], facet_col = d$col[i], facet_page = d$page[i], o = o))
  }
- if ((o$grid.labels.pos[2] == "top" && d$row[i] == 1) || (o$grid.labels.pos[2] == "bottom" && d$row[i] == o$nrows)) {
+ if (o$grid.labels.show[1] && ((o$grid.labels.pos[2] == "top" && d$row[i] == 1) || (o$grid.labels.pos[2] == "bottom" && d$row[i] == o$nrows))) {
  do.call(FUNgridxlab, list(bi = d$bi[i], bbx = bbx, facet_row = d$row[i], facet_col = d$col[i], facet_page = d$page[i], o = o))
  }
  }

R/tm_add_legend.R

@@ -8,7 +8,7 @@
 #' `"fill_alpha"`, `"col_alpha"`, `"lty"`, `"lwd"`, `"linejoin"`, and `"lineend"`.
 #' @param labels labels
 #' @param type the layer type from which the visual variables (see `...`) are taken.
-#' Options: `"Symbols"` (default), `"Lines"`, `"Polygons"`, and `"Text"`.
+#' Options: `"symbols"` (default), `"lines"`, `"polygons"`, and `"text"`.
 #' @param title text of the title
 #' @param design legend design
 #' @param orientation legend orientation
@@ -24,7 +24,7 @@
 #' @export
 tm_add_legend = function(...,
  labels,
- type = "Symbols",
+ type = "symbols",
  title = "",
  design = NULL,
  orientation = NULL,
@@ -38,12 +38,16 @@ tm_add_legend = function(...,
  tm_element_list(do.call(tm_element, c(args, list(subclass = c("tm_add_legend", "tm_component")))))
 }
 
+toTitleCase = function(x) {
+ paste0(toupper(substr(x,1,1)), tolower(substr(x,2, nchar(x))))
+}
+
 
 tmapAddedLegend = function(comp, o) {
  #message("tm_mouse_coordinates ignored for 'plot' mode")
- l = update_l(o = o, l = comp, v = "", mfun = comp$type)
+ l = update_l(o = o, l = comp, v = "", mfun = toTitleCase(comp$type))
 
- fun = paste0("tm_", tolower(comp$type))
+ fun = paste0("tm_", comp$type)
  if (!exists(fun)) {
  stop(paste0("type \"", comp$type, "\" not supported because tm_", comp$type, " not found"), call. = FALSE)
  }

R/tmapGridComp.R

@@ -562,19 +562,83 @@ tmapGridLegPlot_text = function(comp, o, fH, fW) {
 
 }
 
+
+correct_nlines = function(n) {
+ # Linear model applied based on this empirical data:
+ # (results may depend on device)
+ #
+ # y = sapply(1:50, function(i) {
+ # s = paste(rep("text", i), collapse = "\n")
+ # convertHeight(stringHeight(s), "inch", valueOnly = TRUE)
+ # })
+ # df = data.frame(x = 1:50, y = y / 0.2) #0.2 is the lineheight (par "cin")
+ # lm(y~x, df)
+ # 
+ -.6035 + n * 1.2
+}
+
+
 tmapGridCompHeight_text = function(comp, o) {
  textS = if (comp$text == "") 0 else comp$size #* o$scale
  textP = comp$padding[c(3,1)] * textS * o$lin
  textH = textS * o$lin
- comp$Hin = sum(textP[1], textH, textP[2])
+
+ nlines = number_text_lines(comp$text)
+
+ nlines2 = correct_nlines(nlines)
+
+ comp$Hin = sum(textP[1], textH * nlines2, textP[2])
  comp
 }
 
+# borrowed from treemap (wraps text to 1-5 lines)
+wrapText = function(txt, nlines) {
+ if (nlines == 1) {
+ txt
+ } else {
+ # create some wrappings, with slightly different widths:
+ results <- lapply(1:5, FUN=function(pos, nlines, txt) {
+ strwrap(txt, width = pos+(nchar(txt)/nlines))}, nlines, txt)
+ lengths = sapply(results, length)
+
+ # find the best match
+ diff = nlines - lengths
+ diff[diff < 0] = 1000
+ id = which.min(diff)[1]
+
+ paste(results[[id]], collapse = "\n")
+ }
+}
+
+
+
+
 tmapGridCompWidth_text = function(comp, o) {
  textS = if (comp$text == "") 0 else comp$size #* o$scale
  textP = comp$padding[c(2,4)] * textS * o$lin
  textW = textS * graphics::strwidth(comp$text, units = "inch", family = comp$fontfamily, font = fontface2nr(comp$fontface))
- comp$Win = sum(textP[1], textW, textP[2])
+
+ w = sum(textP[1], textW, textP[2])
+
+ if (!is.na(comp$width)) {
+ textPgs = strsplit(comp$text, "\n")[[1]]
+ text2 = do.call(paste, c(lapply(textPgs, function(p) {
+ textW = textS * graphics::strwidth(p, units = "inch", family = comp$fontfamily, font = fontface2nr(comp$fontface))
+ w = sum(textP[1], textW, textP[2])
+ nlines = round(w / (comp$width * textS * o$lin))
+ wrapText(p, nlines)
+ }), list(sep = "\n")))
+
+ textW2 = textS * graphics::strwidth(text2, units = "inch", family = comp$fontfamily, font = fontface2nr(comp$fontface))
+ w2 = sum(textP[1], textW2, textP[2])
+
+ #approxNumL = min(20, round(w / (comp$width * textS * o$lin)))
+ comp$text = text2
+ comp$Win = w2
+ } else {
+ #comp$nlines = length(comp$textPgs)
+ comp$Win = w
+ }
  comp
 }
 

R/tmapGridLegend.R

@@ -50,7 +50,7 @@ tmapGridCompCorner = function(comp, o, stack, pos.h, pos.v, maxH, maxW, offsetIn
  scaleH = legHin / maxH
 
  # because of legend frames (for which margins are added in tmapGridLegend), the scale may be a bit above 1, even though automatic layout is applied and there is enough space
- if (any(scaleW > 1.05) || any(scaleH > 1.05)) warning("Some legend items or map compoments do not fit well (e.g. due to the specified font size).", call. = FALSE)
+ if (any(scaleW > 1.1) || any(scaleH > 1.1)) warning("Some legend items or map compoments do not fit well (e.g. due to the specified font size).", call. = FALSE)
 
  clipW = pmax(1, scaleW) 
  clipH = pmax(1, scaleH) 

R/tmapScaleBivariate.R

@@ -40,10 +40,7 @@ tmapScaleBivariate = function(x1, x2, scale, legend, o, aes, layer, layer_args,
  vals = res[[1]]$vid + (res[[2]]$vid - 1L) * n1
 
  with(scale, {
- 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 aes ", aes, call. = FALSE)
+ check_values(layer, aes, values)
 
  fun_getBVV = paste0("tmapValuesBVV_", aes)
  VV = do.call(fun_getBVV, list(x = values, value.na = value.na, m = n1, n = n2, scale = values.scale * o$scale, rep = values.repeat, o = o))

R/tmapScaleCategorical.R

@@ -15,7 +15,8 @@ tmapScaleCategorical = function(x1, scale, legend, o, aes, layer, layer_args, so
  show.warnings <- o$show.warnings
 
  with(scale, {
-
+ check_values(layer, aes, values)
+
  nms = names(values) #color_names
 
  # cast to factor if needed

R/tmapScaleContinuous.R

@@ -127,10 +127,7 @@ tmapScaleContinuous = function(x1, scale, legend, o, aes, layer, layer_args, sor
  if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range)
 
 
- 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 aes ", aes, call. = FALSE)
+ check_values(layer, aes, values)
 
  fun_isdiv = paste0("tmapValuesIsDiv_", aes)
 

R/tmapScaleDiscrete.R

@@ -48,10 +48,7 @@ tmapScaleDiscrete = function(x1, scale, legend, o, aes, layer, layer_args, sortR
 
  d_isdiv = rng[1] < 0 && rng[2] > 0 
 
- 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 aes ", aes, call. = FALSE)
+ check_values(layer, aes, values)
 
  fun_isdiv = paste0("tmapValuesIsDiv_", aes)
 

R/tmapScaleIntervals.R

@@ -67,10 +67,7 @@ tmapScaleIntervals = function(x1, scale, legend, o, aes, layer, layer_args, sort
  }
  if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range)
 
- 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 aes ", aes, call. = FALSE)
+ check_values(layer, aes, values)
 
  fun_isdiv = paste0("tmapValuesIsDiv_", aes)
 

R/tmapScaleRank.R

@@ -60,10 +60,7 @@ tmapScaleRank = function(x1, scale, legend, o, aes, layer, layer_args, sortRev,
  if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range)
 
 
- 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 aes ", aes, call. = FALSE)
+ check_values(layer, aes, values)
 
  fun_isdiv = paste0("tmapValuesIsDiv_", aes)
 

R/tmapScale_defaults.R

@@ -1,11 +1,10 @@
-tmapValuesCheck_fill = function(x) {
- (!is.null(getPalMeta(x[1])) || all(valid_colors(x))) && !is.numeric(x)
-}
-
 tmapValuesCheck_col = function(x) {
- (!is.null(getPalMeta(x[1])) || all(valid_colors(x))) && !is.numeric(x)
+ ((!is.null(getPalMeta(x[1])) && length(x) == 1L)  || all(valid_colors(x))) && !is.numeric(x)
 }
 
+tmapValuesCheck_fill = function(x) {
+ tmapValuesCheck_col(x)
+}
 
 tmapValuesCheck_shape = function(x) {
  isSymbol = function(s) {
@@ -411,10 +410,10 @@ tmapValuesCVV_fill = function(x, value.na, n, range, scale, rep, o) {
  # process values
  #palid = tmapPalId(x[1])
 
+ arecolors = valid_colors(x[1])
  m = getPalMeta(x[1])
 
- ispalette = !is.null(m) && (length(x) == 1) # the latter in case of ambiguity (e.g. "blue")
- arecolors = valid_colors(x[1])
+ ispalette = !is.null(m) && !arecolors # the latter in case of ambiguity (e.g. "blue")
 
  values = if (!ispalette && !arecolors) {
  rep(x, length.out = n) 

R/tmapScale_misc.R

@@ -1,3 +1,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)
+}
+
 get_scale_defaults = function(scale, o, aes, layer, cls, ct = NULL) {
  within(scale, {
  values = if (is.na(values[1])) {

R/tmapShape.R

@@ -144,9 +144,9 @@ tmapShape.SpatRaster = function(shp, is.main, crs, bbox, unit, filter, shp_name,
  ct = ctabs[[nm]]
  lt = cats[[nm]]
  if (is.factor(dt[[nm]])) {
- levels(dt[[nm]])
+ #levels(dt[[nm]])
 
- ids = match(lt$value, ct$value)
+ ids = match(lt$value[match(levels(dt[[nm]]), lt$levels)], ct$value)
  cti = ct[ids,]
 
  cls = rgb(cti$red, cti$green, cti$blue, cti$alpha, maxColorValue = 255)

R/tmapSubsetShp.R

@@ -64,7 +64,7 @@ tmapSubsetShp.sf = function(shp, vars) {
  shp$LENGTH = sf::st_length(shp)
  }
  if ("MAP_COLORS" %in% vars) {
- shp$MAP_COLORS = tmaptools::map_coloring(shp)
+ shp$MAP_COLORS = as.factor(tmaptools::map_coloring(shp))
  }
  if (!length(vars)) {
  vars = "dummy__"

R/tmap_options.R

@@ -329,6 +329,7 @@
  title.frame.r = 2,
  title.stack = "vertical",
  title.position = tm_pos_out(cell.h = "center", cell.v ="top", pos.h = "left", pos.v = "top", align.h = "left", align.v = "top", just.h = "left", just.v = "bottom"),
+ title.width = NA,
  title.group.frame = TRUE,
  title.resize.as.group = FALSE,