shiny working, fill_alpha working for 3d polys

Author: mtennekes

DESCRIPTION

@@ -7,7 +7,7 @@ Authors@R: c(
 	)
 Description: The 'tmap' package provides two plotting modes for static and interactive thematic maps. This package extends 'tmap' with two additional modes based on 'Mapbox GL JS' and 'MapLibre GL JS'. These modes feature interactive vector tiles, globe views, and other modern web-mapping capabilities, while maintaining a consistent 'tmap' interface across all plotting modes.
 License: GPL-3
-Version: 0.2-1
+Version: 0.3
 Encoding: UTF-8
 Depends:
     R (>= 4.1),

NEWS

@@ -1,3 +1,7 @@
+version 0.3
+- shiny integration
+- fill_alpha working for tm_polygons_3d
+
 version 0.2.1
 - fixed minor bug
 

R/mapgl_init.R

@@ -1,5 +1,7 @@
 #' @param return.asp return.asp
 #' @param vp vp
+#' @param dg base map widget (internal; \code{NULL} in proxy mode, where the
+#'   proxy object \code{m} is used as the drawing canvas instead)
 #' @param m the proxy object from `maplibre_proxy()`/`mapboxgl_proxy()`, supplied in proxy mode
 #' @export
 #' @keywords internal
@@ -9,42 +11,56 @@ tmapMapboxInit = function(o, return.asp = FALSE, vp, prx, dg = NULL, m = NULL, .
 	mapgl_init(o = o, return.asp = return.asp, vp = vp, prx = prx,
 			   dg = dg, m = m, e = .TMAP_MAPBOX, ...)
 }
-
 #' @export
 #' @keywords internal
 #' @rdname tmapMapbox
 tmapMaplibreInit = function(o, return.asp = FALSE, vp, prx, dg = NULL, m = NULL, ...) {
 	mapgl_init(o = o, return.asp = return.asp, vp = vp, prx = prx,
 			   dg = dg, m = m, e = .TMAP_MAPLIBRE, ...)
 }
-
-
 mapgl_init = function(o, return.asp, vp, prx, dg = NULL, m = NULL, e, ...) {
 	if (return.asp) return(1)
-
 	per_page = rep(o$ncols * o$nrows, o$npages)
 	k = o$ncols * o$nrows * o$npages
 	if (o$n < k) {
 		per_page[o$npages] = per_page[o$npages] - (k - o$n)
 	}
-
 	proxy = isTRUE(.TMAP$proxy)
+	if (proxy) {
+		mode = if (identical(e, .TMAP_MAPBOX)) "mapbox" else "maplibre"
+
+		# Legends + controls are rebuilt wholesale on every render, so clear the
+		# previous ones first (otherwise they stack). clear-all = no id argument.
+		m = m |>
+			mapgl::clear_legend() |>
+			mapgl::clear_controls()
+
+		# clear_controls() also removes the navigation / globe controls. On a full
+		# render those are created in mapgl_shape() (navigation then globe, leaving
+		# the globe icon on top), but mapgl_shape() early-returns in proxy mode, so
+		# re-add them here or they vanish after the first update.
+		#
+		# In the proxy re-add path the controls stack in the OPPOSITE visual order
+		# to the initial widget render, so to keep the globe on top (as at start)
+		# we add globe first, then navigation.
+		if (mode == "maplibre") m = mapgl::add_globe_control(m)
+		m = mapgl::add_navigation_control(m, visualize_pitch = TRUE)
+	}
 
-	# proxy mode: draw onto the live map via `m`; otherwise use base widget `dg`
-	base = if (proxy) m else dg
-
+	# layer removal is targeted: only the zindexes named by tm_remove_layer()
 	if (proxy && length(prx)) {
 		pane_name = getFromNamespace("pane_name", "tmap")
 		zres   = vapply(prx, function(p) p$zindex, FUN.VALUE = numeric(1))
-		rm_ids = mapgl_layer_ids(e, pane_name(zres))   # 401 -> "tmap401", matches the keys
+		rm_ids = mapgl_layer_ids(e, pane_name(zres))
 		if (length(rm_ids)) {
 			mapgl::clear_layer(m, rm_ids)
 			e$layer_zindex[pane_name(zres)] = NULL
 		}
 	}
 
+	# proxy mode: draw onto the live map via `m`; otherwise use base widget `dg`
+	base = if (proxy) m else dg
 	ms = lapply(per_page, function(p) lapply(seq_len(p), function(i) base))
-
 	e$ms     = ms
 	e$nrow   = o$nrows
 	e$ncol   = o$ncols
@@ -57,22 +73,16 @@ mapgl_init = function(o, return.asp, vp, prx, dg = NULL, m = NULL, e, ...) {
 	}
 	NULL
 }
