R/tmapLeafletDataPlot_symbols.R

In tmap: Thematic Maps

#' @export
#' @rdname tmapGridLeaflet
tmapLeafletDataPlot.tm_data_symbols = function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, glid, o, ...) {
	# ptdt (popup.title data) and popup.layout are passed via `...` to keep this
	# method's signature identical to the generic (see tm_data_polygons).
	dots = list(...)
	ptdt = dots$ptdt
	popup.layout = dots$popup.layout

	lf = get_lf(facet_row, facet_col, facet_page)

	rc_text = frc(facet_row, facet_col)

	res = select_sf(shpTM, dt[!is.na(dt$size) & !is.na(dt$shape), ])
	shp = res$shp
	if (o$crs_leaflet$crsClass  == "L.CRS.Simple") {
		shp = sf::st_set_crs(shp, NA)
	}
	dt = res$dt

	gp = impute_gp(gp, dt)
	gp = rescale_gp(gp, o$scale_down)

	coords = sf::st_coordinates(shp)

	# in case shp is a multipoint (point_per == "segment"), expand gp:
	cp = expand_coords_gp(coords, gp, ndt = nrow(dt))
	coords = cp$coords
	gp = cp$gp

	if (cp$expanded) {
		shpTM_match = match(shpTM$tmapID_expanded, shpTM$tmapID)
	} else {
		shpTM_match = TRUE
	}

	idt_null = is.null(idt)

	if (!idt_null) {
		idt = idt$id[match(dt$tmapID__[shpTM_match], idt$tmapID__)]
	} else {
		idt = sprintf("%07d", dt$tmapID__)[shpTM_match]
	}
	if (!is.null(hdt)) {
		hdt = hdt$hover[match(dt$tmapID__[shpTM_match], hdt$tmapID__)]
		hdt = lapply(hdt, htmltools::HTML, FUN.VALUE = character(1))
	}
	if (!is.null(ptdt)) {
		pttl = ptdt$title[match(dt$tmapID__[shpTM_match], ptdt$tmapID__)]
	} else {
		pttl = NULL
	}
	if (is.null(pdt)) {
		popups = NULL
	} else {
		mtch = match(dt$tmapID__[shpTM_match], pdt$tmapID__)
		pdt = pdt[mtch][, tmapID__ := NULL]

		if (!is.null(pttl)) {
			popups = view_format_popups(id = pttl, titles = names(pdt), values = pdt, format = popup.format, layout = popup.layout)
		} else if (idt_null) {
			popups = view_format_popups(titles = names(pdt), values = pdt, format = popup.format, layout = popup.layout)
		} else {
			popups = view_format_popups(id = idt, titles = names(pdt), values = pdt, format = popup.format, layout = popup.layout)
		}
	}

	clusterOpts = getClusterOpts(a$clustering)



	interactive = (!is.null(pdt) || !is.null(hdt))

	opt = leaflet::pathOptions(interactive = interactive, pane = pane)

	o$use_WebGL = impute_webgl(o$use_WebGL, dt, supported = c("fill", "size"), checkif = list(shape = c(1,16,19,20,21)), type = "symbols", hover = !is.null(hdt), popup = !is.null(pdt), crs_class = o$crs_leaflet$crsClass)

	use_circleMarkers = o$use_circle_markers && all(gp$shape %in% c(1, 16, 19, 20, 21))


	gp2 = gp_to_lpar(gp, mfun = "Symbols", size_factor = 14) # 14 based on similarity with plot mode and consistency with tmap3
	#gp = gp2leafgp(gp)
	names(gp2)[names(gp2) == 'stroke-width'] = "strokeWidth"
	gp2$baseSize = 20

	#po(sort(gp2$width, decreasing = T))

	shp2 = sf::st_as_sf(as.data.frame(coords), coords = c("X", "Y"), crs = st_crs(shp))

	# Screen-size factor for circle markers. The *visible* on-screen radius (in
	# leaflet px) is `gp2$width * multiplier` regardless of render path: the
	# WebGL path passes `radius = gp2$width` to addGlPoints and the circleMarkers
	# path passes `radius = gp2$width * multiplier`, but both render identically,
	# so addGlPoints' radius unit is effectively `multiplier` leaflet px. Using
	# this single quantity for hitbox sizing keeps the WebGL and non-WebGL
	# hitboxes identical. Only meaningful for circle shapes (the only shapes that
	# reach the WebGL / circleMarkers branches); harmless (-> 0.5) otherwise.
	multiplier = ifelse(gp2$shape == "solid-circle-md", 0.28, ifelse(gp2$shape == "solid-circle-sm", 0.25, 0.5)) # manually calibrated with 4k screen

	# process hitbox option (mirrors tm_lines):
	# an invisible, larger addCircleMarkers overlay carries the interaction
	# (label/popup/layerId) so that small symbols are easier to click/hover.
	#
	# The visible on-screen diameter (leaflet px) of a symbol is
	# `2 * gp2$width * multiplier` across all render paths (see note above;
	# for icons multiplier -> 0.5 so this degrades to gp2$width). The `auto`
	# rule fires only for small symbols (median visible diameter < 12, i.e.
	# below the 12px floor it would be raised to) when there are few enough
	# features, and floors the clickable diameter at 12px. pmax12 leaves
	# symbols already larger than 12px untouched.
	hitbox = if (isTRUE(a$hitbox == "auto")) {
		small = stats::median(2 * gp2$width * multiplier) < 12   # visible diameter (px)
		light = nrow(dt) < 10000
		if (small && light) "pmax12" else "none"
	} else {
		a$hitbox %||% "none"
	}

	# A hitbox is only meaningful when there is something to click (interactive)
	# and when markers are not clustered (clusters already provide a large
	# click target, and overlaying a second clustered layer would double-count).
	use_hitbox = interactive && hitbox != "none" && is.null(clusterOpts)
	if (use_hitbox) hb = parse_hitbox(hitbox)

	# helper: compute the invisible interaction radius (px) from a per-feature
	# *visible diameter* (px). Hitbox numbers (`plusX`, `pmaxX`) are interpreted
	# on the diameter, consistent with line `weight`; the overlay needs a radius.
	hitbox_radius = function(vis_diam) {
		d = vis_diam + hb$plus
		if (hb$pmax != 0) d = pmax(d, hb$pmax)
		d / 2
	}

	# helper: invisible interaction overlay (regular leaflet circle markers)
	add_hitbox = function(lf, layerId, radius) {
		leaflet::addCircleMarkers(lf,
								  data        = shp2,
								  layerId     = layerId,
								  radius      = radius,
								  stroke      = FALSE,
								  fill        = TRUE,
								  fillOpacity = 0,
								  options     = leaflet::pathOptions(interactive = TRUE, pane = pane),
								  group       = group,
								  label       = hdt,
								  popup       = popups)
	}

	if (o$use_WebGL) {
		if (!use_hitbox) {
			idt = submit_labels(idt[1], "symbolsGL", pane, group)

			lf |>  leafgl::addGlPoints(shp2, fillColor = gp2$fillColor, radius = gp2$width, fillOpacity = gp2$fillOpacity[1], pane = pane, group = group, label = hdt, popup = popups, layerId = idt) %>%
				assign_lf(facet_row, facet_col, facet_page)
		} else {
			# visible on-screen radius (leaflet px) = gp2$width * multiplier,
			# the same quantity the non-WebGL path uses -> identical hitboxes
			hb_radius = hitbox_radius(2 * gp2$width * multiplier)

			idt_gl = submit_labels(idt[1], "symbolsGL", pane, group)
			idt_hb = submit_labels(idt, "symbolsGL_hb", pane, group)

			lf |>
				# Fast WebGL rendering (no interaction; handled by overlay)
				leafgl::addGlPoints(shp2, fillColor = gp2$fillColor, radius = gp2$width, fillOpacity = gp2$fillOpacity[1], pane = pane, group = group, label = NULL, popup = NULL, layerId = idt_gl) |>
				# Invisible interaction layer (fatter hitbox)
				add_hitbox(layerId = idt_hb, radius = hb_radius) |>
				assign_lf(facet_row, facet_col, facet_page)
		}
	} else if (use_circleMarkers) {
		cidt = if (!is.null(clusterOpts)) submit_labels(idt[1], "symbolsCluster", pane, group) else NULL

		gp2$strokeWidth[gp2$shape %in% c("solid-circle-md", "solid-circle-bg", "solid-circle-sm")] = 0
		gp2$fillOpacity[gp2$shape %in% "open-circle"] = 0

		vis_radius = gp2$width * multiplier   # multiplier hoisted above

		if (!use_hitbox) {
			idt = submit_labels(idt, "symbols", pane, group)

			lf |>  leaflet::addCircleMarkers(data = shp2, layerId = idt,
											 color = gp2$color,
											 opacity = gp2$opacity,
											 weight = gp2$strokeWidth,
											 dashArray = gp2[["stroke-dasharray"]],
											 fillColor = gp2$fillColor,
											 fillOpacity = gp2$fillOpacity,
											 clusterOptions = clusterOpts,
											 clusterId = cidt,
											 radius = vis_radius,
											 options = opt,
											 group = group, label = hdt, popup = popups) |>
				assign_lf(facet_row, facet_col, facet_page)

		} else {
			idt_vis = submit_labels(idt, "symbols", pane, group)
			idt_hb  = submit_labels(idt, "symbols_hb", pane, group)

			hb_radius = hitbox_radius(vis_radius * 2)
			opt_vis = leaflet::pathOptions(interactive = FALSE, pane = pane)

			lf |>
				# Visible styled layer (non-interactive)
				leaflet::addCircleMarkers(data = shp2, layerId = idt_vis,
										  color = gp2$color,
										  opacity = gp2$opacity,
										  weight = gp2$strokeWidth,
										  dashArray = gp2[["stroke-dasharray"]],
										  fillColor = gp2$fillColor,
										  fillOpacity = gp2$fillOpacity,
										  radius = vis_radius,
										  options = opt_vis,
										  group = group) |>
				# Invisible interaction layer (fatter hitbox)
				add_hitbox(layerId = idt_hb, radius = hb_radius) |>
				assign_lf(facet_row, facet_col, facet_page)
		}

	} else {
		cidt = if (!is.null(clusterOpts)) submit_labels(idt[1], "cluster", pane, group) else NULL

		idt0 = idt # keep per-feature ids for the hitbox overlay
		idt = submit_labels(idt, "symbols", pane, group)
		idt_hb = if (use_hitbox) submit_labels(idt0, "symbols_hb", pane, group) else NULL

		sn = suppressWarnings(as.numeric(gp2$shape))

		is_num = !is.na(sn)
		sid = which(is_num)
		nid = which(!is_num)


		# ="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)

		k = nrow(gp2dfU)

		symbols = do.call(makeSymbolIcons2, as.list(gp2dfU[,-(ncol(gp2dfU)),with=F]))

		gp2dfU[, id:=1L:.N]
		gp2join = gp2df[gp2dfU, id:= id, on=names(gp2df)]
		ids = gp2join$id

		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))
		}

		if (is.null(popups)) {
			popups_grps =  rep(list(NULL), k)
		} else {
			popups_grps = split(popups, ids)
		}


		symbols$iconWidth = rep(NA, k)
		symbols$iconHeight = rep(NA, k)


		if (length(sid)) {
			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 = gp2dfU$width[sid2] / gp2dfU$baseSize[sid2]
			size = size * a$icon.scale/3

			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[sid2[i]] <- symbols_icons$iconAnchorX[i] * size[i]
					symbols$iconAnchorY[sid2[i]] <- symbols_icons$iconAnchorY[i] * size[i]

				}
			}
		}

		# when a hitbox overlay handles interaction, the icon markers themselves
		# carry no label/popup and are non-interactive
		marker_label = if (use_hitbox) replicate(k, list(NULL)) else hdt_grps
		marker_popup = if (use_hitbox) rep(list(NULL), k) else popups_grps

		for (i in 1L:k) {
			opt$zIndexOffset = i * 1e5
			if (use_hitbox) opt$interactive = FALSE
			.TMAP_LEAFLET$markerLayers = c(.TMAP_LEAFLET$markerLayers, opt$pane) # register for additional css
			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 = marker_label[[i]],
									clusterOptions = clusterOpts,
									clusterId = cidt,
									popup = marker_popup[[i]],
									options = opt
				)
		}

		if (use_hitbox) {
			# icon px size ~ gp2$width (per feature) -> use as visible diameter proxy
			hb_radius = hitbox_radius(gp2$width)
			lf = lf |> add_hitbox(layerId = idt_hb, radius = hb_radius)
		}

		lf |> assign_lf(facet_row, facet_col, facet_page)

	}


	# if (o$use_WebGL) {
	# 	lf %>%
	# 		leafgl::addGlPoints(sf::st_sf(shp), fillColor = gp$fill, radius = gp$size*10, fillOpacity = gp$fill_alpha, color = gp$col, opacity = gp$color_alpha, weight = gp$lwd, pane = pane, group = group) %>%
	# 		assign_lf(facet_row, facet_col, facet_page)
	# } else {
	# 	lf %>%
	# 		leaflet::addCircleMarkers(lng = coords[, 1], lat = coords[, 2], fillColor = gp$fill, radius = gp$size*4, fillOpacity = gp$fill_alpha, color = gp$col, opacity = gp$color_alpha, weight = gp$lwd, group = group, options = opt) %>%
	# 		assign_lf(facet_row, facet_col, facet_page)
	# }

	NULL
}


#' @export
#' @rdname tmapGridLeaflet
tmapLeafletDataPlot.tm_data_dots = function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, glid, o, ...) {
	NextMethod()
}

#' @export
#' @rdname tmapGridLeaflet
tmapLeafletDataPlot.tm_data_bubbles = function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, glid, o, ...) {
	NextMethod()
}

#' @export
#' @rdname tmapGridLeaflet
tmapLeafletDataPlot.tm_data_squares = function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, glid, o, ...) {
	NextMethod()
}

#' @export
#' @rdname tmapGridLeaflet
tmapLeafletDataPlot.tm_data_markers = function(a, shpTM, dt, pdt, popup.format, hdt, idt, gp, bbx, facet_row, facet_col, facet_page, id, pane, group, glid, o, ...) {
	NextMethod()
}