diff --git a/R/check_fix.R b/R/check_fix.R index 703b97d98..2372f0821 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 4a26dc98a..ee0ba712d 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 4a8dbd4d7..bbcdaeb05 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 4965cd126..a9c7a5a33 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 967f7e91b..c373da65e 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 42505bca2..f52a8f6b9 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 4c19a136d..eef9b2701 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 4c336b063..613a453f9 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 fcd13c72e..9b7e10b00 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 0ea962a18..2f9796f0c 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 eb4c69c21..70fac8c23 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}