From 8d96d0e91279c5ff33fa0f6abf6fbb12a394135b Mon Sep 17 00:00:00 2001 From: mtennekes Date: Thu, 31 Oct 2024 15:22:24 +0100 Subject: [PATCH] webGL working for polygon borders (https://github.com/r-spatial/leafgl/issues/100) and lines made consistent (https://github.com/r-spatial/leafgl/issues/101) --- R/check_fix.R | 2 +- R/step1_helper_facets.R | 2 +- R/step2_helper_data.R | 1 + R/tm_layout.R | 2 +- R/tmapLeaflet_layers.R | 98 ++++++++++++++++++++++++++++--------- R/tmapScaleCategorical.R | 103 ++++++++++++++++++++------------------- R/tmapScale_defaults.R | 7 +-- R/tmap_options.R | 2 +- examples/tmapOutput.R | 10 ++-- man/renderTmap.Rd | 10 ++-- man/tm_view.Rd | 2 +- 11 files changed, 145 insertions(+), 94 deletions(-) diff --git a/R/check_fix.R b/R/check_fix.R index 703b97d9..2372f082 100644 --- a/R/check_fix.R +++ b/R/check_fix.R @@ -20,7 +20,7 @@ check_fix = function(sfc, shp_name, reproj, messages) { sfc = sf::st_make_valid(sfc) }, error = function(e) { suppressMessages(sf::sf_use_s2(s2)) - stop("Unable to make ", shp_name, " valid", add, call. = FALSE) + stop("Unable to make ", shp_name, " valid", call. = FALSE) }) if (messages) message("Shape ", shp_name, " has been fixed with s2 = ", !s2, ". If the map doesn't look correct, please run sf::sf_use_s2(", !s2, ") before running the tmap code again.") diff --git a/R/step1_helper_facets.R b/R/step1_helper_facets.R index 4a26dc98..ee0ba712 100644 --- a/R/step1_helper_facets.R +++ b/R/step1_helper_facets.R @@ -181,6 +181,7 @@ step1_rearrange_facets = function(tmo, o) { vars = character(0) } } + nvars = length(value) #m nvari = vapply(value, length, integer(1)) @@ -196,7 +197,6 @@ step1_rearrange_facets = function(tmo, o) { update_grp_vars(lev = flvar) add_used_vars(vars) } else { - # if (aes == "shape") browser() mfun = paste0("tmapValuesSubmit_", aes) if (exists(mfun)) { value = do.call(mfun, list(x = value, args = args)) diff --git a/R/step2_helper_data.R b/R/step2_helper_data.R index 4a8dbd4d..bbcdaeb0 100644 --- a/R/step2_helper_data.R +++ b/R/step2_helper_data.R @@ -67,6 +67,7 @@ update_crt = function(o, crt, v, mfun, unm, active) { } getdts = function(aes, unm, p, q, o, dt, shpvars, layer, group, mfun, args, plot.order) { + dev = getOption("tmap.devel.mode") nm = aes$aes diff --git a/R/tm_layout.R b/R/tm_layout.R index 4965cd12..a9c7a5a3 100644 --- a/R/tm_layout.R +++ b/R/tm_layout.R @@ -144,7 +144,7 @@ tm_layout = function( #' #' View mode options. These options are specific to the view mode. #' -#' @param use.WebGL use webGL layers with leafgl +#' @param use.WebGL use webGL for points, lines, and polygons. This is much faster than the standard leaflet layer functions, but the number of visual variables are limited; only fill, size, and color (for lines) are supported. By default `TRUE` if no other visual variables are used. #' @param control.position position of the control attribute #' @param control.bases base layers #' @param control.overlays overlay layers diff --git a/R/tmapLeaflet_layers.R b/R/tmapLeaflet_layers.R index 967f7e91..c373da65 100644 --- a/R/tmapLeaflet_layers.R +++ b/R/tmapLeaflet_layers.R @@ -21,6 +21,26 @@ submit_labels = function(labels, cls, pane, group) { labels } +impute_webgl = function(use.WebGL, dt, supported) { + if (!identical(use.WebGL, FALSE)) { + vary = vapply(dt, function(x)any(x!=x[1]), FUN.VALUE = logical(1)) + + vary = vary[setdiff(names(vary), c(supported, "tmapID__", "ord__"))] + + if (any(vary)) { + if (is.na(use.WebGL)) { + use.WebGL = FALSE + } else { + warning("WegGL enabled: the only supported visual variables are: ", paste(supported, collapse = ", "), ". The visual variable(s) ", paste(names(vary)[vary], collapse = ", "), " are not supported. Disable WebGL to show them.", call. = FALSE) + } + } else { + use.WebGL = TRUE + } + } + use.WebGL +} + + expand_coords_gp = function(coords, gp, ndt) { expanded = (ncol(coords) == 3L) if (expanded) { @@ -66,13 +86,20 @@ tmapLeafletPolygons = function(shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, idt = (if (is.null(idt))dt$tmapID__ else idt) |> submit_labels("polygons", pane, group) + + o$use.WebGL = impute_webgl(o$use.WebGL, dt, supported = c("fill", "col")) + if (o$use.WebGL) { shp2 = sf::st_sf(id = seq_along(shp), geom = shp) shp3 = suppressWarnings(sf::st_cast(shp2, "POLYGON")) + shp3lines = suppressWarnings(sf::st_cast(shp3, "LINESTRING")) gp3 = lapply(gp, function(gpi) {if (length(gpi) == 1) gpi else gpi[shp3$id]}) popups2 = popups[shp3$id] lf %>% - leafgl::addGlPolygons(data = shp3, layerId = idt, color = gp3$col, opacity = gp3$col_alpha, fillColor = gp3$fill, fillOpacity = gp3$fill_alpha, weight = gp3$lwd, group = group, pane = pane, popup = popups2) %>% + leafgl::addGlPolygons(data = shp3, layerId = idt, # not working: color = gp3$col, opacity = gp3$col_alpha[1], + fillColor = gp3$fill, fillOpacity = gp3$fill_alpha[1], #not working: weight = gp3$lwd[1], + group = group, pane = pane, popup = popups2) %>% + leafgl::addGlPolylines(data = shp3lines, color = gp3$col, opacity = gp3$col_alpha, weight = gp3$lwd/4, pane = pane, group = group, layerId = idt) |> assign_lf(facet_row, facet_col, facet_page) } else { lf %>% @@ -130,12 +157,14 @@ tmapLeafletLines = function(shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, fac idt = (if (is.null(idt))dt$tmapID__ else idt) |> submit_labels("lines", pane, group) + o$use.WebGL = impute_webgl(o$use.WebGL, dt, supported = "col") + if (o$use.WebGL) { shp2 = sf::st_sf(id = seq_along(shp), geom = shp) shp3 = suppressWarnings(sf::st_cast(shp2, "LINESTRING")) gp3 = lapply(gp, function(gpi) {if (length(gpi) == 1) gpi else gpi[shp3$id]}) lf %>% - leafgl::addGlPolylines(data = shp3, color = gp3$col, opacity = gp3$col_alpha, weight = gp3$lwd, pane = pane, group = group, layerId = idt) %>% + leafgl::addGlPolylines(data = shp3, color = gp3$col, opacity = gp3$col_alpha, weight = gp3$lwd/4, pane = pane, group = group, layerId = idt) %>% assign_lf(facet_row, facet_col, facet_page) } else { @@ -208,11 +237,13 @@ tmapLeafletSymbols = function(shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, f #po(sort(gp2$width, decreasing = T)) + o$use.WebGL = impute_webgl(o$use.WebGL, dt, supported = c("fill", "size")) + + + if (o$use.WebGL) { - vary = vapply(dt, function(x)any(x!=x[1]), FUN.VALUE = logical(1))[c("col", "shape", "lwd", "lty", "fill_alpha", "col_alpha")] - if (any(vary)) warning("WegGL enabled: the only supported visual variables are: fill and size. The visual variable(s) ", paste(names(vary)[vary], collapse = ", "), " are not supported. Disable WebGL to show them.", call. = FALSE) lf %>% leafgl::addGlPoints(sf::st_sf(shp), fillColor = gp2$fillColor, radius = gp2$width, fillOpacity = gp2$fillOpacity[1], pane = pane, group = group) %>% assign_lf(facet_row, facet_col, facet_page) } else { @@ -223,46 +254,67 @@ tmapLeafletSymbols = function(shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, f sid = which(is_num) nid = which(!is_num) - gp2$shape[sid] = paste0("icon", seq_along(sid)) + + # ="circle" to make makeSymbolsIcons2 work + # shape_orig to let unique pick unique rows (one for each ) + gp2$shape_orig = gp2$shape + gp2$shape[sid] = "circle" # faster than symbols2 = do.call(makeSymbolIcons2, gp2) gp2df = as.data.table(gp2) gp2dfU = unique(gp2df) - symbols = do.call(makeSymbolIcons2, as.list(gp2dfU)) + k = nrow(gp2dfU) + + symbols = do.call(makeSymbolIcons2, as.list(gp2dfU[,-(ncol(gp2dfU)),with=F])) gp2dfU[, id:=1L:.N] - gp2join = gp2df[gp2dfU, on=names(gp2df)] + gp2join = gp2df[gp2dfU, id:= id, on=names(gp2df)] ids = gp2join$id - symbols = lapply(symb, function(s) s[ids]) + coords_grps = split.data.frame(coords, ids) + idt_grps = split(idt, ids) + if (!is.null(hdt)) { + hdt_grps = split(hdt, ids) + } else { + hdt_grps = replicate(k, list(NULL)) + } + popups_grps = split(popups, ids) + + + symbols$iconWidth = rep(NA, k) + symbols$iconHeight = rep(NA, k) - symbols$iconWidth = rep(NA, length(symbols$iconUrl)) - symbols$iconHeight = rep(NA, length(symbols$iconUrl)) if (length(sid)) { - iconLib <- get("shapeLib", envir = .TMAP)[sn[sid]-999] + sym_shapes = suppressWarnings(as.numeric(gp2dfU$shape_orig)) + sid2 = which(!is.na(sym_shapes)) + + iconLib <- get("shapeLib", envir = .TMAP)[sym_shapes[sid2]-999] symbols_icons <- merge_icons(iconLib) - size = gp2$width[sid] / gp2$baseSize - size[sid] = size[sid] * args$icon.scale/3 + size = gp2dfU$width[sid2] / gp2dfU$baseSize[sid2] + size = size * args$icon.scale/3 - for (i in seq_along(sid)) { - symbols$iconUrl[sid[i]] = symbols_icons$iconUrl[i] - symbols$iconWidth[sid[i]] <- symbols_icons$iconWidth[i] * size[i] - symbols$iconHeight[sid[i]] <- symbols_icons$iconHeight[i] * size[i] + for (i in seq_along(sid2)) { + symbols$iconUrl[sid2[i]] = symbols_icons$iconUrl[i] + symbols$iconWidth[sid2[i]] <- symbols_icons$iconWidth[i] * size[i] + symbols$iconHeight[sid2[i]] <- symbols_icons$iconHeight[i] * size[i] if (all(c("iconAnchorX", "iconAnchorY") %in% names(symbols_icons))) { - symbols$iconAnchorX[sid[i]] <- symbols_icons$iconAnchorX[i] * size[i] - symbols$iconAnchorY[sid[i]] <- symbols_icons$iconAnchorY[i] * size[i] + symbols$iconAnchorX[sid2[i]] <- symbols_icons$iconAnchorX[i] * size[i] + symbols$iconAnchorY[sid2[i]] <- symbols_icons$iconAnchorY[i] * size[i] } } } - - lf %>% leaflet::addMarkers(lng = coords[, 1], lat = coords[, 2], - icon = symbols, group = group, layerId = idt, label = hdt, popup = popups, options = opt) %>% - assign_lf(facet_row, facet_col, facet_page) + for (i in 1L:k) { + lf = lf |> + leaflet::addMarkers(lng = coords_grps[[i]][, 1], + lat = coords_grps[[i]][, 2], + icon = lapply(symbols, "[", i), group = group, layerId = idt_grps[[i]], label = hdt_grps[[i]], popup = popups_grps[[i]], options = opt) + } + lf |> assign_lf(facet_row, facet_col, facet_page) } diff --git a/R/tmapScaleCategorical.R b/R/tmapScaleCategorical.R index 42505bca..f52a8f6b 100644 --- a/R/tmapScaleCategorical.R +++ b/R/tmapScaleCategorical.R @@ -3,16 +3,16 @@ #' @rdname tmap_internal tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_args, sortRev, bypass_ord, submit_legend = TRUE) { cls = if (inherits(scale, "tm_scale_categorical")) c("fact", "unord") else c("fact", "ord") - + if (is.factor(x1)) { defcols_cats = grepl("=<>=", levels(x1)[1], fixed = TRUE) defcols_nocats = grepl("=><=", levels(x1)[1], fixed = TRUE) - - if (defcols_cats || defcols_nocats) { + + if (defcols_cats || defcols_nocats) { res = strsplit(levels(x1), {if (defcols_cats) "=<>=" else "=><="}, fixed = TRUE) levels(x1) = vapply(res, "[", 1, FUN.VALUE = character(1)) ct = vapply(res, "[", 2, FUN.VALUE = character(1)) - + if (defcols_nocats && !legend$called) { legend$show = FALSE } @@ -22,18 +22,19 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a } else { ct = NULL } - - + + scale = get_scale_defaults(scale, o, aes, layer, cls, ct) - + show.messages <- o$show.messages show.warnings <- o$show.warnings - + + with(scale, { check_values(layer, aes, values) - + nms = names(values) #color_names - + # cast to factor if needed if (!is.factor(x1)) { su = sort(unique(x1)) @@ -42,10 +43,10 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a }, error = function(e) { stop("tm_scale_categorical in layer \"tm_", layer, "\", visual variable \"", aes, "\" cannot be applied due to an error categorization of the data", call. = FALSE) }) - - if (is.numeric(su)) levels(x1) <- do.call("fancy_breaks", c(list(vec=su, intervals=FALSE, as.count = FALSE), label.format)) + + if (is.numeric(su)) levels(x1) <- do.call("fancy_breaks", c(list(vec=su, intervals=FALSE, as.count = FALSE), label.format)) } - + # select levels if (!is.null(levels)) { x1 = factor(x1, levels = levels) @@ -64,89 +65,89 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a } x1 = y } - + lvls = levels(x1) n = nlevels(x1) - + if (is.null(labels)) { - labs = lvls + labs = lvls } else { if (is.null(names(labels))) { if (length(labels) != n) warning("labels do not have the same length as levels, so they are repeated", call. = FALSE) - labs = rep(labels, length.out = n) + labs = rep(labels, length.out = n) } else { nms = names(labels) labs = structure(lvls, names = lvls) - + nms2 = intersect(nms, lvls) labs[nms2] = unname(labels[nms2]) } } names(labs) = NULL - + if (!is.null(names(values))) { nms = names(values) xlev = levels(x1) if (!all(xlev %in% nms)) { - stop("All levels should occur in the vector names of values: ", paste(setdiff(xlev, nms), collapse = ", "), " are missing", call. = FALSE) + stop("All levels should occur in the vector names of values: ", paste(setdiff(xlev, nms), collapse = ", "), " are missing", call. = FALSE) } else { values = values[match(xlev, nms)] } } - - + + # combine levels if (n.max < n) { if (show.warnings) warning("Number of levels of the variable assigned to the aesthetic \"",aes ,"\" of the layer \"", layer, "\" is ", n, ", which is larger than n.max (which is ", n.max, "), so levels are combined.", call. = FALSE) - + mapping = as.numeric(cut(seq.int(n), breaks=n.max)) to = c(which(mapping[-n] - mapping[-1]!=0), n) from = c(0, to[-n.max]) + 1 - + new_lvls = paste0(labs[from], "...", labs[to]) - + x1 = factor(mapping[as.integer(x1)], levels=1L:n.max, labels=new_lvls) labs = new_lvls } n = nlevels(x1) - + # 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 = FALSE)) } if (length(values.range) == 1 && !is.na(values.range[1])) values.range = c(0, values.range) - + fun_getCVV = paste0("tmapValuesCVV_", aes) VV = do.call(fun_getCVV, list(x = values, value.na = value.na, n = n, range = values.range, scale = values.scale, rep = values.repeat, o = o)) - + values = 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)) - + mfun = paste0("tmapValuesSubmit_", aes) values = do.call(mfun, list(x = values, args = layer_args)) value.na = do.call(mfun, list(x = value.na, args = layer_args)) value.neutral = do.call(mfun, list(x = value.neutral, args = layer_args)) - + # legend.palette <- do.call("process_color", c(list(col=legend.palette), process.colors)) # colorNA <- do.call("process_color", c(list(col=colorNA), process.colors)) - + ids = as.integer(x1) vals = values[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 @@ -155,30 +156,30 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a } else if (sortRev) { ids = (as.integer(n) + 1L) - ids } - + if (anyNA) { vals[isna] = value.na if (!is.null(sortRev)) ids[isna] = 0L } - - - - + + + + if (legend$reverse) { labs = rev(labs) values = rev(values) } - + if (na.show) { labs = c(labs, label.na) values = c(values, value.na) } attr(labs, "align") = label.format$text.align - - + + # SPECIAL CASE: if icons are used, specify this information in the symbol legend, such that it can be taken (in step4_plot_collect_legends) by other legends (e.g. for symbol sizes) icon_scale = if ((aes == "shape") && any(values > 999) && getOption("tmap.mode") == "plot") layer_args$icon.scale else 1 - + legend = within(legend, { nitems = length(labs) labels = labs @@ -190,7 +191,7 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a scale = "categorical" layer_args = layer_args }) - + chartFun = paste0("tmapChart", toTitleCase(chart$summary)) chart = do.call(chartFun, list(chart, @@ -198,19 +199,19 @@ tmapScaleCategorical = function(x1, scale, legend, chart, o, aes, layer, layer_a breaks_def = NULL, na.show = na.show, 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/tmapScale_defaults.R b/R/tmapScale_defaults.R index 4c19a136..eef9b270 100644 --- a/R/tmapScale_defaults.R +++ b/R/tmapScale_defaults.R @@ -625,7 +625,7 @@ tmapValuesSubmit_lty = function(x, args) x #' @keywords internal #' @rdname tmap_internal tmapValuesSubmit_shape = function(x, args) { - x = tmapVV(x) + if (!inherits(x, c("tmapStandard", "tmapSpecial"))) x = tmapVV(x) if (inherits(x, "tmapSpecial")) { gs = tmap_graphics_name() fun = paste0("submit_symbols_", gs) @@ -643,12 +643,9 @@ tmapValuesSubmit_shape = function(x, args) { just.override = TRUE } }) - - - do.call(fun, args = list(x, args)) } else { - x + unlist(x) } } diff --git a/R/tmap_options.R b/R/tmap_options.R index 4c336b06..613a453f 100644 --- a/R/tmap_options.R +++ b/R/tmap_options.R @@ -22,7 +22,7 @@ tmapMode = function(id, name, ...) { use.gradient = FALSE, crs = "auto"), view = list(name = "Leaflet", - use.WebGL = FALSE, + use.WebGL = NA, legend.position = tm_pos_in(pos.h = "right", pos.v = "bottom", align.h = "left", align.v = "top", just.h = "left", just.v = "bottom"), crs = list(dimensions = 3857, 4326), facet.max = 16, diff --git a/examples/tmapOutput.R b/examples/tmapOutput.R index fcd13c72..9b7e10b0 100644 --- a/examples/tmapOutput.R +++ b/examples/tmapOutput.R @@ -1,8 +1,8 @@ if (interactive() && require("shiny")) { - + data(World) world_vars <- setdiff(names(World), c("iso_a3", "name", "sovereignt", "geometry")) - + tmap_mode("plot") shinyApp( @@ -17,7 +17,7 @@ if (interactive() && require("shiny")) { }) } ) - + tmap_mode("view") shinyApp( @@ -28,14 +28,14 @@ if (interactive() && require("shiny")) { server <- function(input, output, session) { output$map <- renderTmap({ tm_shape(World, id = "iso_a3") + - tm_polygons(world_vars[1], zindex = 401) + tm_polygons(fill = world_vars[1], zindex = 401) }) observe({ var <- input$var tmapProxy("map", session, { tm_remove_layer(401) + tm_shape(World, id = "iso_a3") + - tm_polygons(var, zindex = 401) + tm_polygons(fill = var, zindex = 401) }) }) },options = list(launch.browser=TRUE) diff --git a/man/renderTmap.Rd b/man/renderTmap.Rd index 0ea962a1..2f9796f0 100644 --- a/man/renderTmap.Rd +++ b/man/renderTmap.Rd @@ -52,10 +52,10 @@ Two features from tmap are not (yet) supported in Shiny: small multiples (facets } \examples{ if (interactive() && require("shiny")) { - + data(World) world_vars <- setdiff(names(World), c("iso_a3", "name", "sovereignt", "geometry")) - + tmap_mode("plot") shinyApp( @@ -70,7 +70,7 @@ if (interactive() && require("shiny")) { }) } ) - + tmap_mode("view") shinyApp( @@ -81,14 +81,14 @@ if (interactive() && require("shiny")) { server <- function(input, output, session) { output$map <- renderTmap({ tm_shape(World, id = "iso_a3") + - tm_polygons(world_vars[1], zindex = 401) + tm_polygons(fill = world_vars[1], zindex = 401) }) observe({ var <- input$var tmapProxy("map", session, { tm_remove_layer(401) + tm_shape(World, id = "iso_a3") + - tm_polygons(var, zindex = 401) + tm_polygons(fill = var, zindex = 401) }) }) },options = list(launch.browser=TRUE) diff --git a/man/tm_view.Rd b/man/tm_view.Rd index eb4c69c2..70fac8c2 100644 --- a/man/tm_view.Rd +++ b/man/tm_view.Rd @@ -17,7 +17,7 @@ tm_view( ) } \arguments{ -\item{use.WebGL}{use webGL layers with leafgl} +\item{use.WebGL}{use webGL for points, lines, and polygons. This is much faster than the standard leaflet layer functions, but the number of visual variables are limited; only fill, size, and color (for lines) are supported. By default \code{TRUE} if no other visual variables are used.} \item{control.position}{position of the control attribute}