-
-
-
 #' @param q q
 #' @export
 #' @keywords internal
 #' @rdname tmapMapbox
 tmapMapboxAux = function(o, q) {
 	NULL
 }
-
-
 #' @export
 #' @keywords internal
 #' @rdname tmapMapbox
 tmapMaplibreAux = function(o, q) {
 	NULL
 }
-

R/mapgl_layers.R

@@ -182,6 +182,18 @@ lty2dash <- function(lty) {
 	}
 }
 
+# ============================================================
+#  Source id helper
+# ============================================================
+
+# Source ids must be unique per render. clear_layer() (used by tm_remove_layer
+# in proxy mode) removes *layers* but not their *sources*, so reusing a source
+# id on a redraw collides with the still-present stale source: MapLibre keeps
+# the old data and the re-added layers recolour from it. .TMAP$stamp is bumped
+# by print.tmap() on every render, giving a fresh source id each time. Layer
+# ids stay stable (glid-based) so the tm_remove_layer registry keeps matching.
+mapgl_srcid <- function(base) sprintf("%s_%.0f", base, .TMAP$stamp * 1e6)
+
 # ============================================================
 #  mapgl_polygons
 # ============================================================
@@ -191,9 +203,6 @@ mapgl_polygons <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 						   id, pane, group, glid, o, ..., mode) {
 
 	m <- get_mapgl(facet_row, facet_col, facet_page, mode)
-	message("== mapgl_polygons: class(m) = ", paste(class(m), collapse=", "),
-			" | pane = ", pane)
-
 	rc_text    <- frc(facet_row, facet_col)
 	shp_is_pointer <- inherits(shpTM$shp, "character")
 
@@ -204,7 +213,7 @@ mapgl_polygons <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		if (pmtiles_unsupported(shpTM, mode)) return(NULL)
 
 		smeta      <- shpTM$smeta
-		srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
+		srcname    <- mapgl_srcid(paste0("layer", pane))
 		layername1 <- paste0(glid, "polygons_fill")
 		layername2 <- paste0(glid, "polygons_border")
 		url        <- smeta$url
@@ -222,12 +231,12 @@ mapgl_polygons <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		# so there is no row-level join available at render time.
 
 		m |>
-			mapgl::add_pmtiles_source(id = glid, url = url) |>
-			mapgl::add_fill_layer(layername1, source = glid,
+			mapgl::add_pmtiles_source(id = srcname, url = url) |>
+			mapgl::add_fill_layer(layername1, source = srcname,
 								  source_layer  = smeta$layer,
 								  fill_color    = aes_f,
 								  fill_opacity  = aes_fo) |>
-			mapgl::add_line_layer(layername2, source = glid,
+			mapgl::add_line_layer(layername2, source = srcname,
 								  source_layer  = smeta$layer,
 								  line_color    = aes_c,
 								  line_opacity  = aes_co,
@@ -290,7 +299,7 @@ mapgl_polygons <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 	ahp  <- attach_hover_popup(shp2, dt, hdt, pdt, idt, popup.format)
 	shp2 <- ahp$shp2
 
-	srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
+	srcname    <- mapgl_srcid(paste0("layer", pane))
 	layername1 <- paste0(glid, "polygons_fill")
 	layername2 <- paste0(glid, "polygons_border")
 
@@ -329,7 +338,7 @@ mapgl_polygons_3d <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		if (pmtiles_unsupported(shpTM, mode)) return(NULL)
 
 		smeta      <- shpTM$smeta
-		srcname    <- paste0("layer", pane)
+		srcname    <- mapgl_srcid(paste0("layer", pane))
 		layername1 <- paste0(glid, "polygons_fill")
 		layername2 <- paste0(glid, "polygons_border")
 		url        <- smeta$url
@@ -416,13 +425,13 @@ mapgl_polygons_3d <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		)
 
 		m |>
-			mapgl::add_pmtiles_source(id = glid, url = url) |>
-			mapgl::add_line_layer(layername2, source = glid,
+			mapgl::add_pmtiles_source(id = srcname, url = url) |>
+			mapgl::add_line_layer(layername2, source = srcname,
 								  source_layer          = smeta$layer,
 								  line_color            = aes_c,
 								  line_opacity          = aes_co,
 								  line_width            = aes_lwd) |>
-			mapgl::add_fill_extrusion_layer(layername1, source = glid,
+			mapgl::add_fill_extrusion_layer(layername1, source = srcname,
 											source_layer           = smeta$layer,
 											fill_extrusion_color   = aes_f,
 											fill_extrusion_base    = 0,
@@ -463,12 +472,23 @@ mapgl_polygons_3d <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		geometry = shp
 	)
 
+	# NOTE on transparency: fill-extrusion layers do NOT support per-feature alpha.
+	# The GL spec ignores the alpha channel of fill-extrusion-color (and a long-
+	# standing engine bug renders alpha=0 as solid black), and fill-extrusion-opacity
+	# is per-LAYER only, not data-driven. So we honour transparency as a single
+	# layer-wide opacity, taken as the mean of the per-feature fill_alpha values.
+	fill_ext_opacity <- {
+		fa <- suppressWarnings(as.numeric(shp2$fill_alpha))
+		fa <- fa[is.finite(fa)]
+		if (!length(fa)) 1 else min(max(mean(fa), 0), 1)
+	}
+
 	ahp  <- attach_hover_popup(shp2, dt, hdt, pdt, idt, popup.format)
 	shp2 <- ahp$shp2
 
-	srcname    <- paste0("layer", pane)
-	layername1 <- paste0(srcname, "polygons_fill")
-	layername2 <- paste0(srcname, "polygons_border")
+	srcname    <- mapgl_srcid(paste0("layer", pane))
+	layername1 <- paste0(glid, "polygons_fill")
+	layername2 <- paste0(glid, "polygons_border")
 
 	if (is.character(a$height.max)) {
 		is_perc_max <- grepl("%$", a$height.max)
@@ -513,11 +533,12 @@ mapgl_polygons_3d <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 							  line_opacity = mapgl::get_column("col_alpha"),
 							  line_width   = mapgl::get_column("lwd")) |>
 		mapgl::add_fill_extrusion_layer(layername1, source = srcname,
-										fill_extrusion_color  = mapgl::get_column("fill"),
-										fill_extrusion_base   = 0,
-										fill_extrusion_height = mapgl::get_column("height"),
-										tooltip               = ahp$hdt_arg,
-										popup                 = ahp$pdt_arg) |>
+										fill_extrusion_color   = mapgl::get_column("fill"),
+										fill_extrusion_opacity = fill_ext_opacity,
+										fill_extrusion_base    = 0,
+										fill_extrusion_height  = mapgl::get_column("height"),
+										tooltip                = ahp$hdt_arg,
+										popup                  = ahp$pdt_arg) |>
 		assign_mapgl(facet_row, facet_col, facet_page, mode = mode)
 
 	mapgl_submit_group(group, c(layername1, layername2), mode, pane)
@@ -539,16 +560,16 @@ mapgl_lines <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 	if (shp_is_pointer) {
 		if (pmtiles_unsupported(shpTM, mode)) return(NULL)
 		smeta      <- shpTM$smeta
-		srcname    <- paste0("layer", pane)
+		srcname    <- mapgl_srcid(paste0("layer", pane))
 		layername1 <- paste0(glid, "lines")
 		url        <- smeta$url
 		get_pmt_aes <- make_get_pmt_aes(dt)
 		aes_c   <- get_pmt_aes("col")
 		aes_co  <- get_pmt_aes("col_alpha")
 		aes_lwd <- get_pmt_aes("lwd")
 		m |>
-			mapgl::add_pmtiles_source(id = glid, url = url) |>
-			mapgl::add_line_layer(layername1, source = glid,
+			mapgl::add_pmtiles_source(id = srcname, url = url) |>
+			mapgl::add_line_layer(layername1, source = srcname,
 								  source_layer  = smeta$layer,
 								  line_color    = aes_c,
 								  line_opacity  = aes_co,
@@ -594,7 +615,7 @@ mapgl_lines <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 
 	ahp  <- attach_hover_popup(shp2, dt, hdt, pdt, idt, popup.format)
 	shp2 <- ahp$shp2
-	srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
+	srcname    <- mapgl_srcid(paste0("layer", pane))
 	layername1 <- paste0(glid, "lines")  # was paste0(srcname, "lines") — fixed to match legend
 
 	m |>
@@ -629,7 +650,7 @@ mapgl_symbols <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		if (pmtiles_unsupported(shpTM, mode)) return(NULL)
 
 		smeta      <- shpTM$smeta
-		srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
+		srcname    <- mapgl_srcid(paste0("layer", pane))
 		layername1 <- paste0(glid, "symbols_fill")
 		url        <- smeta$url
 
@@ -646,8 +667,8 @@ mapgl_symbols <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 		if (is.numeric(aes_size)) aes_size <- aes_size * 10
 
 		m |>
-			mapgl::add_pmtiles_source(id = glid, url = url) |>
-			mapgl::add_circle_layer(layername1, source = glid,
+			mapgl::add_pmtiles_source(id = srcname, url = url) |>
+			mapgl::add_circle_layer(layername1, source = srcname,
 									source_layer          = smeta$layer,
 									circle_color          = aes_f,
 									circle_opacity        = aes_fo,
@@ -714,7 +735,7 @@ mapgl_symbols <- function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp,
 
 	ahp  <- attach_hover_popup(shp2, dt, hdt, pdt, idt, popup.format)
 	shp2 <- ahp$shp2
-	srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
+	srcname    <- mapgl_srcid(paste0("layer", pane))
 	layername1 <- paste0(glid, "symbols_fill")  # was paste0(srcname, ...) — fixed
 
 	m |>
@@ -751,15 +772,15 @@ mapgl_raster <- function(a, shpTM, dt, gp, pdt, popup.format, hdt, idt,
 		if (pmtiles_unsupported(shpTM, mode)) return(NULL)
 
 		smeta      <- shpTM$smeta
-		srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
-		layername1 <- paste0(srcname, "raster")
+		srcname    <- mapgl_srcid(paste0("layer", pane))
+		layername1 <- paste0(glid, "raster")
 		url        <- smeta$url
 
 		m <- get_mapgl(facet_row, facet_col, facet_page, mode = mode)
 
 		m |>
-			mapgl::add_pmtiles_source(id = glid, url = url, source_type = "raster") |>
-			mapgl::add_raster_layer(layername1, source = glid) |>
+			mapgl::add_pmtiles_source(id = srcname, url = url, source_type = "raster") |>
+			mapgl::add_raster_layer(layername1, source = srcname) |>
 			assign_mapgl(facet_row, facet_col, facet_page, mode = mode)
 
 		return(NULL)
@@ -795,8 +816,8 @@ mapgl_raster <- function(a, shpTM, dt, gp, pdt, popup.format, hdt, idt,
 		if (ext$ymax >  89.9) ext$ymax <-  89
 		rst2 <- terra::crop(rst, ext)
 
-		srcname    <- paste0("layer", pane, "_", .TMAP$stamp)
-		layername1 <- paste0(srcname, "raster")
+		srcname    <- mapgl_srcid(paste0("layer", pane))
+		layername1 <- paste0(glid, "raster")
 
 		m <- get_mapgl(facet_row, facet_col, facet_page, mode = mode)