Merge branch 'master' into bgcol

R/process_meta.R

@@ -67,10 +67,10 @@ preprocess_meta = function(o, cdt) {
 										per_col = any(is.na(cdt$by1__) & !is.na(cdt$by2__) & cdt$class == "autoout"),
 										per_facet = any(!is.na(cdt$by1__) & !is.na(cdt$by2__) & cdt$class == "autoout"))
 			}
-			legend.present.fix = c(any(cdt$class == "out" & cdt$cell.v == "bottom"), 
-								   any(cdt$class == "out" & cdt$cell.h == "left"),
-								   any(cdt$class == "out" & cdt$cell.v == "top"),
-								   any(cdt$class == "out" & cdt$cell.h == "right"))
+			legend.present.fix = c(any(cdt$class == "out" & identical(cdt$cell.v, "bottom")), 
+								   any(cdt$class == "out" & identical(cdt$cell.h, "left")),
+								   any(cdt$class == "out" & identical(cdt$cell.v, "top")),
+								   any(cdt$class == "out" & identical(cdt$cell.h, "right")))
 		}
 
 

R/step1_helper_facets.R

@@ -46,6 +46,7 @@ get_split_stars_dim = function(lst) {
 # ## estimate number of facets
 step1_rearrange_facets = function(tmo, o) {
 	#o = tmap_options_mode()
+	dev = getOption("tmap.devel.mode")
 
 
 	# get the final tm_faets object (ignoring group specific args: is.wrap, by, rows, columns, pages)
@@ -61,6 +62,9 @@ step1_rearrange_facets = function(tmo, o) {
 		shp = tmg$tms$shp
 		smeta = tmapGetShapeMeta1(shp, c(o, tmg$tmf))
 
+		if (dev) timing_add(s3 = "get_shape_meta1")
+
+
 		assign("vl", NULL, envir = .TMAP)
 		assign("vn", 1L, envir = .TMAP)
 
@@ -169,8 +173,7 @@ step1_rearrange_facets = function(tmo, o) {
 				popup.format = process_label_format(popup.format, o$label.format)
 
 				if (!all(popup.vars %in% smeta$vars)) {
-					# TODO add a more informative message that says which variables are incorrect.
-					stop("Incorrrect popup.vars specification", call. = FALSE)
+					rlang::arg_match(popup.vars, values = smeta$vars, multiple = TRUE)
 				}
 				if (length(popup.vars)) add_used_vars(popup.vars)
 
@@ -189,6 +192,8 @@ step1_rearrange_facets = function(tmo, o) {
 		shp = tmapSplitShp(shp, split_stars_dim)
 		if (split_stars_dim != "") {
 			smeta = tmapGetShapeMeta1(shp, o)
+			if (dev) timing_add(s3 = "get_shape_meta1_2")
+
 		}	
 
 
@@ -295,8 +300,10 @@ step1_rearrange_facets = function(tmo, o) {
 
 		smeta$vars = get("used_vars", envir = .TMAP)
 		shp = tmapSubsetShp(shp, smeta$vars)
-
+		if (dev) timing_add(s3 = "subset_shp")
+
 		smeta = tmapGetShapeMeta2(shp, smeta, c(o, tmg$tmf))
+		if (dev) timing_add(s3 = "get_shape_meta2")
 
 
 

R/step1_rearrange.R

@@ -131,7 +131,7 @@ step1_rearrange = function(tmel) {
 
 	# get main crs (used in step 3, not necessarily in the plot (e.g. view mode will use 4326/3857))
 	crs_main = if (any_data_layer) get_crs(tms) else NA
-
+	
 	if (inherits(crs_option, "leaflet_crs")) {
 		crs_leaflet = crs_option
 		crs = leaflet2crs(crs_leaflet)
@@ -152,7 +152,6 @@ step1_rearrange = function(tmel) {
 		main_class = "stars" # basemaps
 	}
 
-
 	if (dev) timing_add(s2 = "facet meta")
 
 
@@ -196,6 +195,7 @@ step1_rearrange = function(tmel) {
 	o$crs_leaflet = crs_leaflet
 	o$crs_main = crs_main
 
+
 	o = c(o, tmf)
 	# process shapes: put non-spatial data in data.table, keep spatial data separately 
 
@@ -239,6 +239,8 @@ 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]])
+
 
 	a = complete_options(a, ot)
 

R/step2_helper_data.R

@@ -17,8 +17,7 @@ update_l = function(o, l, v, mfun) {
 
 	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]])
 
 	l = complete_options(l, oleg)
 	l$call = call
@@ -205,7 +204,6 @@ 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)
 
 
-
 				if (length(s) == 0) stop("mapping not implemented for aesthetic ", nm, call. = FALSE)
 				f = s$FUN
 				s$FUN = NULL

R/step3_trans.R

@@ -47,6 +47,7 @@ step3_trans = function(tm) {
 			if (al$trans_isglobal) shpDT = trans_shp(al, shpDT)
 		}
 
+
 		adi$layers = lapply(adi$layers, function(al) {
 			# step 3.c1: apply non global transformation function
 			if (al$trans_isglobal) {
@@ -68,7 +69,6 @@ step3_trans = function(tm) {
 		adi
 	})
 
-
 	list(tmo = bd, aux = aux, cmp = cmp, o = o)
 }
 

R/step4_plot.R

@@ -699,9 +699,17 @@ step4_plot = function(tm, vp, return.asp, show) {
 
 		legs_out = copy(cdt[!is_in])
 		legs_out[, page:=as.integer(NA)]
-		legs_out[, bbox:=list()]
-		legs_out[, units:=list()]
 
+		# legs_out[, bbox:=list()]
+		# legs_out[, units:=list()]
+
+		# ad-hoc method: take first bbox and units
+		bbox_nb = d$bbox[1]
+		attr(bbox_nb, "borrow") = list(col = d$col[1], row = d$row[1])
+		legs_out[, bbox:=bbox_nb]
+		legs_out[, units:=d$units[1]]
+
+
 		cdt = data.table::rbindlist(c(list(legs_out), legs_in))
 
 		cdt$comp = mapply(function(cmp, bbx, u) {

R/tmapGridAux.R

@@ -37,34 +37,45 @@ tmapGridTilesPrep = function(a, bs, id, o) {
 	}
 
 	xs = mapply(function(b, z) {
-
 		m = tryCatch({
-			maptiles::get_tiles(x = b, provider = a$server[1], zoom = z, crop = FALSE, )	
+			maptiles::get_tiles(x = b, provider = a$server[1], zoom = z, crop = FALSE)	
 		}, error = function(e) {
 			tryCatch({
 				maptiles::get_tiles(x = b, provider = a$server[1], zoom = z - 1, crop = FALSE)	
 			}, error = function(e) {
 				NULL
 			})
 		})
-		names(m)[1:3] = c("red", "green", "blue")
+		if (!is.null(m)) {
+			names(m)[1:3] = c("red", "green", "blue")
+			if (terra::nlyr(m) == 4) names(m)[4] = "alpha"
+
+		} else {
+			message("Tiles from ", a$server[1], " at zoom level ", z, " couldn't be loaded")
+		}
 		m
 	}, bs, zs, SIMPLIFY = FALSE)
 
-	if (isproj) xs = mapply(function(x,b) {
-		ex = terra::ext(as.vector(b[c(1,3,2,4)]))
-		asp = (ex[2] - ex[1]) / (ex[4] - ex[3])
-
-		tot = terra::ncell(x) * 2
-
-		nc = round(sqrt(tot * asp))
-		nr = round(tot / nc)
+	if (isproj) {
+		if (!all(vapply(xs, is.null, FUN.VALUE = logical(1)))) {
+			message("Tiles from ", a$server[1], " will be projected so details (e.g. text) could appear blurry")
+			xs = mapply(function(x,b) {
+				if (is.null(x)) return(NULL)
+
+				ex = terra::ext(as.vector(b[c(1,3,2,4)]))
+				asp = (ex[2] - ex[1]) / (ex[4] - ex[3])
+
+				tot = terra::ncell(x) * 2
+
+				nc = round(sqrt(tot * asp))
+				nr = round(tot / nc)
+
+				r = terra::rast(ex, nrows = nr, ncols = nc, crs = crs$wkt)
+				terra::project(x, r, method = "near")
+			}, xs, bs_orig, SIMPLIFY = FALSE)
+		}
+	}
 
-		r = terra::rast(ex, nrows = nr, ncols = nc, crs = crs$wkt)
-		terra::project(x, r, method = "near")
-	}, xs, bs_orig, SIMPLIFY = FALSE)
-
-
 	ss = lapply(xs, function(x) {
 		if (is.null(x)) NULL else do.call(tmapShape, list(shp = x, is.main = FALSE, crs = crs, bbox = NULL, unit=NULL, filter=NULL, shp_name = "x", smeta = list(), o = o))
 	})
@@ -76,7 +87,12 @@ tmapGridTilesPrep = function(a, bs, id, o) {
 		if (is.null(s)) return(NULL)
 		d = s$dt
 		d[, c("col", "legnr") := do.call(srgb$FUN, list(x1 = red, x2 = green, x3 = blue, scale = srgb, legend = list(), o = o, aes = "col", layer = "raster", sortRev = NA, bypass_ord = TRUE))]
-		d[, col_alpha:=1L]
+		if ("alpha" %in% names(d)) {
+			d[, col_alpha:=alpha/255]
+			d[is.na(col_alpha), col_alpha:=0]
+		} else {
+			d[, col_alpha:=1L]
+		}
 		d
 	})
 
@@ -85,9 +101,11 @@ tmapGridTilesPrep = function(a, bs, id, o) {
 	})
 
 
+	bmaps_shpTHs = structure(list(shpTMs), names = id)
+	bmaps_dts = structure(list(ds), names = id)
 
-	g$bmaps_shpTHs = shpTMs
-	g$bmaps_dts = ds
+	g$bmaps_shpTHs = c(g$bmaps_shpTHs, bmaps_shpTHs)
+	g$bmaps_dts = c(g$bmaps_dts, bmaps_dts)
 
 	assign("g", g, envir = .TMAP_GRID)
 	paste0(a$server, collapse = "__")
@@ -345,8 +363,8 @@ tmapGridGridPrep = function(a, bs, id, o) {
 tmapGridTiles = function(bi, bbx, facet_row, facet_col, facet_page, id, pane, group, o) {
 	g = get("g", envir = .TMAP_GRID)
 
-	dt = g$bmaps_dts[[bi]]
-	shpTM = g$bmaps_shpTHs[[bi]]
+	dt = g$bmaps_dts[[id]][[bi]]
+	shpTM = g$bmaps_shpTHs[[id]][[bi]]
 	gp = list()
 
 	if (!is.null(dt)) tmapGridRaster(shpTM, dt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, o)	

R/tmapGridComp.R

@@ -388,6 +388,9 @@ tmapGridCompWidth.tm_scalebar = function(comp, o) {
 	#textP = comp$padding[c(3,1)] * textS * o$lin
 
 	marW = comp$margins[c(2,4)] * textS * o$lin
+
+
+
 	ws = c(marW[1], 0, marW[2])
 
 	sides = switch(comp$position$align.h, left = "second", right = "first", "both")
@@ -396,7 +399,7 @@ tmapGridCompWidth.tm_scalebar = function(comp, o) {
 
 	comp$Win = sum(ws)
 	comp$wsu = wsu
-	
+
 	# in case breaks are used: adjust the legend width later (in tmapGridLegend)
 	comp$WnativeID = 3
 	if (!is.null(comp$breaks)) {
@@ -422,10 +425,21 @@ tmapGridLegPlot.tm_scalebar = function(comp, o, fH, fW) {
 												   heights = hsu))
 
 
+
 	unit = comp$units$unit
 	unit.size = 1/comp$units$to
-	xrange = comp$bbox[3] - comp$bbox[1]
-	crop_factor = as.numeric(wsu[3]) / fW 
+	#xrange = (comp$bbox[3] - comp$bbox[1]) * fW_fact
+
+	xrange = fW * comp$cpi
+
+	# xrange is the range of the viewport in terms of coordinates
+	# xrange2 is the same but with units (e.g. km instead of m)
+	# W is the targeted space for the scalebar
+
+
+	W = as.numeric(wsu[3])
+
+	crop_factor = W / fW 
 	just = 0
 
 	if (is.na(unit.size)) {
@@ -436,24 +450,30 @@ tmapGridLegPlot.tm_scalebar = function(comp, o, fH, fW) {
 
 	xrange2 = xrange/unit.size
 
-	# to find the label width of first and last item, only used as proxy
-	tcks = pretty(c(0, xrange2*crop_factor), 4)
-	tcksL = format(tcks, trim=TRUE)
-	rngL = c(tcksL[1], paste(unit, tail(tcksL, 1), unit))
-	rngW = ((text_width_inch(rngL) / 2) + o$lin * 0.5) * comp$text.size
-
-	# available width for scale bar
-	sbW = as.numeric(wsu[3]) - sum(rngW)
-
-	crop_factor2 = sbW / fW 
 
 	if (is.null(comp$breaks)) {
-		ticks2 = pretty(c(0, xrange2*crop_factor2), round(comp$width * 8))
+		# determine resolution only (unselect steps that do not fit later (with 'sel'))
+		for (i in 10:1) {
+			tcks = pretty(c(0, xrange2*crop_factor), i)
+			tcks3 = (tcks / xrange2) * fW
+			tcksL = format(tcks, trim=TRUE)
+			labW = text_width_inch(tcksL) * comp$text.size
+			tickW = tcks3[-1] - head(tcks3, -1)
+			if (all(tickW > labW[-1])) {
+				sbW = W - labW
+				break
+			}
+		}
+		ticks2 = tcks
 	} else {
 		ticks2 = comp$breaks
+		tcksL = format(ticks2, trim=TRUE)
+
+		labW = text_width_inch(tcksL) * comp$text.size
+		sbW = W - labW
 	}
 
-	ticks3 = ticks2 / xrange2 * fW #   (ticks2*unit.size / xrange) * as.numeric(wsu[3])
+	ticks3 = ticks2 / xrange2 * fW
 	sel = which(ticks3 <= sbW)
 
 	if (!is.null(comp$breaks) && length(sel) != length(ticks3)) {