#879

r-tmap · May 24, 2024 · 2e467c0 · 2e467c0
1 parent ac80017
commit 2e467c0
Show file tree

Hide file tree

Showing 6 changed files with 83 additions and 37 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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,29 +144,29 @@ 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					
 			if (!bypass_ord) dtl[, (nm__ord) := 1L]
 
 			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
@@ -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
@@ -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],