R/tmap_mode.R

In tmap: Thematic Maps

#' Get or set tmap mode
#'
#' @description
#' * `tmap_mode()` gets (no argument) or sets the current mode.
#' * `ttm()` toggles between the two most recent modes.
#' * `ttmp()` same as `ttm()`, then calls [tmap_last()].
#' * `rtm()` rotates through all modes in the pool.
#' * `rtmp()` same as `rtm()`, then calls [tmap_last()].
#' * `tmap_mode_pool()` restricts which modes are cycled by [ttm()] and [rtm()].
#'   Call without arguments to inspect the current pool, or pass `NULL` to reset.
#'
#' It is recommended to use `tmap_mode()` in scripts and `ttm()`/`ttmp()` in the console.
#'
#' @details
#' The default modes are `"plot"` (static, graphics device) and `"view"` (interactive,
#' browser or RStudio Viewer). Additional modes such as `"maplibre"` and `"mapbox"` become
#' available when \pkg{tmap.mapgl} is loaded.
#'
#' @param mode A string specifying the mode. See [tmap_options()] for available modes.
#' @param silent Should the mode be switched silently? Default `FALSE`.
#' @param modes Character vector of mode names (minimum 2), or `NULL` to reset.
#' @return
#' * `tmap_mode()` returns the current mode invisibly when called without argument,
#'   otherwise the previous mode.
#' * `ttm()`, `rtm()` return the previous mode invisibly.
#' * `tmap_mode_pool()` returns the previous pool invisibly.
#' @example ./examples/tmap_mode.R
#' @seealso
#' * .doc_see_also_modes()
#' * [tmap_last()] to show the last map
#' * [tm_view()] for viewing options
#' * [tmap_leaflet()] for obtaining a leaflet widget
#' * [tmap_options()] for tmap options
#' @references Tennekes, M., 2018, {tmap}: Thematic Maps in {R},
#' Journal of Statistical Software, 84(6), 1-39, \doi{10.18637/jss.v084.i06}
#' @export
tmap_mode = function(mode = NULL, silent = FALSE) {
	type = if (is.null(mode)) "get" else "set"
	set_mode(mode, show.messages = !silent && get("tmapOptions", envir = .TMAP)$show.messages, type = type)
}


#' @rdname tmap_mode
#' @export
ttm = function() {
	set_mode(show.messages = get("tmapOptions", envir = .TMAP)$show.messages, type = "toggle")
}

#' @rdname tmap_mode
#' @export
rtm = function() {
	set_mode(show.messages = get("tmapOptions", envir = .TMAP)$show.messages, type = "rotate")
}


set_mode = function(mode = NULL, show.messages = FALSE, type = "set") {
	mode_now = getOption("tmap.mode")

	modes = get_modes()
	id = match(mode_now, modes)

	arrow = length(modes) > 2

	if (type == "get") {
		mode_next = mode_now
		id_next = id
	} else if (type == "set") {
		if (!mode %in% modes) {
			if (mode %in% c("maplibre", "mapbox")) {
				cli::cli_abort(c(
					"Mode {.val {mode}} requires the {.pkg tmap.mapgl} package.",
					"i" = "Please install and load it first: {.run library(tmap.mapgl)}"
				), call = rlang::caller_env())
			} else {
				cli::cli_abort(c(
					"{.val {mode}} is not a valid tmap mode.",
					"i" = "Must be one of {.or {.val {modes}}}."
				), call = rlang::caller_env())
			}
		}

		mode_next = rlang::arg_match0(mode, modes)
		id_next = match(mode_next, modes)
	} else if (type == "toggle") {
		mode_next = .TMAP$mode_last
		if (is.null(mode_next) || !mode_next %in% modes) {
			mode_next = modes[modes != mode_now][1]
		}
		id_next = match(mode_next, modes)
	} else {
		id_next = id + 1L
		if (id_next > length(modes)) id_next = 1L
		mode_next = modes[id_next]
	}

	modes_str = paste0("{.val ", modes, "}")
	modes_str[id_next] = paste0("{.strong ", modes_str[id_next], "}")
	rotate_str = paste(modes_str, collapse = ifelse(arrow, " -> ", " - "))

	if (mode_now != mode_next) {
		.TMAP$mode_last = mode_now
		options(tmap.mode = mode_next)
		fill_providers()
	}

	if (show.messages) {
		str1 = paste0("tmap modes ", rotate_str)
		str2 = paste0(ifelse(arrow, "rotate with {.run tmap::rtm()}", ""),
					 ifelse(arrow, "switch to {.str {mode_now}} ", "toggle "),
					 "with {.run tmap::ttm()}")

		cli::cli_inform(c("i" = str1))
		cli::cli_inform(c("i" = str2), .frequency = "once", .frequency_id = paste0("mode", ifelse(arrow, "_rotate", "toggle")))
	}

	invisible(mode_now)
}


