From 624c4a9f07bc82377d91dece502a35613452e0ff Mon Sep 17 00:00:00 2001 From: mtennekes Date: Wed, 25 Sep 2024 19:56:25 +0200 Subject: [PATCH] #937 fixed tm_facets_pagewise --- R/process_meta.R | 262 ++++++++++++++++++++-------------------- R/tm_facets.R | 26 ++-- R/tmapScaleContinuous.R | 196 ++++++++++++++++-------------- R/tmapScaleIntervals.R | 88 +++++++------- 4 files changed, 291 insertions(+), 281 deletions(-) diff --git a/R/process_meta.R b/R/process_meta.R index ceb3bac8..7057b556 100644 --- a/R/process_meta.R +++ b/R/process_meta.R @@ -1,5 +1,5 @@ prepreprocess_meta = function(o, vp) { - + within(o, { vp = vp if (is.null(vp)) { @@ -9,10 +9,10 @@ prepreprocess_meta = function(o, vp) { devsize = c(grid::convertWidth(grid::unit(1, "npc"), unitTo = "inch", valueOnly = TRUE), grid::convertHeight(grid::unit(1, "npc"), unitTo = "inch", valueOnly = TRUE)) } - + # dasp device aspect ratio dasp = devsize[1] / devsize[2] - + # needed for spnc viewport (to retain aspect ratio) if (dasp > 1) { cw = dasp @@ -21,17 +21,17 @@ prepreprocess_meta = function(o, vp) { ch = 1/dasp cw = 1 } - - + + lin = graphics::par("cin")[2]# * scale lineH = lin / devsize[2] * scale lineW = lin / devsize[1] * scale - + # not needed? #nlinesH = 1/lineH #nlinesW = 1/lineW - + }) } preprocess_meta = function(o, cdt) { @@ -39,10 +39,10 @@ preprocess_meta = function(o, cdt) { nby = fn #get_nby(fl) 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]) || !o$panel.show, "none", - ifelse((type %in% c("wrap", "stack")) || (n == 1), "wrap", "xtab")) - + + if (is.na(panel.type)) panel.type = ifelse(((type == "page" || n == 1) && is.na(panel.labels[[1]]) && !identical(panel.show, TRUE)) || ((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) || (type == "page" && identical(panel.show, TRUE)), "wrap", "xtab")) + inner.margins = get_option_class(inner.margins, class = main_class) # legend.present.auto: @@ -50,32 +50,32 @@ preprocess_meta = function(o, cdt) { # use them to automatically determine meta.margins (in preprocess_meta) # # legend.present.fix # find legend boxes that are assigned to outer margins - + if (nrow(cdt) == 0) { legend.present.auto = c(all = FALSE, per_row = FALSE, per_col = FALSE, per_facet = FALSE) legend.present.fix = rep(FALSE, 4) } else { if (type %in% c("wrap", "stack", "page")) { #o$legend.present.auto = c(all = any(is.na(cdt$by1__) & cdt$class == "autoout"), per_row = any(!is.na(cdt$by1__) & cdt$class == "autoout"), per_col = FALSE) - legend.present.auto = c(all = any(cdt$class == "autoout" & is.na(cdt$by1__)), - per_row = FALSE, per_col = FALSE, + legend.present.auto = c(all = any(cdt$class == "autoout" & is.na(cdt$by1__)), + per_row = FALSE, per_col = FALSE, per_facet = any(cdt$class == "autoout" & !is.na(cdt$by1__))) } else { - legend.present.auto = c(all = any(is.na(cdt$by1__) & is.na(cdt$by2__) & cdt$class == "autoout"), - per_row = any(!is.na(cdt$by1__) & is.na(cdt$by2__) & cdt$class == "autoout"), + legend.present.auto = c(all = any(is.na(cdt$by1__) & is.na(cdt$by2__) & cdt$class == "autoout"), + per_row = any(!is.na(cdt$by1__) & is.na(cdt$by2__) & cdt$class == "autoout"), 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"), + 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")) } - - + + # in case there are per-facet legends but no no marginal legends, and nrows or ncols equals 1, place them outside (to do this, set them to all-facet here, change legend.position.all below accordingly, and finally determine legend position in step4_plot) if (legend.present.auto[4] && (!any(legend.present.auto[2:3]))) { - + if (type == "stack") { legend.present.auto[1] = TRUE legend.present.auto[4] = FALSE @@ -86,7 +86,7 @@ preprocess_meta = function(o, cdt) { } else { set_to_stack_message = FALSE } - + }) } @@ -106,27 +106,27 @@ process_meta = function(o, d, cdt, aux) { fixedMargins = outer.margins + meta.buffers * 2 + meta.margins nrows = 1L ncols = 1L - + between.marginH = between.margin * lineH between.marginW = between.margin * lineW - - + + #overall scale down factor for facets width_forn = max(1e-9, ((1 - sum(fixedMargins[c(2, 4)])) - (ncols * sum(panel.wrap.size[c(2,4)])) - (ncols - 1) * between.marginW) / ncols) width_for1 = max(1e-9, ((1 - sum(fixedMargins[c(2, 4)])) - (sum(panel.wrap.size[c(2,4)])))) - + height_forn = max(1e-9, ((1 - sum(fixedMargins[c(1, 3)])) - (nrows * sum(panel.wrap.size[c(1,3)])) - (nrows - 1) * between.marginH) / nrows) height_for1 = max(1e-9, ((1 - sum(fixedMargins[c(1, 3)])) - (sum(panel.wrap.size[c(1,3)])))) - + scale_down = (1 / sqrt((width_for1 * height_for1) / (width_forn * height_forn))) ^ (1 / scale.factor) - + })) } - + gs = tmap_graphics_name() - - # add tm_grid values to o + + # add tm_grid values to o gid = which(vapply(aux, FUN = inherits, "tm_grid", FUN.VALUE = logical(1)))[1] if (!is.na(gid)) { a = aux[[gid]]$args @@ -134,17 +134,17 @@ process_meta = function(o, d, cdt, aux) { a$group = NULL o[paste0("grid.", names(a))] = a } - + # add credits into to o (for view mode in order to reset default attribution text) cid = which(vapply(cdt$comp, FUN = inherits, "tm_credits", FUN.VALUE = logical(1)))[1] o$credits.defined = (!is.na(cid)) - + bbx = d$bbox[[1]] within(o, { # sasp shape aspect ratio (NA if free coordinates) diff_asp = any(d$asp != d$asp[1]) sasp = ifelse(diff_asp, NA, d$asp[1]) - + # preferred aspect ratio (just for this function): if asp is defined (not 0 or NA), use that, otherwise use sasp (shape asp) if available (if not; 1) pasp = if (is.na(sasp)) { if (!is.na(asp) && asp > 0) { @@ -159,47 +159,47 @@ process_meta = function(o, d, cdt, aux) { sasp } } - - + + if (gs == "Grid") { - + bufferH = lineH / 2 bufferW = lineW / 2 - + # calculate space for margins, panels, etc - + meta.automatic = is.na(meta.margins[1]) - + #one.row = (!is.na(o$nrows) && o$nrows == 1) #one.col = (!is.na(o$ncols) && o$ncols == 1) - + if (meta.automatic) meta.margins = c(0, 0, 0, 0) else meta.margins = rep(meta.margins, length.out = 4) - + meta.buffers = sign(meta.margins) * c(bufferH, bufferW, bufferH, bufferW) # outside and inside - + panel.xtab.size = if (panel.type == "xtab") { c(ifelse("bottom" %in% panel.xtab.pos, panel.label.height * lineH, 0), ifelse("left" %in% panel.xtab.pos, panel.label.height * lineW, 0), ifelse("top" %in% panel.xtab.pos, panel.label.height * lineH, 0), ifelse("right" %in% panel.xtab.pos, panel.label.height * lineW, 0)) } else c(0, 0, 0, 0) - + panel.margin = get_option_class(panel.margin, panel.type, spatial_class = FALSE) - + panel.xtab.margin = if (panel.type == "xtab") { c(ifelse("bottom" %in% panel.xtab.pos, panel.margin * lineH, 0), ifelse("left" %in% panel.xtab.pos, panel.margin * lineW, 0), ifelse("top" %in% panel.xtab.pos, panel.margin * lineH, 0), ifelse("right" %in% panel.xtab.pos, panel.margin * lineW, 0)) } else c(0, 0, 0, 0) - + panel.wrap.margin = if (panel.type == "wrap") { c(ifelse(panel.wrap.pos == "bottom", panel.margin * lineH, 0), ifelse(panel.wrap.pos == "left", panel.margin * lineW, 0), ifelse(panel.wrap.pos == "top", panel.margin * lineH, 0), ifelse(panel.wrap.pos == "right", panel.margin * lineW, 0)) } else c(0, 0, 0, 0) - + panel.wrap.size = if (panel.type == "wrap") { c(ifelse(panel.wrap.pos == "bottom", panel.label.height * lineH, 0), @@ -207,7 +207,7 @@ process_meta = function(o, d, cdt, aux) { ifelse(panel.wrap.pos == "top", panel.label.height * lineH, 0), ifelse(panel.wrap.pos == "right", panel.label.height * lineW, 0)) } else c(0, 0, 0, 0) - + xylab.margins = rep(0, 4) if (xlab.show) { xylab.margins[ifelse(xlab.side == "bottom", 1, 3)] = if (xlab.rotation %in% c(0, 180)) { @@ -223,16 +223,16 @@ process_meta = function(o, d, cdt, aux) { (text_width_inch(ylab.text, space = FALSE) / lin) * lineW } } - - + + grid.buffers = if (grid.show) { as.integer(c("bottom", "left", "top", "right") %in% grid.labels.pos) * c(bufferH, bufferW, bufferH, bufferW) } else { rep(0, 4) } - - - + + + 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) @@ -242,16 +242,16 @@ process_meta = function(o, d, cdt, aux) { } lineHin <- convertHeight(unit(grid.labels.size, "lines"), "inch", valueOnly=TRUE) - + 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( @@ -259,22 +259,22 @@ process_meta = function(o, d, cdt, aux) { stringWidth(do.call("fancy_breaks", c( list(vec=gridy, intervals=FALSE), grid.labels.format))), "inch", valueOnly = TRUE) ) - + ybbstringWin = ybbstringWin * 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 + + marks_new = c(xgridHin, ygridWin, xgridHin, ygridWin) / lin grid.margins = as.integer(c("bottom", "left", "top", "right") %in% grid.labels.pos) * marks_new * c(lineH, lineW, lineH, lineW) } else { grid.margins = rep(0, 4) } - + between.marginH = between.margin * lineH between.marginW = between.margin * lineW - + fixedMargins = outer.margins + meta.buffers * 2 + meta.margins + xylab.margins + panel.xtab.size + grid.buffers + grid.margins } else { #if (gs == "Leaflet") { grid.buffers = rep(0, 4) @@ -285,56 +285,56 @@ process_meta = function(o, d, cdt, aux) { between.marginH = 0 between.marginW = 0 } - + masp = ((1 - sum(fixedMargins[c(2, 4)])) / (1 - sum(fixedMargins[c(1, 3)]))) * dasp - + # Aspect ratios: # sasp: shape # asp: user specified # pasp: prefered (asp or if not specified, sasp) # masp: multiples (facets) area - + # determine where to place automatic legends (i.e. legends with local legend.position = NA and with legend.position = tm_pos_auto_out() enabled) # this is also neede to find out which margins are taken from meta.auto.margins - + legend.position.sides = legend.position legend.position.all = legend.position - + # legsG = cdt[, leg] - + # determine orientation of stacked maps # it also implies where legends will be drawn: horizontal orientation=legends bottom or top, vertical orientation=legends left or right # !!! this also applies for single maps mx_width = (1 - sum(fixedMargins[c(1, 3)])) * devsize[1] mx_height = (1 - sum(fixedMargins[c(2, 4)])) * devsize[2] - + # cdt[, scale := pmax(legW/mx_width, legH/mx_height, 1)] # cdt[, ":="(legW_sc = legW/scale, legH_sc = legH/scale)] - - + + if (gs == "Grid") { if (type %in% c("stack", "page")) { if (is.na(orientation)) { if (nrow(cdt)) { - legs_auto = cdt[class=="autoout"] + legs_auto = cdt[class=="autoout"] } else { legs_auto = cdt } - - + + if (type == "page" || (nrow(legs_auto) && n == 1)) { - - legWmax = min(max(legs_auto$legW) / devsize[1], max(meta.auto.margins[c(2,4)])) + + legWmax = min(max(legs_auto$legW) / devsize[1], max(meta.auto.margins[c(2,4)])) legHmax = min(max(legs_auto$legH) / devsize[2], max(meta.auto.margins[c(1,3)])) - - + + av_width = mx_width - legWmax * devsize[1] av_height = mx_height - legHmax * devsize[2] - + shp_height_hor = if ((av_width / mx_height) < pasp) av_width / pasp else mx_height shp_height_ver = if ((mx_width / av_height) < pasp) mx_width / pasp else av_height - + orientation = if (shp_height_hor >= shp_height_ver) "vertical" else "horizontal" } else { orientation = if ((n == 1 && (pasp > masp)) || (n > 1 && (pasp < masp))) "horizontal" else "vertical" @@ -344,7 +344,7 @@ process_meta = function(o, d, cdt, aux) { } else { #if (gs == "Leaflet") { orientation = if ((n == 1 && (pasp > masp)) || (n > 1 && (pasp < masp))) "horizontal" else "vertical" } - + if (gs == "Grid") { ## find position for all-facet legend if (legend.present.auto[1]) { @@ -357,32 +357,32 @@ process_meta = function(o, d, cdt, aux) { legend.position.all = list(cell.h = legend.position$cell.h, cell.v = "center") } } else if (legend.present.auto[2] & !legend.present.auto[3]) { - # central goes center bottom + # central goes center bottom legend.position.all = list(cell.h = "center", cell.v = legend.position$cell.v) } else if (!legend.present.auto[2] & legend.present.auto[3]) { - # central goes right center + # central goes right center legend.position.all = list(cell.h = legend.position$cell.h, cell.v = "center") } } - + margins.used.all = c(legend.position.all$cell.v == "bottom", legend.position.all$cell.h == "left", legend.position.all$cell.v == "top", legend.position.all$cell.h == "right") * legend.present.auto[1] - + margins.used.sides = c(bottom = legend.position.sides$cell.v == "bottom", left = legend.position.sides$cell.h == "left", top = legend.position.sides$cell.v == "top", right = legend.position.sides$cell.h == "right") * legend.present.auto[c(3,2,3,2)] - - + + 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) { @@ -391,39 +391,39 @@ process_meta = function(o, d, cdt, aux) { # -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)] cdt2[!is.na(by1__) & is.na(by2__) & class == "autoout", ':='(cell.h = legend.position.sides$cell.h, cell.v = "by")] cdt2[is.na(by1__) & !is.na(by2__) & class == "autoout", ':='(cell.h = "by", cell.v = legend.position.sides$cell.v)] - + cdt2[is.na(by1__) & is.na(by2__) & class == "autoout", ':='(stack = ifelse(stack_auto, ifelse(cell.h == "center", stacks["all_col"], ifelse(cell.v == "center", stacks["all_row"], stacks["all"])), stack))] cdt2[!is.na(by1__) & is.na(by2__) & class == "autoout", ':='(stack = ifelse(stack_auto, stacks["per_row"], stack))] cdt2[is.na(by1__) & !is.na(by2__) & class == "autoout", ':='(stack = ifelse(stack_auto, stacks["per_col"], stack))] - - + + cdt2[class == "autoout", class := "out"] - - - + + + if (nrow(cdt2) == 0) { meta.auto.margins = c(0, 0, 0, 0) } else { if (type == "stack") { # workaround: stacking mode is determined later (step4 L156), because it requires ncols and nrows # for stack, this is already known, so therefore we can better estimate the meta width and height - + cdt2[is.na(by1__), by1__:=1] - + 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"]))] - + 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(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(sum(c(0,cdt2b[cell.h == "left" & stack == "horizontal", legW,by = c("cell.h", "cell.v")]$legW)), @@ -434,24 +434,24 @@ process_meta = function(o, d, cdt, aux) { max(c(0,cdt2b[cell.h == "right" & stack == "vertical", legW,by = c("cell.h", "cell.v")]$legW))) / o$devsize[1]) }))) } else { - meta.auto.margins = pmin(meta.auto.margins, + meta.auto.margins = pmin(meta.auto.margins, c(max(cdt$legH[cdt$cell.v == "bottom" & cdt$class %in% c("autoout", "out")], 0) / o$devsize[2], max(cdt$legW[cdt$cell.h == "left" & cdt$class %in% c("autoout", "out")], 0) / o$devsize[1], max(cdt$legH[cdt$cell.v == "top" & cdt$class %in% c("autoout", "out")], 0) / o$devsize[2], max(cdt$legW[cdt$cell.h == "right" & cdt$class %in% c("autoout", "out")], 0) / o$devsize[1])) } - + # 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] if (length(sel_lr)) meta.auto.margins[sel_lr] = meta.auto.margins[sel_lr] + 2 * (o$frame.lwd * o$scale / 144) / o$devsize[1] } } - + if (meta.automatic && any(margins.used)) { meta.auto.margins = rep(meta.auto.margins, length.out = 4) if (all(!margins.used[c(1,3)]) && n == 1) { @@ -483,12 +483,12 @@ process_meta = function(o, d, cdt, aux) { meta.buffers = c(0, 0, 0, 0) meta.margins = c(0, 0, 0, 0) } - + # determine number of rows and cols if (type == "grid") { nrows = nby[1] - ncols = nby[2] + ncols = nby[2] } else if (type == "page") { nrows = 1 ncols = 1 @@ -506,44 +506,44 @@ process_meta = function(o, d, cdt, aux) { } else if (!is.na(nrows) && is.na(ncols)) { ncols = ceiling((nby[1] / nrows)) } else if (is.na(nrows) && is.na(ncols)) { - + # loop through col row combinations to find best nrow/ncol # b needed to compare landscape vs portrait. E.g if prefered asp is 2, 1 is equally good as 4 ncols = which.min(vapply(1L:n, function(nc) { nr = ceiling(n / nc) - + # calculate available width and height. They can be negative, at this stage this is avoided my taking at least a small number width = max(1e-9, ((1 - sum(fixedMargins[c(2, 4)])) - (nc * sum(panel.wrap.size[c(2,4)])) - (nc - 1) * between.marginW) / nc) height = max(1e-9, ((1 - sum(fixedMargins[c(1, 3)])) - (nr * sum(panel.wrap.size[c(1,3)])) - (nr - 1) * between.marginH) / nr) - + a = (width / height) * dasp b = ifelse(a tr$domain[2]) stop("Values found that are higher than the valid domain", call. = FALSE) - + + + if (!allna) { + xrange = range(x1, na.rm = TRUE) + + if (xrange[1] < tr$domain[1]) stop("Values found that are lower than the valid domain", call. = FALSE) + if (xrange[2] > tr$domain[2]) stop("Values found that are higher than the valid domain", call. = FALSE) + } + udiv = identical(use_div(brks = NULL, midpoint), TRUE) ticks.specified = !is.null(ticks) limits.specified = (length(limits) == 2L) - + if (!limits.specified) { + if (allna) { + if (show.messages) message("Variable(s) \"", paste(aes, collapse = "\", \""), "\" only contains NAs. Legend disabled for tm_scale_continuous, unless limits are specified") + chart = within(chart, { + labels = label.na + vvalues = c(value.na, value.na) + breaks = c(0, 1) + na.show = TRUE + x1 = x1[1] + }) + return(tmapScale_returnNA(n = length(x1), legend = legend, chart = chart, value.na = value.na, label.na = label.na, label.show = label.show, na.show = legend$na.show, sortRev = sortRev, bypass_ord = bypass_ord)) + } if (is.na(limits)) { limits = range(x1, na.rm = TRUE) } else { @@ -95,7 +103,7 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar if (limits[1] < tr$domain[1]) stop("Lower limit too low", call. = FALSE) if (limits[2] > tr$domain[2]) stop("Upper limit too high", call. = FALSE) - + if (ticks.specified) { if (limits.specified) { if (any(ticks < limits[1])) stop("(Some) ticks are lower than the lowest limit. Please remove these ticks or adjust the lower limit.", call. = FALSE) @@ -104,7 +112,7 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar n = length(ticks) - 1 ticks_t = do.call(tr$fun, c(list(x = ticks), trargs)) } - + if (limits.specified) { x1_low = x1 < limits[1] x1_high = x1 > limits[2] @@ -117,11 +125,11 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar x1[which(x1_high)] = if (outliers.trunc[2]) limits[2] else NA } } - + x_t = do.call(tr$fun, c(list(x = x1), trargs)) limits_t = do.call(tr$fun, c(list(x = limits), trargs)) - domain_t = do.call(tr$fun, c(list(x = tr$domain), trargs)) - + domain_t = do.call(tr$fun, c(list(x = tr$domain), trargs)) + if (!vnum) { breaks = cont_breaks(limits_t, n=o$precision) if (is.null(labels)) { @@ -131,39 +139,39 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar if (show.warnings) warning("The length of legend labels is ", length(labels), ", which differs from the length of the breaks (", (n+1), "). Therefore, legend labels will be ignored", call.=FALSE) labels = NULL } else { - ncont = length(labels) + ncont = length(labels) } } q = num2breaks(x = x_t, n = o$precision, style = "fixed", breaks=breaks, approx=TRUE, interval.closure = "left", var=paste(layer, aes, sep = "-"), args = list()) - + breaks = q$brks nbrks = length(breaks) n2 = nbrks - 1 - + } - - - + + + # update range if NA (automatic) if (is.na(values.range[1])) { fun_range = paste0("tmapValuesRange_", aes) values.range = do.call(fun_range, args = list(x = values, n = n, isdiv = udiv)) } if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range) - - + + check_values(layer, aes, values) - + fun_isdiv = paste0("tmapValuesIsDiv_", aes) - + isdiv = !is.null(midpoint) || do.call(fun_isdiv, args = list(x = values)) # determine midpoint if ((is.null(midpoint) || is.na(midpoint)) && isdiv) { rng <- range(x_t, na.rm = TRUE) if (rng[1] < 0 && rng[2] > 0 && is.null(midpoint)) { - + if (show.messages) message("Variable(s) \"", paste(aes, collapse = "\", \""), "\" contains positive and negative values, so midpoint is set to 0. Set midpoint = NA to show the full range of visual values.") midpoint <- 0 } else { @@ -179,25 +187,25 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar } } } - + fun_getVV = paste0("tmapValuesVV_", aes) - + if (!vnum) { #### discretisize - + # number of visual values in legend item (belonging to one label) nvv = o$nvv - - + + VV = do.call(fun_getVV, list(x = values, value.na = value.na, isdiv = isdiv, n = n2, dvalues = breaks, midpoint = midpoint, range = values.range, scale = values.scale * o$scale, are_breaks = TRUE, rep = values.repeat, o = o)) - + vv = VV$vvalues value.na = VV$value.na - + sfun = paste0("tmapValuesScale_", aes) cfun = paste0("tmapValuesColorize_", aes) if (is.na(value.neutral)) value.neutral = VV$value.neutral else value.neutral = do.call(sfun, list(x = do.call(cfun, list(x = value.neutral, pc = o$pc)), scale = values.scale)) - + ids = classInt::findCols(q) vals = vv[ids] } else { @@ -205,16 +213,16 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar values = tm_seq(values[1], values[length(values)], power = "lin") } VV = transform_values(x_t, limits_t, values.range, values$power, values.scale * o$scale) - + vals = VV$x if (is.na(value.neutral)) value.neutral = VV$neutral } - + isna = is.na(vals) anyNA = any(isna) - + na.show = update_na.show(label.show, legend$na.show, anyNA) - + if (is.null(sortRev)) { ids = NULL } else if (is.na(sortRev)) { @@ -223,7 +231,7 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar if (vnum) { ids = rank(-vals) } else { - ids = (as.integer(n2) + 1L) - ids + ids = (as.integer(n2) + 1L) - ids } } else if (vnum) { ids = rank(vals) @@ -233,10 +241,10 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar vals[isna] = value.na if (!is.null(sortRev)) ids[isna] = 0L } - + labels_exp = !ticks.specified && trans == "log" && trargs$base != exp(1) - - + + if (ticks.specified) { b_t = ticks_t b = do.call(tr$rev, c(list(x = b_t), trargs)) @@ -244,7 +252,7 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar if (labels_exp) { b = do.call(tr$rev, c(list(x = pretty(limits_t, n = n)), trargs)) } else { - b = prettyTicks(do.call(tr$rev, c(list(x = seq(limits_t[1], limits_t[2], length.out = n)), trargs))) + b = prettyTicks(do.call(tr$rev, c(list(x = seq(limits_t[1], limits_t[2], length.out = n)), trargs))) } if (!(aes %in% c("col", "fill"))) b = b[b!=0] @@ -254,8 +262,8 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar b_t = b_t[sel] b = b[sel] - - + + nbrks_cont <- length(b_t) if (vnum) { @@ -276,46 +284,46 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar if (legend$reverse) rev(vv[i]) else vv[i] }) } - - - - - + + + + + if (legend$reverse) vvalues = rev(vvalues) - + if (na.show) vvalues = c(vvalues, value.na) - + # temporarily stack gradient values if (!vnum) vvalues = cont_collapse(vvalues) - + # create legend values values = b - + # create legend labels for continuous cases if (is.null(labels)) { if (labels_exp) { labels = paste(trargs$base, b_t, sep = "^") } else { - labels = do.call("fancy_breaks", c(list(vec=b, as.count = FALSE, intervals=FALSE, interval.closure="left"), label.format)) + labels = do.call("fancy_breaks", c(list(vec=b, as.count = FALSE, intervals=FALSE, interval.closure="left"), label.format)) } } else { labels = rep(labels, length.out=nbrks_cont) attr(labels, "align") <- label.format$text.align } - + if (legend$reverse) { labels.align = attr(labels, "align") labels = rev(labels) attr(labels, "align") = labels.align - } + } if (na.show) { labels.align = attr(labels, "align") labels = c(labels, label.na) attr(labels, "align") = labels.align } - + legend = within(legend, { nitems = length(labels) labels = labels @@ -331,18 +339,18 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar # NOTE: tr and limits are included in the output to facilitate the transformation of the leaflet continuous legend ticks (https://github.com/rstudio/leaflet/issues/665) #vvalues_mids = sapply(cont_split(vvalues), "[", nvv/2) #vvalues_mids[vvalues_mids == "NA"] = NA - - + + chartFun = paste0("tmapChart", toTitleCase(chart$summary)) - + chart = do.call(chartFun, list(chart, bin_colors = NULL, breaks_def = NULL, na.show = na.show, x1 = x1)) - - - + + + # chart = within(chart, { # labels = labels # vvalues = sapply(cont_split(vvalues), "[", 5) @@ -350,14 +358,14 @@ tmapScaleContinuous = function(x1, scale, legend, chart, o, aes, layer, layer_ar # na.show = get("na.show", envir = parent.env(environment())) # x1 = x1 # }) - - - + + + if (submit_legend) { if (bypass_ord) { format_aes_results(vals, legend = legend, chart = chart) } else { - format_aes_results(vals, ids, legend, chart = chart) + format_aes_results(vals, ids, legend, chart = chart) } } else { list(vals = vals, ids = ids, legend = legend, chart = chart, bypass_ord = bypass_ord) diff --git a/R/tmapScaleIntervals.R b/R/tmapScaleIntervals.R index 785dbc03..69fa2314 100644 --- a/R/tmapScaleIntervals.R +++ b/R/tmapScaleIntervals.R @@ -4,33 +4,35 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_args, sortRev, bypass_ord, submit_legend = TRUE) { cls = data_class(x1) maincls = class(scale)[1] - + if (attr(cls, "unique") && is.null(scale$breaks)) stop("Unique value, so cannot determine intervals scale range. Please specify breaks.", call. = FALSE) - - + + if (cls[1] != "num") { if (!is.factor(x1)) x1 = as.factor(x1) x1 = as.integer(x1) warning(maincls, " is supposed to be applied to numerical data", call. = FALSE) } - + x1 = without_units(x1) - + if (aes %in% c("pattern")) stop("tm_scale_intervals cannot be used for layer ", layer, ", aesthetic ", aes, call. = FALSE) - + scale = get_scale_defaults(scale, o, aes, layer, cls) - + show.messages <- o$show.messages show.warnings <- o$show.warnings - + with(scale, { + allna = all(is.na(x1)) + if (anyDuplicated(breaks)) stop("breaks specified in the ", aes, ".scale scaling function contains duplicates.", call. = FALSE) if (!is.null(breaks) && length(breaks) < 2) stop("breaks should contain at least 2 numbers", call. = FALSE) - - udiv = identical(use_div(breaks, midpoint), TRUE) + udiv = identical(use_div(breaks, midpoint), TRUE) - if (all(is.na(x1))) { + if (allna && is.null(breaks)) { + if (show.messages) message("Variable(s) \"", paste(aes, collapse = "\", \""), "\" only contains NAs. Legend disabled for tm_scale_intervals, unless breaks are specified") chart = within(chart, { labels = label.na vvalues = c(value.na, value.na) @@ -49,7 +51,7 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg if (is.na(as.count)) { as.count = is.integer(x1) && !any(!is.na(x1) & x1 < 0) } - + if (as.count) { if (interval.closure != "left" && show.warnings) warning("For as.count = TRUE, interval.closure will be set to \"left\"", call. = FALSE) interval.closure = "left" @@ -58,7 +60,7 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg #breaks.specified <- !is.null(breaks) is.log = (style == "log10_pretty") if (is.log && !attr(label.format, "big.num.abbr.set")) label.format$big.num.abbr = NA - + if (style == "log10_pretty") { x1 = log10(x1) style = "fixed" @@ -68,34 +70,34 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg style <- "fixed" } else if (as.count && style == "fixed") { breaks[length(breaks)] = breaks[length(breaks)] + 1L - } - + } + q = num2breaks(x=x1, n=n, style=style, breaks=breaks, interval.closure=interval.closure, var=paste(layer, aes, sep = "-"), as.count = as.count, args = style.args) - + breaks = q$brks nbrks = length(breaks) n = nbrks - 1 - + int.closure <- attr(q, "intervalClosure") - + # update range if NA (automatic) if (is.na(values.range[1])) { fun_range = paste0("tmapValuesRange_", aes) values.range = do.call(fun_range, args = list(x = values, n = n, isdiv = udiv)) } if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range) - + check_values(layer, aes, values) - + fun_isdiv = paste0("tmapValuesIsDiv_", aes) - + isdiv = !is.null(midpoint) || do.call(fun_isdiv, args = list(x = values)) # determine midpoint if ((is.null(midpoint) || is.na(midpoint)) && isdiv) { rng <- range(x1, na.rm = TRUE) if (rng[1] < 0 && rng[2] > 0 && is.null(midpoint)) { - + if (show.messages) message(paste0("[scale] tm_", layer[1], ":() the data variable assigned to '", aes, "' contains positive and negative values, so midpoint is set to 0. Set 'midpoint = NA' in 'fill.scale = tm_scale_intervals()' to use all visual values (e.g. colors)")) midpoint <- 0 } else { @@ -107,24 +109,24 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg } } } - + fun_getVV = paste0("tmapValuesVV_", aes) VV = do.call(fun_getVV, list(x = values, value.na = value.na, isdiv = isdiv, n = n, dvalues = breaks, midpoint = midpoint, range = values.range, scale = values.scale * o$scale, are_breaks = TRUE, rep = values.repeat, o = o)) - + vvalues = VV$vvalues value.na = VV$value.na - + sfun = paste0("tmapValuesScale_", aes) cfun = paste0("tmapValuesColorize_", aes) if (is.na(value.neutral)) value.neutral = VV$value.neutral else value.neutral = do.call(sfun, list(x = do.call(cfun, list(x = value.neutral, pc = o$pc)), scale = values.scale)) - - + + ids = classInt::findCols(q) vals = vvalues[ids] isna = is.na(vals) anyNA = any(isna) na.show = update_na.show(label.show, legend$na.show, anyNA) - + if (is.null(sortRev)) { ids = NULL } else if (is.na(sortRev)) { @@ -132,29 +134,29 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg } else if (sortRev) { ids = (as.integer(n) + 1L) - ids } - + if (anyNA) { vals[isna] = value.na if (!is.null(sortRev)) ids[isna] = 0L } - - # detransform log + + # detransform log if (is.log) { if (any((breaks %% 1) != 0)) message("non-rounded breaks occur, because style = \"log10_pretty\" is designed for large values") breaks <- 10^breaks } - + # create legend values #values = breaks[-nbrks] - + if (is.null(labels)) { - labels = do.call("fancy_breaks", c(list(vec=breaks, as.count = as.count, intervals=TRUE, interval.closure=int.closure), label.format)) + labels = do.call("fancy_breaks", c(list(vec=breaks, as.count = as.count, intervals=TRUE, interval.closure=int.closure), label.format)) } else { if (length(labels)!=nbrks-1 && show.warnings) warning("number of legend labels should be ", nbrks-1, call. = FALSE) labels = rep(labels, length.out=nbrks-1) attr(labels, "align") <- label.format$text.align } - + if (legend$reverse) { labels.brks <- attr(labels, "brks") labels.align <- attr(labels, "align") @@ -164,10 +166,10 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg } attr(labels, "align") = labels.align vvalues = rev(vvalues) - } - - - + } + + + if (na.show) { labels.brks = attr(labels, "brks") labels.align = attr(labels, "align") @@ -181,7 +183,7 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg attr(labels, "align") = labels.align vvalues = c(vvalues, value.na) } - + legend = within(legend, { nitems = length(labels) labels = labels @@ -192,9 +194,9 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg scale = "intervals" layer_args = layer_args }) - + chartFun = paste0("tmapChart", toTitleCase(chart$summary)) - + chart = do.call(chartFun, list(chart, bin_colors = vvalues, breaks_def = breaks, @@ -205,7 +207,7 @@ tmapScaleIntervals = function(x1, scale, legend, chart, o, aes, layer, layer_arg if (bypass_ord) { format_aes_results(vals, legend = legend, chart = chart) } else { - format_aes_results(vals, ids, legend, chart = chart) + format_aes_results(vals, ids, legend, chart = chart) } } else { list(vals = vals, ids = ids, legend = legend, chart = chart, bypass_ord = bypass_ord)