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