1# Author: Robert J. Hijmans
2# Date :  June 2019
3# Version 1.0
4# License GPL v3
5
6
7setMethod("dots", signature(x="SpatVector"),
8	function(x, field, size,  ...) {
9		n <- length(x)
10		if (n < 1) return(NULL)
11		#method <- match.arg(tolower(method), c("regular", "random"))
12		if (is.character(field)) {
13			stopifnot(field %in% names(x))
14		} else {
15			stopifnot(field > 0 && field <= ncol(x))
16		}
17		stopifnot(is.numeric(x[[field,drop=TRUE]]))
18		field <- x[[field,drop=TRUE]]
19		size <- size[1]
20		stopifnot(size > 0)
21		d <- round(field / size)
22		d[d < 1 | is.na(d)] <- 0
23		i <- d > 0;
24		if (sum(i) == 0) {
25			error("dots", "'size' is too small")
26		}
27		s <- spatSample(x[i], d[i], method="random")
28		if (.Device  != "null device") {
29			try(points(s, ...), silent=TRUE)
30		}
31		invisible(s)
32	}
33)
34
35
36
37.plotLines <- function(x, out, lty=1, lwd=1, ...) {
38	cols <- out$cols
39	if (is.null(cols)) cols = rep("black", length(x))
40
41	g <- geom(x, df=TRUE)
42	g <- split(g, g[,1])
43	g <- lapply(g, function(x) split(x, x[,2]))
44	#p <- sapply(g, function(x) lapply(x, function(y) lines(y[,3:4], ...))
45	n <- length(g)
46	lty <- rep_len(lty, n)
47	lwd <- rep_len(lwd, n)
48	for (i in 1:n) {
49		x <- g[[i]]
50		for (j in 1:length(x)) {
51			lines(x[[j]][,3:4], col=out$main_cols[i], lwd=lwd[i], lty=lty[i], ...)
52		}
53	}
54	out$leg$lwd <- lwd
55	out$leg$lty <- lty
56	out
57}
58
59.plotPolygons <- function(x, out, lty=1, lwd=1, density=NULL, angle=45, ...) {
60
61	g <- geom(x, df=TRUE)
62	g <- split(g, g[,1])
63	g <- lapply(g, function(y) split(y, y[,2]))
64	n <- length(g)
65	if (!is.null(out$leg$border)) {
66		out$leg$border <- rep_len(out$leg$border, n)
67	} else {
68		out$leg$border <- NA
69	}
70	if (!is.null(density)) {
71		out$leg$density <- rep_len(density, length(g))
72		out$leg$angle <- rep_len(angle, n)
73	}
74	out$leg$lty <- rep_len(lty, n)
75	out$leg$lwd <- rep_len(lwd, n)
76
77	w <- getOption("warn")
78	on.exit(options("warn" = w))
79	for (i in 1:length(g)) {
80		gg <- g[[i]]
81		for (j in 1:length(gg)) {
82			a <- gg[[j]]
83			if (any(is.na(a))) next
84			if (any(a[,5] > 0)) {
85				a <- split(a, a[,5])
86				a <- lapply(a, function(i) rbind(i, NA))
87				a <- do.call(rbind, a )
88				a <- a[-nrow(a), ]
89				# g[[i]][[1]] <- a
90			}
91			if (!is.null(out$leg$density)) {
92				graphics::polygon(a[,3:4], col=out$main_cols[i], density=out$leg$density[i], angle=out$leg$angle[i], border=NA, lwd=out$leg$lwd[i], lty=out$leg$lty[i], ...)
93				graphics::polypath(a[,3:4], col=NA, rule="evenodd", border=out$leg$border[i], lwd=out$leg$lwd[i], lty=out$leg$lty[i], ...)
94			} else {
95				graphics::polypath(a[,3:4], col=out$main_cols[i], rule = "evenodd", border=out$leg$border[i], lwd=out$leg$lwd[i], lty=out$leg$lty[i], ...)
96			}
97		}
98		options("warn" = -1)
99	}
100	invisible(out)
101}
102
103
104.vplot <- function(x, out, xlab="", ylab="", cex=1, pch=20, ...) {
105	if (out$leg$geomtype == "points") {
106		points(x, col=out$main_cols, cex=cex, pch=pch, ...)
107		#if (!out$add) {
108		#	e <- out$lim
109		#}
110		out$leg$pch = pch
111		out$leg$pt.cex = cex
112	} else {
113		#e <- matrix(as.vector(ext(x)), 2)
114		if (out$leg$geomtype == "polygons") {
115			out <- .plotPolygons(x, out, density=out$leg$density, angle=out$leg$angle, ...)
116		} else {
117			out <- .plotLines(x, out, ...)
118		}
119	}
120	out
121}
122
123
124.getCols <- function(n, cols) {
125	if (!is.null(cols)) {
126		ncols <- length(cols)
127		if (ncols > n) {
128			steps <- ncols/n
129			i <- round(seq(1, ncols, steps))
130			cols <- cols[i]
131		} else if (ncols < n) {
132			cols <- rep_len(cols, n)
133		}
134	}
135	cols
136}
137
138
139.vect.legend.none <- function(out) {
140	#if (out$leg$geomtype == "points") {
141		out$main_cols <- .getCols(out$ngeom, out$cols)
142	#} else {
143	#	out$cols <- .getCols(out$ngeom, out$cols)
144	#}
145	out
146}
147
148.vect.legend.classes <- function(out) {
149	ucols <- .getCols(length(out$uv), out$cols)
150
151	out$uv <- sort(out$uv)
152
153	i <- match(out$v, out$uv)
154	out$cols <- ucols
155	out$main_cols <- ucols[i]
156
157	out$levels <- out$uv
158	out$leg$legend <- out$uv
159	nlevs <- length(out$uv)
160
161	cols <- out$cols
162	ncols <- length(cols)
163	if (nlevs < ncols) {
164		i <- trunc((ncols / nlevs) * 1:nlevs)
165		cols <- cols[i]
166	} else {
167		cols <- rep_len(cols, nlevs)
168	}
169	out$leg$fill <- cols
170	out$legend_type <- "classes"
171
172	if (is.null(out$leg$x)) { # && is.null(out$leg$ext)) {
173		out$leg$x <- "top"
174	}
175
176	out
177}
178
179
180.vect.legend.continuous <- function(out) {
181
182	z <- stats::na.omit(out$v)
183	n <- length(z)
184	if (n == 0) error("plot", "no values")
185	if (!is.numeric(out$v)) {
186		out$v <- as.integer(as.factor(out$v))
187		z <- stats::na.omit(out$v)
188		n <- length(z)
189	}
190	#out$range <- range(z)
191
192	interval <- (out$range[2]-out$range[1])/(length(out$cols)-1)
193	breaks <- out$range[1] + interval * (0:(length(out$cols)-1))
194
195	out$legend_type <- "continuous"
196	if (is.null(out$levels)) {
197		out$levels <- 5
198	}
199	if (is.null(out$leg$digits)) {
200		dif <- diff(out$range)
201		if (dif == 0) {
202			out$leg_digits = 0;
203		} else {
204			out$leg$digits <- max(0, -floor(log10(dif/10)))
205		}
206	}
207
208	if (is.null(out$leg$loc)) out$leg$loc <- "right"
209
210	brks <- seq(out$range[1], out$range[2], length.out = length(out$cols))
211	grps <- cut(out$v, breaks = brks, include.lowest = TRUE)
212	out$main_cols <- out$cols[grps]
213
214	out
215}
216
217
218.vect.legend.interval <- function(out, dig.lab=3, ...) {
219
220	nmx <- length(out$uv)
221	if (!is.numeric(out$v)) {
222		out$v <- as.integer(as.factor(out$v))
223	}
224
225	if (is.null(out$breaks)) {
226		out$breaks <- min(5, nmx)
227	}
228
229	if (length(out$breaks) == 1) {
230		out$breaks <- .get_breaks(out$v, out$breaks, out$breakby, out$range)
231	}
232
233	fz <- cut(out$v, out$breaks, include.lowest=TRUE, right=FALSE, dig.lab=dig.lab)
234	out$vcut <- as.integer(fz)
235	levs <- levels(fz)
236	nlevs <- length(levs)
237
238	cols <- out$cols
239	ncols <- length(cols)
240	if (nlevs < ncols) {
241		i <- trunc((ncols / nlevs) * 1:nlevs)
242		cols <- cols[i]
243	} else {
244		cols <- rep_len(cols, nlevs)
245	}
246	out$cols <- cols
247	out$leg$fill <- cols
248	out$legend_type <- "classes"
249
250	if (!is.null(out$leg$legend)) {
251		if (length(out$leg$legend) != nlevs) {
252			warn("plot", "legend does not match number of levels")
253			out$leg$legend <- rep_len(out$leg$legend, nlevs)
254		}
255	} else {
256		levs <- gsub("]", "", gsub(")", "", gsub("\\[", "", levs)))
257		levs <- paste(levs, collapse=",")
258		m <- matrix(as.numeric(unlist(strsplit(levs, ","))), ncol=2, byrow=TRUE)
259		m <- apply(m, 1, function(i) paste(i, collapse=" - "))
260		out$leg$legend <- m
261	}
262
263	if (is.null(out$leg$x)) { # && is.null(out$leg$ext)) {
264		out$leg$x <- "top"
265	}
266
267	out$main_cols <- out$cols[out$vcut]
268	out
269}
270
271
272
273.plot.vect.map <- function(x, out, xlab="", ylab="", type = "n", yaxs="i", xaxs="i", asp=out$asp, density=NULL, angle=45, border="black", dig.lab=3, main="", ...) {
274
275	if ((!out$add) & (!out$legend_only)) {
276		if (!any(is.na(out$mar))) { graphics::par(mar=out$mar) }
277		plot(out$lim[1:2], out$lim[3:4], type="n", xlab=xlab, ylab=ylab, asp=asp, xaxs=xaxs, yaxs=yaxs, axes=FALSE, main=main)
278	}
279
280	out$leg$density <- density
281	out$leg$angle <- angle
282	out$leg$border <- border
283
284	nuq <- length(out$uv)
285	if (out$legend_type == "none") {
286		out <- .vect.legend.none(out)
287	} else if (out$legend_type == "classes") {
288		out <- .vect.legend.classes(out)
289	} else if (out$legend_type == "interval") {
290		if (nuq < 2) {
291			out <- .vect.legend.classes(out, ...)
292		} else {
293			out <- .vect.legend.interval(out, dig.lab=dig.lab)
294		}
295	} else if (out$legend_type == "depends") {
296		if (nuq < 11) {
297			out <- .vect.legend.classes(out)
298		} else if (!is.numeric(out$uv) && (nuq < 21)) {
299			out <- .vect.legend.classes(out)
300		} else {
301			out <- .vect.legend.interval(out, dig.lab=dig.lab)
302		}
303	} else {
304		if (nuq == 1) {
305			out <- .vect.legend.classes(out)
306		} else {
307			out <- .vect.legend.continuous(out)
308			out$leg$density <- NULL
309		}
310	}
311	if (!out$legend_only) {
312		out <- .vplot(x, out, ...)
313	}
314
315	if (out$axes) {
316		out <- .plot.axes(out)
317	}
318
319	if (out$legend_draw) {
320		if (out$legend_type == "continuous") {
321			out$legpars <- do.call(.plot.cont.legend, list(x=out))
322		} else {
323			out$legpars <- do.call(.plot.class.legend, out$leg)
324		}
325	}
326	out
327}
328
329
330.prep.vect.data <- function(x, y, type, cols=NULL, mar=NULL, legend=TRUE,
331	legend.only=FALSE, levels=NULL, add=FALSE, range=NULL, breaks=NULL, breakby="eqint",
332	xlim=NULL, ylim=NULL, colNA=NA, alpha=NULL, axes=TRUE, main=NULL,
333	pax=list(), plg=list(), ...) {
334
335	out <- list()
336	out$ngeom <- nrow(x)
337	e <- as.vector(ext(x))
338	out$ext <- e
339
340	if (!is.null(xlim)) {
341		stopifnot(length(xlim) == 2)
342		e[1:2] <- sort(xlim)
343	} else {
344		dx <- diff(e[1:2]) / 50
345		e[1:2] <- e[1:2] + c(-dx, dx)
346	}
347	if (!is.null(ylim)) {
348		stopifnot(length(ylim) == 2)
349		e[3:4] <- sort(ylim)
350	} else {
351		dy <- diff(e[3:4]) / 50
352		e[3:4] <- e[3:4] + c(-dy, dy)
353	}
354	out$lim <- e
355
356	out$add <- isTRUE(add)
357	out$axes <- isTRUE(axes)
358	out$axs <- pax
359	out$leg <- plg
360	out$leg$geomtype <- geomtype(x)
361	out$asp <- 1
362	out$lonlat <- is.lonlat(x, perhaps=TRUE, warn=FALSE)
363	if (out$lonlat) {
364		out$asp <- 1/cos((mean(out$ext[3:4]) * pi)/180)
365	}
366	out$breaks <- breaks
367	out$breakby <- breakby
368
369	v <- unlist(x[, y, drop=TRUE], use.names=FALSE)
370	if (!is.null(range)) {
371		range <- sort(range)
372		v[v < range[1]] <- NA
373		v[v > range[2]] <- NA
374		if (all(is.na(v))) {
375			v <- NULL
376			y <- ""
377			type = "none"
378		} else {
379			out$range <- range
380		}
381		out$range_set <- TRUE
382	} else {
383		if (!is.null(v)) {
384			out$range <- range(v, na.rm=TRUE)
385		}
386		out$range_set <- FALSE
387	}
388	out$v <- v
389
390	out$uv <- unique(out$v)
391
392	if (missing(type)) {
393		type <- "depends"
394	} else {
395		type <- match.arg(type, c("continuous", "classes", "interval", "depends", "none"))
396	}
397	out$levels <- levels
398
399	if (type=="none") {
400		legend <- FALSE
401		legend_only <- FALSE
402	}
403	out$legend_type <- type
404
405	if (is.null(cols)) {
406		if (type == "none") {
407			if (out$leg$geomtype %in% c("lines", "points")) {
408				cols <- "black"
409			}
410		} else {
411			cols <- rev(grDevices::rainbow(100, start=.1, end=0.9))
412		}
413	}
414	if (!is.null(alpha)) {
415		alpha <- clamp(alpha[1]*255, 0, 255)
416		cols <- grDevices::rgb(t(grDevices::col2rgb(cols)), alpha=alpha, maxColorValue=255)
417	} else {
418		alpha <- 255
419	}
420	out$cols <- cols
421	out$legend_draw <- isTRUE(legend)
422	out$legend_only <- isTRUE(legend.only)
423
424	if (is.null(mar)) {
425		if (out$legend_draw) {
426			mar=c(3.1, 3.1, 2.1, 7.1)
427		} else {
428			mar=c(3.1, 3.1, 2.1, 2.1)
429		}
430	}
431	out$mar <- rep_len(mar, 4)
432
433	if (!is.null(colNA)) {
434		if (!is.na(colNA)) {
435			out$colNA <- grDevices::rgb(t(grDevices::col2rgb(colNA)), alpha=alpha, maxColorValue=255)
436			out$r[is.na(out$r)] <- out$colNA
437		}
438	}
439
440	.plot.vect.map(x, out, main=main, ...)
441}
442
443
444setMethod("plot", signature(x="SpatVector", y="character"),
445	function(x, y, col=NULL, type, mar=NULL, legend=TRUE, add=FALSE, axes=!add,
446	main=y, plg=list(), pax=list(), nr, nc, ...) {
447
448		if (nrow(x) == 0) {
449			error("plot", "SpatVector has zero geometries")
450		}
451
452		y <- trimws(y)
453		if (any(is.na(match(y, c("", names(x)))))) {
454			i <- is.na(match(y, names(x)))
455			error("plot", paste(paste(y[i], collapse=",")), " is not a name in x")
456		}
457		nrnc <- c(1,1)
458		if (length(y) > 1) {
459			nrnc <- .get_nrnc(nr, nc, length(y))
460			old.par <- graphics::par(no.readonly =TRUE)
461			on.exit(graphics::par(old.par))
462			graphics::par(mfrow=nrnc)
463		}
464		if (is.character(legend)) {
465			plg$x <- legend
466			legend <- TRUE
467		}
468
469		for (i in 1:length(y)) {
470			if (length(y) > 1) {
471				newrow <- (nrnc[2] == 1) | ((i %% nrnc[2]) == 1)
472				lastrow <- i > (prod(nrnc) - nrnc[2])
473				if (lastrow) {
474					if (newrow) {
475						pax$sides <- 1:2
476					} else {
477						pax$sides <- 1
478					}
479				} else if (newrow) {
480					pax$sides <- 2
481				} else {
482					pax$sides <- 0
483				}
484			}
485			if (missing(col)) col <- NULL
486
487			if (y[i] == "") {
488				out <- .prep.vect.data(x, y="", type="none", cols=col, mar=mar, plg=list(), pax=pax, legend=FALSE, add=add, axes=axes, main=main[i], ...)
489			} else {
490				out <- .prep.vect.data(x, y[i], type=type, cols=col, mar=mar, plg=plg, pax=pax, legend=isTRUE(legend), add=add, axes=axes, main=main[i], ...)
491			}
492			invisible(out)
493		}
494	}
495)
496
497
498setMethod("plot", signature(x="SpatVector", y="numeric"),
499	function(x, y, ...)  {
500		y <- round(y)
501		if (any(y > ncol(x))) {
502			error("plot", paste("x only has", ncol(x), " columns"))
503		}
504		y[y<0] <- 0
505		y <- c("", names(x))[y+1]
506		out <- plot(x, y, ...)
507		invisible(out)
508	}
509)
510
511
512setMethod("plot", signature(x="SpatVector", y="missing"),
513	function(x, y, ...)  {
514		out <- plot(x, "", ...)
515		invisible(out)
516	}
517)
518
519