R/step2_data.R

In tmap: Thematic Maps

step2_data = function(tm) {
	dev = getOption("tmap.devel.mode")

	tmo = tm$tmo
	o = tm$o
	aux = tm$aux
	cmp = tm$cmp
	prx = tm$prx

	if (is.null(tmo)) {
		return(	list(tmo = NULL, aux = aux, cmp = cmp, prx = prx, o = o))
	}

	groupnames = paste0("group", seq_along(tmo))
	fl = list(1L, 1L, 1L)
	assign("fl", fl, envir = .TMAP)

	# to reset the legends (which are  temporarily stored in .TMAP environment)
	legends_init()
	charts_init()

	grps = mapply(function(tmg, groupname) {
		tmf = tmg$tmf
		dt = tmg$tms$dt

		type_ids = tmg$tms$type_ids
		type_vars = tmg$tms$type_vars # used to split dt vars in the layer functions, e.g. for networks with edges and nodes

		if ("by1__" %in% names(dt) && o$rev1) dt[, by1__ := (o$fn[1]+1L)-by1__]
		if ("by2__" %in% names(dt) && o$rev2) dt[, by2__ := (o$fn[2]+1L)-by2__]
		if ("by3__" %in% names(dt) && o$rev3) dt[, by3__ := (o$fn[3]+1L)-by3__]

		shpvars = tmg$tms$smeta$vars

		# step2_data_grp_prepare
		#tmf_meta = step2_data_grp_prepare(tmg$tmf, grpvars, dt)

		layernames = paste0("layer", seq_along(tmg$tmls))
		lrs = mapply(function(tml, layername) {
			glid = paste0(groupname, "_", layername)

			#cat("step2_grp_lyr======================\n")

			if (!is.null(type_ids)) {
				ids = tml$layer %in% names(type_ids)
				if (any(ids)) {
					lid = tml$layer[[which(ids)[1]]]
					tmapids = type_ids[[lid]]
					dt = data.table::copy(dt[dt$tmapID__ %in% tmapids, c(type_vars[[lid]], "sel__"), with = FALSE])
				}

			}

			gp = tml$gpar
			tp = tml$tpar

			plot.order = tml$plot.order

			group = if (is.na(tml$group)) tmg$tms$shp_name else as.character(tml$group)
			group.control = as.character(tml$group.control)

			.TMAP$popup.format = tml$popup.format

			mfun = tml$mapping.fun

			# args will be passed on to the scale functions (in case needed)
			# they also will be used in step 3 (trans) and step 4 (mapping)
			if (is.null(dt)) {
				# bypass (e.g. in case of pmtiles)
				trans = list()
				mapping = mapply(getdts, tml$mapping.aes, names(tml$mapping.aes), SIMPLIFY = FALSE, MoreArgs = list(p = gp, q = tmf, o = o, dt = dt, shpvars = shpvars, layer = tml$layer, group = group, glid = glid, mfun = mfun, args = tml$mapping.args, plot.order = plot.order))
				#mapping = list()
			} else {
				trans = mapply(getdts, tml$trans.aes, names(tml$trans.aes), SIMPLIFY = FALSE, MoreArgs = list(p = tp, q = tmf, o = o, dt = dt, shpvars = shpvars, layer = tml$layer, group = group, glid = glid,mfun = mfun, args = tml$trans.args, plot.order = plot.order))

				mapping = mapply(getdts, tml$mapping.aes, names(tml$mapping.aes), SIMPLIFY = FALSE, MoreArgs = list(p = gp, q = tmf, o = o, dt = dt, shpvars = shpvars, layer = tml$layer, group = group, glid = glid,mfun = mfun, args = tml$mapping.args, plot.order = plot.order))
			}


			dts_trans = cbind_dts(lapply(trans, function(x) x$dt), plot.order)
			trans_legend = lapply(trans, function(x) x$leg)

			dts_mapping = cbind_dts(lapply(mapping, function(x) x$dt), plot.order)
			mapping_legend = lapply(mapping, function(x) x$leg)
			if (dev) timing_add(s4 = "combine")
			if (dev) timing_add(s3 = paste0("layer ", tml$layer))


			if (!length(tml$popup.vars) || is.null(dt)) {
				popup.data = NULL
			} else {
				# tml$popup.vars = tml$popup.vars
				# 	intersect(tml$popup.vars, names(dt)) # in case type_ids !NULL

				popupvars = intersect(tml$popup.vars, names(dt))

				if (!length(popupvars)) {
					popup.data = NULL
				} else {
					if (!is.null(names(tml$popup.vars))) {
						popupvars = structure(popupvars, names = names(tml$popup.vars)[match(popupvars, tml$popup.vars)])
					}

					popup.data = copy(dt[, c(popupvars, "tmapID__"), with = FALSE])
					if (!is.null(names(popupvars))) popup.data = data.table::setnames(popup.data, old = unname(popupvars), new = names(popupvars))
				}
			}
			hover.data = if (tml$hover == "" || is.null(dt)) {
				NULL
			} else {
				data.table(hover = as.character(dt[[tml$hover]]), tmapID__ = dt$tmapID__)
			}
			id.data = if (tml$id == "" || is.null(dt)) {
				NULL
			} else {
				data.table(id = as.character(dt[[tml$id]]), tmapID__ = dt$tmapID__)
			}

			# popup.title: a data variable used as the popup header. Overrules
			# `id` for the popup title (analogous to how `hover` overrules `id`
			# for hover labels). `tml$popup.title` is NULL for layers that do
			# not set it (e.g. extension layers), or NA when not specified.
			popup.title = tml$popup.title
			popup.title.data = if (is.null(popup.title) || (length(popup.title) == 1L && is.na(popup.title)) || is.null(dt)) {
				NULL
			} else if (!popup.title %in% names(dt)) {
				NULL
			} else {
				ptt = data.table(title = as.character(dt[[popup.title]]), tmapID__ = dt$tmapID__)
				if (!is.null(names(popup.title)) && names(popup.title) != "") {
					attr(ptt, "label") = names(popup.title)
				}
				ptt
			}

			format_called = attr(tml$popup.format, "called")
			if (length(format_called) > 0L) {
				.TMAP$popup.format[format_called] = tml$popup.format[format_called]
			}


			list(trans_dt = dts_trans,
				 trans_legend = trans_legend,
				 trans_fun = tml$trans.fun,
				 trans_args = tml$trans.args,
				 trans_apply = tml$trans.apply_to,
				 mapping_dt = dts_mapping,
				 mapping_legend = mapping_legend,
				 mapping_fun = tml$mapping.fun,
				 mapping_args = tml$mapping.args,
				 lid = tml$lid,
				 group = group,
				 glid = glid,
				 group.control = group.control,
				 popup.data = popup.data,
				 popup.format = .TMAP$popup.format,
				 popup.title.data = popup.title.data,
				 popup.layout = tml$popup.layout,
				 hover.data = hover.data,
				 id.data = id.data,
				 plot.order = plot.order, # passed on for step 3 non-data driven transformation
				 gp = gp,
				 tp = tp)
		}, tmg$tmls, layernames, SIMPLIFY = FALSE, USE.NAMES = FALSE)
		if (length(lrs)) names(lrs) = layernames

		shpDT = data.table(shpTM = list(tmg$tms$shpTM))
		if (dev) timing_add(s2 = "group")

		list(layers = lrs, shpDT = shpDT)
	}, tmo, groupnames, SIMPLIFY = FALSE, USE.NAMES = FALSE)
	names(grps) = groupnames
	#attr(grps, "fl") = fl
	#attr(grps, "main") = attr(tmo, "main")
	#attr(grps, "crs") = attr(tmo, "crs")

	#tmf = get_tmf(lapply(tmo, function(tmoi) tmoi$tmf))



	# facet labels "_old' were obtained in step2, and still determine data levels
	# currently, facet labels are determined in step1, but they need to be the same as the data labels
	# o$fl_old = get("fl", envir = .TMAP)
	# o$fn_old = sapply(o$fl_old, function(f) {
	# 	if (is.character(f)) length(f) else f
	# })
	# o$fl_old = lapply(o$fl_old, function(f) {
	# 	if (is.character(f)) f else NULL
	# })
	#
	# if (!identical(o$fn, o$fn_old) || !identical(o$fl, o$fl_old)) {
	# 	po(o$fn_old, o$fl_old, o$fn, o$fl)
	# 	stop("fl not identical")
	# }



	#cat("fl old:\n")
	#print(o$fl_old)


	#o = c(o, tmf)

	# attr(grps, "is.wrap") = tmo[[1]]$tmf$is.wrap
	# attr(grps, "nrows") = tmo[[1]]$tmf$nrows
	# attr(grps, "ncols") = tmo[[1]]$tmf$ncols

	o = within(o, {
		if (rev1) fl[[1]][] = rev(fl[[1]][])
		if (rev2) fl[[2]][] = rev(fl[[2]][])
		if (rev3) fl[[3]][] = rev(fl[[3]][])
	})

	list(tmo = grps, aux = aux, cmp = cmp, prx = prx, o = o)
}