R/map_cat2shape.R

In mtennekes/tmap: Thematic Maps

cat2shape <- function(x, 
					  var,
					  shapes,
					  drop.levels = FALSE,
					  legend.labels = NULL,
					  shapeNA = NA,
					  legend.NA.text = "Missing",
					  showNA = NA,
					  legend.format=list(align="left"),
					  reverse = FALSE) {
	
	sel <- attr(x, "sel")
	if (is.null(sel)) sel <- rep(TRUE, length(x))
	
	x[!sel] <- NA
	
	gt <- get("tmapOptions", envir = .TMAP_CACHE)
	show.messages <- gt$show.messages
	show.warnings <- gt$show.warnings
	
	
	if (!is.factor(x)) x <- factor(x, levels=sort(unique(x)))
	
	
	# drop levels
	if (drop.levels) {
		y <- droplevels(x)
		matching <- match(levels(y), levels(x))
		if (length(shapes) == nlevels(x)) {
			shapes <- shapes[matching]
		}
		if (!is.null(legend.labels) && (length(legend.labels) == nlevels(x))) {
			legend.labels <- legend.labels[matching]
		}
		x <- y
	}	
	
	
	nCol <- nlevels(x)
	max_levels <- length(shapes)
	
	named <- !is.null(names(shapes))
	

	if (named) {
		nms <- names(shapes)
		xs <- levels(x)
		
		if (!setequal(xs, nms)) {
			c1 <- setdiff(xs, nms)
			c2 <- setdiff(nms, xs)
			txt <- paste0("Names of shapes argument do not match with the values of the variable \"", var, "\".")
			if (length(c1)>0) {
				stop(paste0(txt, " Values not specified in shapes argument: \"", paste(c1, collapse="\", \""), "\".")	, call. = FALSE)
			} else if (show.messages) {
				message(paste0(txt, " Names in shapes argument for which no values exist: \"", paste(c2, collapse="\", \""), "\"."))
			}
		}
		shapes <- shapes[match(xs, nms)]
	} else {
		if (nCol > max_levels) {
			if (show.warnings) warning("Number of levels (unique values) is ", nCol, ", which is larger than number of symbol shapes (", max_levels, ").", call. = FALSE)
			mapping <- if (max_levels==1) {
				rep(1, nCol)
			} else as.numeric(cut(seq.int(nCol), breaks=max_levels))
			to <- c(which(mapping[-nCol] - mapping[-1]!=0), nCol)
			from <- c(0, to[-max_levels]) + 1
			
			lvls <- levels(x)
			new_lvls <- paste0(lvls[from], "...", lvls[to])
			
			x <- factor(mapping[as.integer(x)], levels=1:max_levels, labels=new_lvls)
		}
		nCol <- nlevels(x)		
	}
	
	

	
	# in case the number of shapes is more than the number of levels
	shapes <- rep(shapes, length.out=nCol) 
	
	if (is.null(legend.labels)) {
		legend.labels <- levels(x)	
	} else {
		legend.labels <- rep(legend.labels, length.out = nCol)
	}
	
	
	shps <- shapes[as.integer(x)]
	shpsNA <- is.na(shps)
	
	
	if (any(shpsNA)) {
		if (is.na(showNA)) showNA <- any(shpsNA & sel)
		shps[shpsNA] <- shapeNA
	} else {
		if (is.na(showNA)) showNA <- FALSE
	}
	
	legend.values <- legend.labels
	
	if (reverse) {
		legend.labels <- rev(legend.labels)
		shapes <- rev(shapes)
	}
	
	if (showNA) {
		legend.labels <- c(legend.labels, legend.NA.text)
		shapes <- c(shapes, shapeNA)
	}
	attr(legend.labels, "align") <- legend.format$text.align
	list(shps=shps, legend.labels=legend.labels, legend.values=legend.values, shapes=shapes)
}