improved continuous scaling, cartograms, and panels

NAMESPACE

@@ -121,6 +121,9 @@ export(get_fact_levels_na)
 export(make_by_vars)
 export(marker_icon)
 export(opt_tm_bubbles)
+export(opt_tm_cartogram)
+export(opt_tm_cartogram_dorling)
+export(opt_tm_cartogram_ncont)
 export(opt_tm_dots)
 export(opt_tm_labels)
 export(opt_tm_lines)

R/misc_other.R

@@ -72,7 +72,7 @@ completeDT2 = function(DT, cols, defs = NULL){
 } 
 
 cont_breaks = function(breaks, n=101) {
- x = round(seq(1, 101, length.out=length(breaks)))
+ x = round(seq(1, n, 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) 

R/process_meta.R

@@ -40,8 +40,7 @@ preprocess_meta = function(o, cdt) {
  isdef = !sapply(fl, is.null)
  n = prod(nby)
 
-
- if (is.na(panel.type)) panel.type = ifelse(((type == "page" || n == 1) && is.na(panel.labels[[1]])) || ((type %in% c("wrap", "stack")) && !isdef[1]) || (!(type %in% c("wrap", "stack")) && !isdef[1] && !isdef[2]), "none", 
+ if (is.na(panel.type)) panel.type = ifelse(((type == "page" || n == 1) && is.na(panel.labels[[1]])) || ((type %in% c("wrap", "stack")) && !isdef[1]) || (!(type %in% c("wrap", "stack")) && !isdef[1] && !isdef[2]) || !o$panel.show, "none", 
  ifelse((type %in% c("wrap", "stack")) || (n == 1), "wrap", "xtab"))
 
  inner.margins = get_option_class(inner.margins, class = main_class)

R/step2_helper_data.R

@@ -88,16 +88,16 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order)
  # active grouping variables (to keep)
  grp_bv = by123__[sort(c({if (nvars > 1) v else integer(0)}, b))]
 
- sfun = paste0("tmapValuesScale_", unm)
- cfun = paste0("tmapValuesColorize_", unm)
+ sfun = paste0("tmapValuesScale_", nm)
+ cfun = paste0("tmapValuesColorize_", nm)
 
  #print(vars)
  if (!aes$data_vars && !aes$geo_vars) {
- # cat("step2_grp_lyr_aes_const", unm," \n")
+ #cat("step2_grp_lyr_aes_const", unm," \n")
  # 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)
+ check_fun = paste0("tmapValuesCheck_", nm)
  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"
@@ -138,7 +138,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order)
  if (any(!dtl$sel__) || !q$drop.units) {
  # also needed for drop.units later on
  cls = data_class(dtl[[nm]])
- value.null = getAesOption("value.null", o, unm, layer, cls = cls)
+ value.null = getAesOption("value.null", o, nm, layer, cls = cls)
  value.null = do.call(sfun, list(x = value.null, scale = o$scale))
  value.null = do.call(cfun, list(x = value.null, pc = o$pc))
 
@@ -162,6 +162,8 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order)
 
  dtl_leg = dtl[, .SD[1], by = c(grp_bv)][, tmapID__ := NULL][, legnr := (vapply(get(..nm), function(s) legend_save(list(vneutral = s)), FUN.VALUE = integer(1)))][, crtnr := (vapply(get(..nm), function(s) chart_save(list()), FUN.VALUE = integer(1)))][, (nm) := NULL]
  } else {
+ #cat("step2_grp_lyr_aes_var", nm," \n")
+
  relevant_vars = c("tmapID__", "sel__" , vars, by123__[b])
  dtl = copy(dt[, relevant_vars, with = FALSE])
 
@@ -271,12 +273,12 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order)
 
  #aesname = aes$aes
  value.null = if ("value.null" %in% names(s)) s$value.null else {
- vn = getAesOption("value.null", o, unm, layer, cls = cls)
+ vn = getAesOption("value.null", o, nm, layer, cls = cls)
  vn = do.call(sfun, list(x = vn, scale = o$scale))
  do.call(cfun, list(x = vn, pc = o$pc))
  }
 
- arglist = list(scale = s, legend = l, chart = crt, o = o, aes = unm, 
+ arglist = list(scale = s, legend = l, chart = crt, o = o, aes = nm, 
  layer = layer, 
  layer_args = args,
  sortRev = sortRev, 

R/step4_plot.R

@@ -470,7 +470,7 @@ step4_plot = function(tm, vp, return.asp, show, knit, args) {
 
  # determine row and col ids 
 
- if (o$panel.type == "xtab") {
+ if (o$type == "grid") {
  d[, row := as.integer((i - 1) %% o$nrows + 1)]
  d[, col := as.integer((((i - 1) %/% o$nrows + 1) - 1) %% o$ncols + 1)]
  } else {

R/tm_layers_cartogram.R

@@ -1,5 +1,8 @@
 #' @rdname tm_cartogram
 #' @name opt_tm_cartogram
+#' @param type cartogram type, one of: "cont" for contiguous cartogram, "ncont" for non-contiguous cartogram and "dorling" for Dorling cartograms
+#' @param itermax, maximum number of iterations (see [cartogram::cartogram_cont()])
+#' @param ... arguments passed on to [cartogram::cartogram_cont()]
 #' @export
 opt_tm_cartogram = function(type = "cont",
  itermax = 15,
@@ -11,6 +14,8 @@ opt_tm_cartogram = function(type = "cont",
 
 #' @rdname tm_cartogram
 #' @name opt_tm_cartogram
+#' @param expansion factor expansion, see [cartogram::cartogram_ncont()] (argument `k`)
+#' @param inplace should each polygon be modified in its original place? (`TRUE` by default)
 #' @export
 opt_tm_cartogram_ncont = function(type = "ncont",
  expansion = 1,
@@ -25,6 +30,7 @@ opt_tm_cartogram_ncont = function(type = "ncont",
 
 #' @rdname tm_cartogram
 #' @name opt_tm_cartogram
+#' @param share share of the bounding box filled with the larger circle (see [cartogram::cartogram_dorling()] argument `k`)
 #' @export
 opt_tm_cartogram_dorling = function(type = "dorling",
  share = 5,

R/tmapGridComp_leg_landscape.R

@@ -256,15 +256,15 @@ tmapGridLegPlot.tm_legend_standard_landscape = function(comp, o, fH, fW) {
  id1 = which(!is.na(fill_list[[1]]))[1]
  id2 = tail(which(!is.na(fill_list[[nlev2]])), 1)
 
- x1 = ((id1-1) / 10) / nlev2
- x2 = (id2 / 10) / nlev2 + ((nlev2-1)/nlev2)
+ x1 = ((id1-1) / o$nvv) / nlev2
+ x2 = (id2 / o$nvv) / nlev2 + ((nlev2-1)/nlev2)
  w = x2 - x1
 
  if (vary_fill) {
- cols = unlist(fill_list)[id1:(10*(nlev2-1) + id2)]
+ cols = unlist(fill_list)[id1:(o$nvv*(nlev2-1) + id2)]
  cols_alph = paste0(cols, num_to_hex(gp$fill_alpha[1] * 255))
  } else {
- alph = unlist(alpha_list)[id1:(10*(nlev2-1) + id2)]
+ alph = unlist(alpha_list)[id1:(o$nvv*(nlev2-1) + id2)]
  cols_alph = paste0(col2hex(gp$fill[1]), num_to_hex(alph * 255))
  }
  grItems1 = list(gridCell(6, comp$item_ids[lvs], grid::rectGrob(x = x1 + 0.5*w, width= w, gp=gpar(fill = grid::linearGradient(colours = cols_alph), col = NA))))
@@ -279,11 +279,11 @@ tmapGridLegPlot.tm_legend_standard_landscape = function(comp, o, fH, fW) {
  }
 
  if (vary_fill) {
- x1 = (sum(is.na(fill_list[[1]])) * .1) / nlev2
- x2 = (sum(is.na(fill_list[[nlev2]])) * .1) / nlev2
+ x1 = (sum(is.na(fill_list[[1]])) / o$nvv) / nlev2
+ x2 = (sum(is.na(fill_list[[nlev2]])) / o$nvv) / nlev2
  } else {
- x1 = (sum(is.na(alpha_list[[1]])) * .1) / nlev2
- x2 = (sum(is.na(alpha_list[[nlev2]])) * .1) / nlev2
+ x1 = (sum(is.na(alpha_list[[1]])) / o$nvv) / nlev2
+ x2 = (sum(is.na(alpha_list[[nlev2]])) / o$nvv) / nlev2
  }
 
 

R/tmapGridComp_leg_portrait.R

@@ -7,7 +7,7 @@ tmapGridCompPrepare.tm_legend_standard_portrait = function(comp, o) {
 
  type = if ("biv" %in% names(attributes(gp$fill))) {
  "bivariate"
- } else if (!is.na(gp$fill[1]) && any(nchar(gp$fill) > 50) || !is.na(gp$fill_alpha[1]) && any(nchar(gp$fill_alpha) > 50)) {
+ } else if (!is.na(gp$fill[1]) && any(nchar(gp$fill) > 20) || !is.na(gp$fill_alpha[1]) && any(nchar(gp$fill_alpha) > 20)) {
  "gradient"
  } else if (!is.na(gp$shape[1])) {
  "symbols"
@@ -423,15 +423,15 @@ tmapGridLegPlot.tm_legend_standard_portrait = function(comp, o, fH, fW) {
  id1 = which(!is.na(fill_list[[1]]))[1]
  id2 = tail(which(!is.na(fill_list[[nlev2]])), 1)
 
- y1 = 1 - ((id1-1) / 10) / nlev2
- y2 = 1 - ((id2 / 10) / nlev2 + ((nlev2-1)/nlev2))
+ y1 = 1 - ((id1-1) / o$nvv) / nlev2
+ y2 = 1 - ((id2 / o$nvv) / nlev2 + ((nlev2-1)/nlev2))
  h = y1 - y2
 
  if (vary_fill) {
- cols = unlist(fill_list)[id1:(10*(nlev2-1) + id2)]
+ cols = unlist(fill_list)[id1:(o$nvv*(nlev2-1) + id2)]
  cols_alph = paste0(cols, num_to_hex(gp$fill_alpha[1] * 255))
  } else {
- alph = unlist(alpha_list)[id1:(10*(nlev2-1) + id2)]
+ alph = unlist(alpha_list)[id1:(o$nvv*(nlev2-1) + id2)]
  cols_alph = paste0(col2hex(gp$fill[1]), num_to_hex(alph * 255))
  }
  grItems1 = list(gridCell(comp$item_ids[lvs], 3, grid::rectGrob(y = y2 + 0.5*h, height= h, gp=gpar(fill = grid::linearGradient(colours = rev(cols_alph)), col = NA))))
@@ -448,11 +448,11 @@ tmapGridLegPlot.tm_legend_standard_portrait = function(comp, o, fH, fW) {
 
 
  if (vary_fill) {
- y1 = (sum(is.na(fill_list[[1]])) * .1) / nlev2
- y2 = (sum(is.na(fill_list[[nlev2]])) * .1) / nlev2
+ y1 = (sum(is.na(fill_list[[1]])) /o$nvv) / nlev2
+ y2 = (sum(is.na(fill_list[[nlev2]])) /o$nvv) / nlev2
  } else {
- y1 = (sum(is.na(alpha_list[[1]])) * .1) / nlev2
- y2 = (sum(is.na(alpha_list[[nlev2]])) * .1) / nlev2
+ y1 = (sum(is.na(alpha_list[[1]])) /o$nvv) / nlev2
+ y2 = (sum(is.na(alpha_list[[nlev2]])) /o$nvv) / nlev2
  }
 
  grItems2 = list(gridCell(comp$item_ids[lvs], 3, rndrectGrob(y = grid::unit(y2, "npc"), just = c("center", "bottom"), height = grid::unit(1-(y1+y2), "npc"), gp = gpars, r = comp$item.r)))

R/tmapGridInit.R

@@ -12,8 +12,8 @@ tmapGridInit = function(o, return.asp = FALSE, vp) {
  grid.buffers.top = grid.buffers[3],
  grid.margins.top = grid.margins[3],
 
- {if (o$nrows > 1) rep(c(panel.wrap.size[3], 0, panel.wrap.size[1], between.marginH), o$nrows -1) else NULL},
- panel.wrap.size[3], 0, panel.wrap.size[1],
+ {if (o$nrows > 1) rep(c(panel.wrap.size[3], panel.wrap.margin[3], 0, panel.wrap.margin[1], panel.wrap.size[1], between.marginH), o$nrows -1) else NULL},
+ panel.wrap.size[3], panel.wrap.margin[3], 0, panel.wrap.margin[1], panel.wrap.size[1],
 
  grid.margins.bottom = grid.margins[1],
  grid.buffers.bottom = grid.buffers[1],
@@ -43,8 +43,8 @@ tmapGridInit = function(o, return.asp = FALSE, vp) {
  grid.buffers.left = grid.buffers[2],
  grid.margins.left = grid.margins[2],
 
- {if (o$ncols > 1) rep(c(panel.wrap.size[2], 0, panel.wrap.size[4], between.marginW), o$ncols -1) else NULL},
- panel.wrap.size[2], 0, panel.wrap.size[4],
+ {if (o$ncols > 1) rep(c(panel.wrap.size[2], panel.wrap.margin[2], 0,  panel.wrap.margin[4], panel.wrap.size[4], between.marginW), o$ncols -1) else NULL},
+ panel.wrap.size[2], panel.wrap.margin[2], 0, panel.wrap.margin[4], panel.wrap.size[4],
 
  grid.margins.left = grid.margins[4],
  grid.buffers.left = grid.buffers[4],
@@ -65,8 +65,8 @@ tmapGridInit = function(o, return.asp = FALSE, vp) {
  nr = length(rows)
  nc = length(cols)
 
- cols_facet_ids = 1:o$ncols * 4 + 7
- rows_facet_ids = 1:o$nrows * 4 + 7
+ cols_facet_ids = 1:o$ncols * 6 + 6
+ rows_facet_ids = 1:o$nrows * 6 + 6
 
  #if (o$panel.type == "xtab") {
  cols_panel_col_ids = cols_facet_ids
@@ -75,8 +75,8 @@ tmapGridInit = function(o, return.asp = FALSE, vp) {
  rows_panel_row_ids = rows_facet_ids
  rows_panel_col_id = ifelse(o$panel.xtab.pos[1] == "left", 6, nc - 5)
  #} else if (o$panel.type == "wrap") {
- cols_panel_ids = cols_facet_ids + ifelse(o$panel.wrap.pos == "left", -1, ifelse(o$panel.wrap.pos == "right", 1, 0))
- rows_panel_ids = rows_facet_ids + ifelse(o$panel.wrap.pos == "top", -1, ifelse(o$panel.wrap.pos == "bottom", 1, 0))
+ cols_panel_ids = cols_facet_ids + ifelse(o$panel.wrap.pos == "left", -2, ifelse(o$panel.wrap.pos == "right", 2, 0))
+ rows_panel_ids = rows_facet_ids + ifelse(o$panel.wrap.pos == "top", -2, ifelse(o$panel.wrap.pos == "bottom", 2, 0))
 
  panel_col_rot = 0
  panel_row_rot = ifelse(o$panel.xtab.pos[1] == "left", 90, 270)

R/tmapGridWrap.R

@@ -8,21 +8,26 @@ tmapGridWrap = function(label, facet_row, facet_col, facet_page, o) {
  row = g$rows_panel_ids[facet_row]
  col = g$cols_panel_ids[facet_col]
 
- frame.col = if (isFALSE(o$frame)) o$attr.color else if (isTRUE(o$frame)) o$attr.color else o$frame
+ frame.col = if (isFALSE(o$panel.label.frame)) o$attr.color else if (isTRUE(o$panel.label.frame)) o$attr.color else o$panel.label.frame
+
+ frame.show = !isFALSE(o$panel.label.frame)
 
  #scale = o$scale * o$scale_down
 
- gpar_rect = grid::gpar(fill = o$panel.label.bg.color, lwd=o$frame.lwd * o$scale, col = o$frame)
+ if (frame.show) {
+ gpar_rect = grid::gpar(fill = o$panel.label.bg.color, lwd=o$panel.label.frame.lwd * o$scale, col = frame.col)
+ } 
  gpar_text = rescale_gp(grid::gpar(cex = o$panel.label.size * o$scale, col = o$panel.label.color, fontfamily = o$panel.label.fontfamily, fontface = o$panel.label.fontface), o$scale_down)
 
  # resize due to not fitting
  gpar_text$cex = determine_scale(label = label, rot = rot, row = row, col = col, g = g, scale = gpar_text$cex)
  grb = grid::grobTree(
- rndrectGrob(gp = gpar_rect, r = o$frame.r * o$scale),
+ if (frame.show) {
+ rndrectGrob(gp = gpar_rect, r = o$panel.label.frame.r * o$scale)
+ } else NULL,
  grid::textGrob(label = label, rot = rot, gp = gpar_text)
  )
-
-
+
  gt = add_to_gt(gt, grb, row = row, col = col)
 
  gts[[facet_page]] = gt

R/tmapGrid_misc.R

@@ -74,7 +74,7 @@ gp_to_gpar = function(gp, id = NULL, sel = "all", split_to_n = NULL, pick_middle
  if (pick_middle) {
  x = sapply(x, function(i) {
  if (all(is.na(i))) NA else {
- sq = c(5,6,4,7,3,8,2,9,1,10) # priority for middle values
+ sq = (o$nvv/2) + (rep(0:5,each=2) * c(1,-1))[-1] # priority for middle values
  i[sq[which(!is.na(i)[sq])[1]]]
  }
  })