R/view_functions.R

In mtennekes/tmap: Thematic Maps

split_alpha_channel <- function(x, alpha) {
	if (is.null(x)) {
		list(col=NULL, opacity=0)
	} else {
		RGBA <- col2rgb(x, alpha = TRUE)
		col <- rgb(RGBA[1,], RGBA[2,], RGBA[3,], maxColorValue = 255)
		opacity <- unname(RGBA[4,]/255 * alpha)
		list(col=col, opacity=opacity)
	}
}
get_x_name <- function(type) {
	if (type=="fill") {
		"xfill"
	} else if (type=="symbol") {
		c("xsize", "xcol", "xshape")
	} else if (type=="raster") {
		"xraster"
	} else if (type=="line") {
		c("xline", "xlwd")
	} else if (type=="text") {
		c("xtext", "xtsize", "xtcol")
	}
}

get_aes_name <- function(type) {
	if (type=="fill") {
		"fill"
	} else if (type=="symbol") {
		c("symbol.size", "symbol.col", "symbol.shape")
	} else if (type=="raster") {
		"raster"
	} else if (type=="line") {
		c("line.col", "line.lwd")
	} else if (type=="text") {
		c("text", "text.size", "text.color")
	}
}

get_labels <- function(gpl, type) {
	var_names <- paste(type, "names", sep=".")
	gpl$data[[gpl[[var_names]]]]
}

get_popups <- function(gpl, type) {
	var_names <- paste(type, "names", sep=".")
	var_vars <- paste(type, "popup.vars", sep=".")
	var_format <- paste(type, "popup.format", sep=".")
	
	dt <- gpl$data
	
	if (is.na(gpl[[var_vars]][1])) {
		popups <- NULL
	} else {
		popups <- view_format_popups(dt[[gpl[[var_names]]]], gpl[[var_vars]], gpl[[var_format]], dt[, gpl[[var_vars]], drop=FALSE])
	}
	popups
}


working_internet <- function(url = "https://www.google.com") {
	# test the http capabilities of the current R build
	if (!capabilities(what = "http/ftp")) return(FALSE)
	
	# test connection by trying to read first line of url
	test <- try(suppressWarnings(readLines(url, n = 1)), silent = TRUE)
	# return FALSE if test inherits 'try-error' class
	!inherits(test, "try-error")
}

bbx_per_line <- function(bbx) {
	max_lines <- 60
	(bbx[4] - bbx[2]) / max_lines
}

units_per_line <- function(bbx) {
	max_lines <- 60
	
	# calculate top-center to bottom-center
	vdist <- suppressWarnings({tmaptools::approx_distances(bbx, projection = 4326, target = "m")$vdist})
	vdist/max_lines
}

lty2dashArray <- function(lty) {
	numlty <- switch(lty,
					 solid=0,
					 blank=0,
					 # These numbers taken from ?par
					 dashed=c(4, 4),
					 dotted=c(1, 3),
					 dotdash=c(1, 3, 4, 3),
					 longdash=c(7, 3),
					 twodash=c(2, 2, 6, 2),
					 # Otherwise we're a hex string
					 as.numeric(as.hexmode(strsplit(lty, "")[[1]])))
	paste(ifelse(numlty == 0,
				 "none",
				 numlty),
		  collapse=",")
}

get_epsg_number <- function(proj) {
	if (inherits(proj, "crs")) {
		if (!is.na(proj$epsg)) {
			return(proj$epsg)	
		} else {
			proj <- proj$proj4string
		}
	}
	if (inherits(proj, "CRS")) proj <- attr(proj, "projargs")
	
	pat <- "^.*\\=epsg ?: ?(\\S*)(.*)$"
	epsg <- as.numeric(sub(pat, "\\1", proj[grepl(pat, proj)]))
	if (length(epsg)==0) NA else epsg
}


submit_labels <- function(labels, cls, pane, group_name, e) {
	
	layerIds <- get("layerIds", envir = e)
	
	
	types <- attr(layerIds, "types")
	groups <- attr(layerIds, "groups")
	
	labels_all <- unlist(layerIds, use.names = FALSE)
	
	pos <- length(labels_all)
	
	labels_all <- make.names(c(labels_all, labels), unique = TRUE)
	
	labels <- labels_all[(pos + 1): length(labels_all)]	
	
	labelsList <- list(labels)
	names(labelsList) <- pane
	
	layerIds <- c(layerIds, labelsList)
	
	#layerIds[[cls]] <- labels_all
	
	attr(layerIds, "types") <- c(types, cls)
	attr(layerIds, "groups") <- c(types, group_name)
	
	assign("layerIds", layerIds, envir = e)
	labels
}

paneName <- function(x) {
	paste0("tmap", sprintf("%03d", x))
}

legendName <- function(x) {
	paste0("legend", sprintf("%03d", x))
}