From 2e467c0a7209bf483a905145b1964adfef3d7455 Mon Sep 17 00:00:00 2001 From: mtennekes Date: Fri, 24 May 2024 15:54:52 +0200 Subject: [PATCH] #879 --- R/messages.R | 14 +++++++++- R/process_meta.R | 33 ++++++++++++++++-------- R/step1_rearrange.R | 5 +++- R/step2_helper_data.R | 60 ++++++++++++++++++++++++++++--------------- R/tm_pos.R | 2 +- R/tmapGridInit.R | 6 ++--- 6 files changed, 83 insertions(+), 37 deletions(-) diff --git a/R/messages.R b/R/messages.R index ba16795f..de6bbba1 100644 --- a/R/messages.R +++ b/R/messages.R @@ -45,6 +45,7 @@ message_nothing_to_show = function(any_groups) { } else { message("[nothing to show] no layers defined") } + NULL } message_wrapstack = function(horizontal = TRUE) { @@ -53,5 +54,16 @@ message_wrapstack = function(horizontal = TRUE) { } else { message("[facets] use tm_facets_vstack() instead of tm_facets_wrap() to put the legends next to and aligned with the facets") } - + NULL +} + +message_pos_auto = function(type) { + if (!message_thrown("pos_auto")) { + fun = if (type == "autoout") "tm_pos_auto_out()" else "tm_pos_auto_in()" + fun2 = if (type == "autoout") "tm_pos_out()" else "tm_pos_in()" + message("[position] ", "use ", fun2, " instead of ", fun, ". The latter should be used with tmap_options().") + message_reg("pos_auto") + } + NULL } + diff --git a/R/process_meta.R b/R/process_meta.R index 529a75cf..b19050e9 100644 --- a/R/process_meta.R +++ b/R/process_meta.R @@ -379,13 +379,22 @@ process_meta = function(o, d, cdt, aux) { margins.used = margins.used.all | margins.used.sides | legend.present.fix # tm_shape(World) + tm_polygons(fill = "HPI", lwd = "life_exp") - - + if (nrow(cdt)) { cdt2 = data.table::copy(cdt[cdt$class %in% c("autoout", "out"),]) # CODE COPIED FROM STEP4_plot L157 # TO DO: fix this + if (o$type != "grid" && o$n > 1) { + #if (o$nrows == 1 && o$ncols == 1) + if (identical(orientation, "horizontal")) { + # -use by2 and not by1 when they form a row + cdt2[, by2__ := by1__] + cdt2[, by1__ := NA] + } + } + + stacks = o$legend.stack cdt2[is.na(by1__) & is.na(by2__) & class == "autoout", ':='(cell.h = legend.position.all$cell.h, cell.v = legend.position.all$cell.v)] @@ -410,18 +419,22 @@ process_meta = function(o, d, cdt, aux) { cdt2[is.na(by1__), by1__:=1] + po(meta.auto.margins) meta.auto.margins = pmin(meta.auto.margins, do.call(pmax, lapply(unique(cdt2$by1__), function(b1) { cdt2b = cdt2[by1__==b1, ] - cdt2b[stack_auto == TRUE, stack:= ifelse(n==1, ifelse(cell.h %in% c("left", "right"), o$legend.stack["all_row"], o$legend.stack["all_col"]), ifelse(orientation == "vertical", o$legend.stack["per_row"], o$legend.stack["per_col"]))] - c(sum(c(0,cdt2b[cell.v == "bottom" & stack == "vertical", legH,by = c("cell.h", "cell.v")]$legH), + cdt2b[stack_auto == TRUE, stack:= ifelse(n==1, ifelse(cell.h %in% c("left", "right"), o$legend.stack["all_row"], o$legend.stack["all_col"]), ifelse(orientation == "vertical", o$legend.stack["per_row"], o$legend.stack["per_col"]))] + + print(cdt2b) + + c(sum(sum(c(0,cdt2b[cell.v == "bottom" & stack == "vertical", legH,by = c("cell.h", "cell.v")]$legH)), max(c(0,cdt2b[cell.v == "bottom" & stack == "horizontal", legH,by = c("cell.h", "cell.v")]$legH))) / o$devsize[2], - sum(c(0,cdt2b[cell.h == "left" & stack == "horizontal", legW,by = c("cell.h", "cell.v")]$legW), + sum(sum(c(0,cdt2b[cell.h == "left" & stack == "horizontal", legW,by = c("cell.h", "cell.v")]$legW)), max(c(0,cdt2b[cell.h == "left" & stack == "vertical", legW,by = c("cell.h", "cell.v")]$legW))) / o$devsize[1], - sum(c(0,cdt2b[cell.v == "top" & stack == "vertical", legH,by = c("cell.h", "cell.v")]$legH), + sum(sum(c(0,cdt2b[cell.v == "top" & stack == "vertical", legH,by = c("cell.h", "cell.v")]$legH)), max(c(0,cdt2b[cell.v == "top" & stack == "horizontal", legH,by = c("cell.h", "cell.v")]$legH))) / o$devsize[2], - sum(c(0,cdt2b[cell.h == "right" & stack == "horizontal", legW,by = c("cell.h", "cell.v")]$legW), + sum(sum(c(0,cdt2b[cell.h == "right" & stack == "horizontal", legW,by = c("cell.h", "cell.v")]$legW)), max(c(0,cdt2b[cell.h == "right" & stack == "vertical", legW,by = c("cell.h", "cell.v")]$legW))) / o$devsize[1]) }))) } else { @@ -435,6 +448,7 @@ process_meta = function(o, d, cdt, aux) { # add margins (compensate for legend frames) # the final calculations of these margins are computed in tmapGridLegend (this is just to compute the meta.auto.margins) # those calculations are take the component.offset into account + sel_tb = c(3,1)[meta.auto.margins[c(3,1)]!=0] sel_lr = c(2,4)[meta.auto.margins[c(2,4)]!=0] if (length(sel_tb)) meta.auto.margins[sel_tb] = meta.auto.margins[sel_tb] + 2 * (o$frame.lwd * o$scale / 144) / o$devsize[2] @@ -464,7 +478,7 @@ process_meta = function(o, d, cdt, aux) { } else { meta.margins[margins.used] = meta.auto.margins[margins.used] } - + # redo calculations meta.buffers = sign(meta.margins) * c(bufferH, bufferW, bufferH, bufferW) # outside and inside fixedMargins = outer.margins + meta.buffers * 2 + meta.margins + xylab.margins + panel.xtab.size + grid.buffers + grid.margins @@ -474,8 +488,7 @@ process_meta = function(o, d, cdt, aux) { meta.margins = c(0, 0, 0, 0) } - - + # determine number of rows and cols if (type == "grid") { nrows = nby[1] diff --git a/R/step1_rearrange.R b/R/step1_rearrange.R index 6f27d9d2..4c291b75 100644 --- a/R/step1_rearrange.R +++ b/R/step1_rearrange.R @@ -241,7 +241,10 @@ impute_comp = function(a, o) { # special case: position, in case c("left", "top") is used if (is.character(a$position)) a$position = str2pos(a$position) if (is.numeric(a$position)) a$position = num2pos(a$position) - if (inherits(a$position, "tm_pos")) a$position = complete_options(a$position, o$component.position[[a$position$type]]) + if (inherits(a$position, "tm_pos")) { + a$position = complete_options(a$position, o$component.position[[a$position$type]]) + if (a$position$type %in% c("autoin", "autoout")) message_pos_auto(a$position$type) + } a = complete_options(a, ot) diff --git a/R/step2_helper_data.R b/R/step2_helper_data.R index 083238e7..732fa0aa 100644 --- a/R/step2_helper_data.R +++ b/R/step2_helper_data.R @@ -14,11 +14,15 @@ update_l = function(o, l, v, mfun) { settings_name = paste0("legend.settings.", l$design, ".", l$orientation) oleg = c(oleg, o[[settings_name]]) - + if ("position" %in% names(l) && is.character(l$position)) l$position = str2pos(l$position) if ("position" %in% names(l) && is.numeric(l$position)) l$position = num2pos(l$position) - if ("position" %in% names(l) && inherits(l$position, "tm_pos")) l$position = complete_options(l$position, o$component.position[[l$position$type]]) + if ("position" %in% names(l) && inherits(l$position, "tm_pos")) { + l$position = complete_options(l$position, o$component.position[[l$position$type]]) + if (l$position$type %in% c("autoin", "autoout")) message_pos_auto(l$position$type) + } + l = complete_options(l, oleg) l$call = call l$mfun = mfun @@ -41,7 +45,10 @@ update_crt = function(o, crt, v, mfun) { if ("position" %in% names(crt) && is.character(crt$position)) crt$position = str2pos(crt$position) if ("position" %in% names(crt) && is.numeric(crt$position)) crt$position = num2pos(crt$position) - + if ("position" %in% names(crt) && inherits(crt$position, "tm_pos")) { + l$position = complete_options(crt$position, o$component.position[[crt$position$type]]) + if (crt$position$type %in% c("autoin", "autoout")) message_pos_auto(crt$position$type) + } crt = complete_options(crt, ocrt) crt$call = call @@ -60,6 +67,13 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) nm = aes$aes nm__ord = paste0(nm, "__ord") + + #nm and unm are both visual variables + #nm is the 'prototype', for which methods are written (tmapScale_defaults.R) + #unm is the name known by the user, so used in messaging and also as identifier in data + + unm__ord = paste0(unm, "__ord") + # should the results of the data (needed for the plotting function)? # sorting order will be plotting order # -1 for NULL features (filtered out, or dropped units) @@ -91,8 +105,12 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) sfun = paste0("tmapValuesScale_", nm) cfun = paste0("tmapValuesColorize_", nm) - #print(vars) - if (!aes$data_vars && !aes$geo_vars) { + + if (inherits(val, "tmapUsrCls")) { + # not data driven variable: visual variable to support tm_mv of other visual variable (e.g. fill of donut maps) + dtl = data.table::data.table() + + } else if (!aes$data_vars && !aes$geo_vars) { #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) @@ -126,10 +144,10 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) if (length(v)) update_fl(k = v, m = nvars) if (nvars > 1) { - dtl = melt(dtl, id.vars = c("tmapID__", "sel__", by123__[b]), measure.vars = vnames, variable.name = var__, value.name = nm) + dtl = melt(dtl, id.vars = c("tmapID__", "sel__", by123__[b]), measure.vars = vnames, variable.name = var__, value.name = unm) dtl[, (var__) := as.integer(get(..var__))] } else { - setnames(dtl, vnames[1], nm) + setnames(dtl, vnames[1], unm) } # impute null (filter argument of tm_shape) with value.null @@ -137,18 +155,18 @@ 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]]) + cls = data_class(dtl[[unm]]) 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)) # todo: combine these: - dtl[sel__==FALSE, (nm) := value.null] + dtl[sel__==FALSE, (unm) := value.null] if (!bypass_ord) dtl[sel__==FALSE, (nm__ord) := -1L] if (!q$drop.units) { - imp = structure(list(value.null, -1L, FALSE), names = c(nm, {if (bypass_ord) NULL else nm__ord}, "sel__")) + imp = structure(list(value.null, -1L, FALSE), names = c(unm, {if (bypass_ord) NULL else nm__ord}, "sel__")) levs = lapply(get_num_facets(grp_bv), seq.int, from = 1) names(levs) = grp_bv dtl = completeDT2(dtl, cols = c(list("tmapID__" = unique(dtl$tmapID__)), levs), defs = imp) @@ -160,7 +178,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) dtl[, crtnr := vector("integer", length = nrow(dtl))] - 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] + dtl_leg = dtl[, .SD[1], by = c(grp_bv)][, tmapID__ := NULL][, legnr := (vapply(get(..unm), function(s) legend_save(list(vneutral = s)), FUN.VALUE = integer(1)))][, crtnr := (vapply(get(..unm), function(s) chart_save(list()), FUN.VALUE = integer(1)))][, (unm) := NULL] } else { #cat("step2_grp_lyr_aes_var", nm," \n") @@ -240,7 +258,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) l = update_l(o = o, l = l, v = v, mfun = mfun) crt = update_crt(o = o, crt = crt, v = v, mfun = mfun) - if (length(s) == 0) stop("mapping not implemented for aesthetic ", nm, call. = FALSE) + if (length(s) == 0) stop("mapping not implemented for aesthetic ", unm, call. = FALSE) f = s$FUN s$FUN = NULL # update label.format @@ -291,7 +309,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) dtl[, c(varname, ordname, legname, crtname) := list(value.null, -1L, 0L, 0L)] } - if (is.na(value.null)) stop("value.null not specified for aesthetic ", nm, call. = FALSE) + if (is.na(value.null)) stop("value.null not specified for aesthetic ", unm, call. = FALSE) if (bypass_ord) { dtl[sel__ == TRUE, c(varname, legname, crtname) := do.call(f, c(unname(.SD), arglist)), grp_b_fr, .SDcols = v] } else { @@ -305,7 +323,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) } } if (!q$drop.units) { - imp = structure(list(value.null, 0L, TRUE), names = c(nm, legname, "sel__")) + imp = structure(list(value.null, 0L, TRUE), names = c(unm, legname, "sel__")) levs = lapply(get_num_facets(grp_bv), seq.int, from = 1) names(levs) = grp_bv dtl = completeDT2(dtl, cols = c(list("tmapID__" = unique(dtl$tmapID__)), levs), defs = imp) @@ -341,8 +359,8 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) } - varnames = paste(nm, 1L:nvars, sep = "_") - ordnames = paste(nm__ord, 1L:nvars, sep = "_") + varnames = paste(unm, 1L:nvars, sep = "_") + ordnames = paste(unm__ord, 1L:nvars, sep = "_") legnames = paste("legnr", 1L:nvars, sep = "_") crtnames = paste("crtnr", 1L:nvars, sep = "_") @@ -353,7 +371,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) dtl_leg = melt(dtl, id.vars = c("tmapID__", by__), measure.vars = legnames, variable.name = var__, value.name = "legnr") dtl_crt = melt(dtl, id.vars = c("tmapID__", by__), measure.vars = crtnames, variable.name = var__, value.name = "crtnr") if (!bypass_ord) dtl_ord = melt(dtl, id.vars = c("tmapID__", by__), measure.vars = ordnames, variable.name = var__, value.name = nm__ord) - dtl = melt(dtl, id.vars = c("tmapID__", by__), measure.vars = varnames, variable.name = var__, value.name = nm) + dtl = melt(dtl, id.vars = c("tmapID__", by__), measure.vars = varnames, variable.name = var__, value.name = unm) if (!bypass_ord) dtl[, (nm__ord) := dtl_ord[[nm__ord]]] dtl[, (var__) := as.integer(get(..var__))] @@ -375,7 +393,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) stop("incorrect scale specification") } - if (length(s) == 0) stop("mapping not implemented for aesthetic ", nm, call. = FALSE) + if (length(s) == 0) stop("mapping not implemented for aesthetic ", unm, call. = FALSE) if (inherits(aes$legend, "tm_legend")) { l = aes$legend @@ -395,7 +413,7 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) stop("incorrect chart specification") } - dtl = apply_scale(s, l, crt, val, nm, nm__ord, "legnr", "crtnr", sortRev, bypass_ord) + dtl = apply_scale(s, l, crt, val, unm, nm__ord, "legnr", "crtnr", sortRev, bypass_ord) #sel = !vapply(dtl$legend, is.null, logical(1)) dtl_leg = dtl[legnr != 0L, c(grp_bv_fr, "legnr", "crtnr"), with = FALSE] @@ -404,10 +422,10 @@ getdts = function(aes, unm, p, q, o, dt, shpvars, layer, mfun, args, plot.order) if (dev) timing_add(s4 = paste0("aes ", aes$aes)) if (bypass_ord) { - list(dt = dtl[, c("tmapID__", grp_bv, nm), with = FALSE], + list(dt = dtl[, c("tmapID__", grp_bv, unm), with = FALSE], leg = dtl_leg) } else { - list(dt = dtl[, c("tmapID__", grp_bv, nm, nm__ord), with = FALSE], + list(dt = dtl[, c("tmapID__", grp_bv, unm, nm__ord), with = FALSE], leg = dtl_leg) } }) diff --git a/R/tm_pos.R b/R/tm_pos.R index e125bb68..0ed2bde4 100644 --- a/R/tm_pos.R +++ b/R/tm_pos.R @@ -5,7 +5,7 @@ #' `tm_pos_out()` places the components outside the map area and `tm_pos_in()` inside the map area. #' Each `position` argument of a map layer or component should be specified with #' one of these functions. The functions `tm_pos_auto_out()` and `tm_pos_auto_in()` -#' are used to set the components automatically, and are recommended to use globally, +#' are used to set the components automatically, and should be used #' via [tmap_options()]. See Details how the positioning works. #' #' @param cell.h,cell.v The plotting area is overlaid with a 3x3 grid, of which diff --git a/R/tmapGridInit.R b/R/tmapGridInit.R index b2d0db89..4178cdc5 100644 --- a/R/tmapGridInit.R +++ b/R/tmapGridInit.R @@ -13,7 +13,7 @@ tmapGridInit = function(o, return.asp = FALSE, vp) { grid.margins.top = grid.margins[3], {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], + 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], 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], + {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],