# tmap_graphics = function(mode = NULL) {
# 	if (is.null(mode)) mode = getOption("tmap.mode")
# 	get("tmapOptions", envir = .TMAP)$graphics[[mode]]
# }
#
# tmap_graphics_name = function(mode = NULL) {
# 	tmap_graphics(mode = mode)$name
# }

# Internal: always returns the full set of registered modes,
# regardless of any active pool. Used for validation.
get_all_modes = function() {
	names(get("tmapOptions", envir = .TMAP)$modes)
}

# Internal: returns the active pool if set, otherwise all modes.
# This is what ttm() and rtm() cycle through.
get_modes = function() {
	.TMAP$mode_pool %||% get_all_modes()
}

#' @rdname tmap_mode
#' @export
tmap_mode_pool = function(modes = NULL, silent = FALSE) {
	all_modes    = get_all_modes()
	prev_pool    = .TMAP$mode_pool %||% all_modes
	show_message = !silent && get("tmapOptions", envir = .TMAP)$show.messages

	# getter
	if (missing(modes)) {
		if (show_message) cli::cli_inform(c("i" = "Current mode pool: {.val {prev_pool}}"))
		return(invisible(prev_pool))
	}

	# reset
	if (is.null(modes)) {
		.TMAP$mode_pool = NULL
		if (show_message) cli::cli_inform(c("i" = "Mode pool reset to: {.val {all_modes}}"))
		return(invisible(prev_pool))
	}

	# validate
	if (length(modes) < 2L) {
		cli::cli_abort("The mode pool must contain at least 2 modes.",
					   call = rlang::caller_env())
	}

	bad = setdiff(modes, all_modes)
	if (length(bad) > 0L) {
		cli::cli_abort(c(
			"Invalid mode{?s}: {.val {bad}}",
			"i" = "Available modes: {.val {all_modes}}"
		), call = rlang::caller_env())
	}

	mode_now = getOption("tmap.mode")
	if (!mode_now %in% modes) {
		cli::cli_abort(c(
			"Current mode {.val {mode_now}} must be included in the pool.",
			"i" = "Either add it: {.run tmap_mode_pool(c({toString(shQuote(c(mode_now, modes)))}))}",
			"i" = "Or switch mode first: {.run tmap_mode(\"{modes[1]}\")}"
		), call = rlang::caller_env())
	}

	.TMAP$mode_pool = modes
	if (show_message) cli::cli_inform(c("i" = "Mode pool set to: {.val {modes}}"))
	invisible(prev_pool)
}

#' Toggle design overlay
#'
#' When the so-called "design mode" is enabled,
#' the composition of the plot is shown explicitly in plot mode.
#' The used color codings is printed in the console as well as information about plot size and aspect ratio.
#'
#' This function sets the global option `tmap.design.mode`.
#' It can be used as toggle function without arguments.
#'
#' @seealso [tmap_options()]
#' @param design.mode Logical value that determines the design mode.
#'   If omitted then the design mode is toggled.
#' @export
tmap_design_mode = function(design.mode) {
	dm = if (missing(design.mode)) {
		!getOption("tmap.design.mode")
	} else {
		if (!is.logical(design.mode)) stop("design.mode is not a logical")
		design.mode[1]
	}

	options(tmap.design.mode = dm)
	message(
		"design.mode: ", if (!dm) "OFF" else "ON",
		if (dm && getOption("tmap.mode") == "view") " (only effective in plot mode)" else "")
}

#' Toggle developer diagnostics
#'
#' When the so-called "development mode" is enabled, helpful messages and timings
#' are printed in the console
#'
#' @param devel.mode logical value that determines the development mode.
#'   If omitted then the development mode is toggled.
#' @export
tmap_devel_mode = function(devel.mode) {
	dm = if (missing(devel.mode)) {
		!getOption("tmap.devel.mode")
	} else {
		if (!is.logical(devel.mode)) stop("devel.mode is not a logical")
		devel.mode[1]
	}

	options(tmap.devel.mode = dm)
	message("devel.mode: ", if (!dm) "OFF" else "ON")
}

pm = function(message) {
	cat("<><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>\n")
	cat(message, "\n")
}

po = function(...) {
	e = substitute(list(...))
	nms = sapply(e, deparse)[-1]

	x = list(...)

	for (i in seq_along(x)) {
		cat("<==================== ", nms[i], "===============>\n")
		print(x[[i]])
		if (i == length(x)) {
			cat("</============================================>\n")
		}
	}

	invisible()
}

so = function(...) {
	e = substitute(list(...))
	nms = sapply(e, deparse)[-1]

	x = list(...)

	for (i in seq_along(x)) {
		cat("<==================== ", nms[i], "===============>\n")
		str(x[[i]])
		if (i == length(x)) {
			cat("</============================================>\n")
		}
	}

	invisible()
}

#' @rdname tmap_mode
#' @export
ttmp = function() {
	ttm()
	tmap_last()
}

#' @rdname tmap_mode
#' @export
rtmp = function() {
	rtm()
	tmap_last()
}