1 ```#' @include RcppExports.R dependencies.R ``` 2 ```NULL ``` 3 4 ```#' Affine transformation ``` 5 ```#' ``` 6 ```#' @noRd ``` 7 ```affineTrans <- function(OldValue, OldMax, OldMin, NewMax, NewMin) { ``` 8 0 ``` OldRange <- (OldMax - OldMin) ``` 9 0 ``` NewRange <- (NewMax - NewMin) ``` 10 0 ``` NewValue <- (((OldValue - OldMin) * NewRange) / OldRange) + NewMin ``` 11 0 ``` return(NewValue) ``` 12 ```} ``` 13 14 ```#' Normal niche simulation function ``` 15 ```#' ``` 16 ```#' @noRd ``` 17 ```normal_niche <- function(x, y) { ``` 18 4 ``` mvtnorm::dmvnorm(x = matrix(c(x, y), ncol = 2), ``` 19 4 ``` mean = c(0, 0), ``` 20 4 ``` sigma = matrix(c(8.5, 0, 0, 8.5), ncol = 2)) * 40 ``` 21 ```} ``` 22 23 ```#' Uniform niche simulation function ``` 24 ```#' ``` 25 ```#' @noRd ``` 26 ```uniform_niche <- function(x, y) { ``` 27 4 ``` rep(0.5, length(x)) ``` 28 ```} ``` 29 30 ```#' Bimodal niche simulation function ``` 31 ```#' ``` 32 ```#' @noRd ``` 33 ```bimodal_niche <- function(x, y) { ``` 34 4 ``` apply(matrix(c(mvtnorm::dmvnorm(x = matrix(c(x, y), ncol = 2), ``` 35 4 ``` mean = c(-2, -2), ``` 36 4 ``` sigma = matrix(c(5, 0, 0, 5), ncol = 2)) * 30, ``` 37 4 ``` mvtnorm::dmvnorm(x = matrix(c(x, y), ncol = 2), ``` 38 4 ``` mean = c(3, 3), ``` 39 4 ``` sigma = matrix(c(3, 0, 0, 3), ``` 40 4 ``` ncol = 2)) * 12), ``` 41 4 ``` ncol = 2), ``` 42 4 ``` 1, max) ``` 43 ```} ``` 44 45 ```#' Function to hash function call ``` 46 ```#' ``` 47 ```#' @noRd ``` 48 ```hashCall <- function(expr, skipargs = c(), env = parent.frame()) { ``` 49 0 ``` expr <- expr[c((skipargs * -1L) - 1L)] ``` 50 0 ``` expr <- expr[which(names(expr) != "force.reset")] ``` 51 0 ``` for (i in seq_along(names(expr))) ``` 52 0 ``` if (inherits(expr[[i]], c("name"))) ``` 53 0 ``` expr[[i]] <- eval(expr[[i]], envir = env) ``` 54 0 ``` paste(deparse(expr), collapse = ";") ``` 55 ```} ``` 56 57 ```#' Make pretty geoplot ``` 58 ```#' @noRd ``` 59 ```prettyGeoplot <- function(polygons, col, basemap, main, fun, beside = TRUE, ``` 60 ``` border = NULL, lwd = 1) { ``` 61 ``` # make layout ``` 62 4 ``` defpar <- graphics::par(no.readonly = TRUE) ``` 63 4 ``` graphics::par(mar = c(1, 1, 1, 1), oma = c(0, 0, 0, 0)) ``` 64 4 ``` if (beside) { ``` 65 4 ``` graphics::layout(matrix(c(1, 1, 3, 2), ncol = 2, byrow = TRUE), ``` 66 4 ``` widths = c(0.8, 0.2), heights = c(0.1, 0.9)) ``` 67 ``` } else { ``` 68 4 ``` graphics::layout(matrix(c(1, 3, 2), ncol = 1, byrow = TRUE), ``` 69 4 ``` widths = c(1), heights = c(0.1, 0.8, 0.1)) ``` 70 ``` } ``` 71 ``` # convert to list if not ``` 72 4 ``` if (!inherits(polygons, "list")) { ``` 73 4 ``` polygons <- list(polygons) ``` 74 4 ``` col <- list(col) ``` 75 4 ``` border <- list(border) ``` 76 4 ``` lwd <- list(lwd) ``` 77 ``` } ``` 78 79 ``` # make title ``` 80 4 ``` graphics::plot(1, 1, type = "n", xlim = c(-1, 1), ylim = c(-1, 1), ``` 81 4 ``` axes = FALSE, xlab = "", ylab = "") ``` 82 4 ``` graphics::mtext(side = 1, line = -0.5, main, cex = 1.5) ``` 83 ``` # make legend ``` 84 4 ``` graphics::plot(1, 1, type = "n", xlim = c(-1, 1), ylim = c(-1, 1), ``` 85 4 ``` axes = FALSE, xlab = "", ylab = "") ``` 86 4 ``` fun() ``` 87 ``` # make geoplot ``` 88 4 ``` if (is.list(basemap)) { ``` 89 0 ``` RgoogleMaps::PlotOnStaticMap(basemap) ``` 90 0 ``` for (i in seq_along(polygons)) { ``` 91 0 ``` suppressWarnings(RgoogleMaps::PlotPolysOnStaticMap( ``` 92 0 ``` basemap, polygons[[i]], col = col[[i]], border = border[[i]], ``` 93 0 ``` add = TRUE, lwd = lwd[[i]])) ``` 94 ``` } ``` 95 ``` } else { ``` 96 4 ``` allpolygons <- do.call(rbind, polygons) ``` 97 4 ``` PBSmapping::plotPolys(polygons[[1]], col = col[[1]], axes = FALSE, ``` 98 4 ``` xlab = "", ylab = "", border = border[[1]], ``` 99 4 ``` lwd = lwd[[1]], xlim = range(allpolygons\$X), ``` 100 4 ``` ylim = range(allpolygons\$Y)) ``` 101 4 ``` for (i in seq_along(polygons)[-1]) { ``` 102 4 ``` if (nrow(polygons[[i]]) > 0) ``` 103 4 ``` suppressWarnings(PBSmapping::addPolys(polygons[[i]], col = col[[i]], ``` 104 4 ``` xlab = "", ylab = "", ``` 105 4 ``` border = border[[i]], ``` 106 4 ``` lwd = lwd[[i]])) ``` 107 ``` } ``` 108 ``` } ``` 109 4 ``` graphics::par(defpar) ``` 110 4 ``` invisible() ``` 111 ```} ``` 112 113 ```#' Extract colors from RcolorBrewer palette functions ``` 114 ```#' ``` 115 ```#' @noRd ``` 116 ```brewerCols <- function(values, pal, alpha = 1, n = NULL) { ``` 117 4 ``` if (is.null(n) & length(pal) == 1) { ``` 118 4 ``` n <- RColorBrewer::brewer.pal.info\$maxcolors[which( ``` 119 4 ``` rownames(RColorBrewer::brewer.pal.info) == pal)] ``` 120 ``` } else { ``` 121 4 ``` n <- length(values) ``` 122 ``` } ``` 123 4 ``` if (length(pal) == 1) { ``` 124 4 ``` suppressWarnings(r <- grDevices::colorRamp( ``` 125 4 ``` RColorBrewer::brewer.pal(n, pal))(values)) ``` 126 ``` } else{ ``` 127 0 ``` suppressWarnings(r <- grDevices::colorRamp(pal)(values)) ``` 128 ``` } ``` 129 4 ``` grDevices::rgb(r, maxColorValue = 255, ``` 130 4 ``` alpha = scales::rescale(alpha, from = c(0, 1), to = c(0, 255))) ``` 131 ```} ``` 132 133 ```#' Add continuous legend to plot ``` 134 ```#' ``` 135 ```#' @noRd ``` 136 ```continuousLegend <- function(values, pal, posx, posy, center = FALSE, ``` 137 ``` endlabs = NULL) { ``` 138 4 ``` function() { ``` 139 4 ``` if (center) { ``` 140 4 ``` vabs <- max(abs(range(values))) ``` 141 4 ``` values <- seq(-vabs, vabs, length.out = 100) ``` 142 ``` } ``` 143 4 ``` xdiff <- diff(graphics::par()\$usr[1:2]) ``` 144 4 ``` ydiff <- diff(graphics::par()\$usr[3:4]) ``` 145 4 ``` zvals <- pretty(values) ``` 146 4 ``` zvals <- zvals[which(zvals > min(values) & zvals < max(values))] ``` 147 4 ``` if (max(zvals) < 1) { ``` 148 4 ``` digit <- 2 ``` 149 ``` } else { ``` 150 0 ``` digit <- 1 ``` 151 ``` } ``` 152 4 ``` shape::colorlegend(zlim = range(values), digit = digit, ``` 153 4 ``` col = brewerCols(seq(0, 1, length.out = 100), pal), ``` 154 4 ``` zval = zvals, posx = posx, posy = posy, xpd = TRUE) ``` 155 4 ``` if (!is.null(endlabs)) { ``` 156 4 ``` xcoord <- graphics::par()\$usr[1] + ``` 157 4 ``` mean(graphics::par()\$usr[2:1] * posx * 2.2) ``` 158 4 ``` ycoords <- (graphics::par()\$usr[3] + ``` 159 4 ``` diff(graphics::par()\$usr[3:4]) * posy) + ``` 160 4 ``` (diff(graphics::par()\$usr[3:4]) * c(-0.02, 0.02)) ``` 161 4 ``` graphics::text(x = rep(xcoord, 2), y = ycoords, rev(endlabs), cex = 1.2, ``` 162 4 ``` ad = c(0.5, 0.5)) ``` 163 ``` } ``` 164 ``` } ``` 165 ```} ``` 166 167 ```#' Add categorical legend to plot ``` 168 ```#' ``` 169 ```#' @noRd ``` 170 ```categoricalLegend <- function(col, labels, ncol = 1) { ``` 171 4 ``` function() { ``` 172 4 ``` if (ncol == 1) { ``` 173 4 ``` graphics::legend("top", bg = "white", legend = labels, fill = col, ``` 174 4 ``` bty = "n", horiz = TRUE, cex = 1.5) ``` 175 ``` } else { ``` 176 4 ``` graphics::legend(y = graphics::par()\$usr[3] + ``` 177 4 ``` (diff(graphics::par()\$usr[3:4]) * 0.6), ``` 178 4 ``` x = graphics::par()\$usr[1] + ``` 179 4 ``` (diff(graphics::par()\$usr[1:2]) * 0.5), ``` 180 4 ``` bg = "white", legend = labels, fill = col, bty = "n", ``` 181 4 ``` ncol = ncol, cex = 1.5, xjust = 0.5, yjust = 0.5, ``` 182 4 ``` xpd = TRUE) ``` 183 ``` } ``` 184 ``` } ``` 185 ```} ``` 186 187 ```#' Create 1-dimensional demand points ``` 188 ```#' ``` 189 ```#' @noRd ``` 190 ```demand.points.density1d <- function(pts, n, quantile = 0.95, ...) { ``` 191 ``` # transform pts ``` 192 4 ``` curr.mean <- mean(pts[, 1]) ``` 193 4 ``` curr.sd <- stats::sd(pts[, 1]) ``` 194 4 ``` pts[, 1] <- (pts[, 1] - curr.mean) / curr.sd ``` 195 ``` # generate points ``` 196 4 ``` quants <- stats::quantile(pts[, 1], ``` 197 4 ``` c( (1 - quantile) / 2, ``` 198 4 ``` quantile + (1 - quantile) / 2)) ``` 199 4 ``` dp <- stats::runif(n, quants[[1]], quants[[2]]) ``` 200 ``` # density kernel ``` 201 4 ``` est <- ks::kde(pts[, 1], eval.points = dp, ...) ``` 202 ``` # back-transform demand point coordinates ``` 203 4 ``` dp.pts <- (matrix(est\$eval.points, ncol = 1) * curr.sd) + curr.mean ``` 204 ``` # return object ``` 205 4 ``` list(coords = dp.pts, weights = est\$estimate) ``` 206 ```} ``` 207 208 ```#' Create 2-dimensional demand points ``` 209 ```#' ``` 210 ```#' @noRd ``` 211 ```demand.points.density2d <- function(pts, n, quantile = 0.95, ...) { ``` 212 ``` # transform pts ``` 213 4 ``` curr.mean <- apply(pts, 2, mean) ``` 214 4 ``` curr.sd <- apply(pts, 2, stats::sd) ``` 215 4 ``` pts <- sweep(pts, MARGIN = 2, FUN = "-", curr.mean) ``` 216 4 ``` pts <- sweep(pts, MARGIN = 2, FUN = "/", curr.sd) ``` 217 ``` # generate points ``` 218 4 ``` dp <- sp::spsample(adehabitatHR::mcp(sp::SpatialPoints(coords = pts), ``` 219 4 ``` percent = quantile * 100, unin = c("m"), ``` 220 4 ``` unout = c("m2")), ``` 221 4 ``` n * 1.1, type = "random")@coords[seq_len(n), ] ``` 222 ``` # fit density kernel ``` 223 4 ``` est <- ks::kde(pts, eval.points = dp, ...) ``` 224 ``` # back-transform dps ``` 225 4 ``` dp <- sweep(dp, MARGIN = 2, FUN = "*", curr.sd) ``` 226 4 ``` dp <- sweep(dp, MARGIN = 2, FUN = "+", curr.mean) ``` 227 ``` # prepare data to return ``` 228 4 ``` list(coords = dp, weights = est\$estimate) ``` 229 ```} ``` 230 231 ```#' Create n-dimensional demand points ``` 232 ```#' ``` 233 ```#' @noRd ``` 234 ```demand.points.hypervolume <- function(pts, n, quantile = 0.95, ...) { ``` 235 ``` # transform pts ``` 236 4 ``` curr.mean <- apply(pts, 2, mean) ``` 237 4 ``` curr.sd <- apply(pts, 2, stats::sd) ``` 238 4 ``` pts <- sweep(pts, MARGIN = 2, FUN = "-", curr.mean) ``` 239 4 ``` pts <- sweep(pts, MARGIN = 2, FUN = "/", curr.sd) ``` 240 ``` # fit density kernel ``` 241 4 ``` args <- list(...) ``` 242 4 ``` if (!"samples.per.point" %in% names(args)) ``` 243 4 ``` args\$samples.per.point <- 500 * ncol(pts) ``` 244 4 ``` if (args\$samples.per.point * nrow(pts) < n) { ``` 245 0 ``` stop(paste0("argument to n.demand.points is too high. Set a higher value ", ``` 246 0 ``` "in the argument to samples.per.point (defaults to ", ``` 247 0 ``` "500 * dimensions in attribute space).")) ``` 248 ``` } ``` 249 ``` # estimate bandwidth for kernel ``` 250 4 ``` if (!"kde.bandwidth" %in% names(args)) { ``` 251 4 ``` args\$kde.bandwidth <- hypervolume::estimate_bandwidth(pts) ``` 252 ``` } ``` 253 ``` # fit kernel ``` 254 4 ``` hv <- do.call(hypervolume::hypervolume, ``` 255 4 ``` append(list(data = pts, quantile.requested=quantile), args)) ``` 256 ``` # extract random points ``` 257 4 ``` rndpos <- sample.int(nrow(hv@RandomPoints), n) ``` 258 ``` # extract coordinates and back-transform ``` 259 4 ``` dp <- hv@RandomPoints[rndpos,, drop = FALSE] ``` 260 4 ``` dp <- sweep(dp, MARGIN = 2, FUN = "*", curr.sd) ``` 261 4 ``` dp <- sweep(dp, MARGIN = 2, FUN = "+", curr.mean) ``` 262 ``` # return object ``` 263 4 ``` list(coords = dp, weights = hv@ValueAtRandomPoints[rndpos]) ``` 264 ```} ``` 265 266 ```#' Calculate zonal-means ``` 267 ```#' ``` 268 ```#' @noRd ``` 269 ```zonalMean <- function(x, y, ids = names(y), ncores = 1) { ``` 270 4 ``` assertthat::assert_that(sum(is.na(ids)) == 0, ``` 271 4 ``` assertthat::is.count(ncores), ``` 272 4 ``` ncores <= parallel::detectCores(logical = TRUE)) ``` 273 4 ``` if (raster::canProcessInMemory(x, 2)) { ``` 274 4 ``` x <- plyr::rbind.fill(plyr::llply(seq_len(nlayers(y)), function(l) { ``` 275 4 ``` zonalMean.RasterLayerInMemory(x, y[[l]], ids[l]) ``` 276 ``` })) ``` 277 ``` } else { ``` 278 0 ``` bs <- raster::blockSize(x) ``` 279 0 ``` if (ncores > 1) { ``` 280 0 ``` clust <- parallel::makeCluster(ncores, type = "SOCK") ``` 281 0 ``` parallel::clusterEvalQ(clust, {library(raster); library(Rcpp)}) ``` 282 0 ``` parallel::clusterExport(clust, c("bs", "x", "rcpp_groupmean"), ``` 283 0 ``` envir = environment()) ``` 284 0 ``` doParallel::registerDoParallel(clust) ``` 285 ``` } ``` 286 0 ``` x <- plyr::rbind.fill(plyr::llply(seq_len(nlayers(y)), function(l) { ``` 287 0 ``` zonalMean.RasterLayerNotInMemory(bs, x, y[[l]], ids[l], ``` 288 0 ``` registered = isTRUE(ncores > 1), clust) ``` 289 ``` })) ``` 290 0 ``` if (ncores > 1) ``` 291 0 ``` clust <- parallel::stopCluster(clust) ``` 292 ``` } ``` 293 ``` # return data ``` 294 4 ``` x ``` 295 ```} ``` 296 297 ```#' Calculate zonal-means for rasters where all data can be stored in RAM ``` 298 ```#' ``` 299 ```#' @noRd ``` 300 ```zonalMean.RasterLayerInMemory <- function(polys, rast, speciesName) { ``` 301 4 ``` tmp <- rcpp_groupmean(raster::getValues(polys), raster::getValues(rast)) ``` 302 4 ``` tmp <- data.frame(species = speciesName, ``` 303 4 ``` pu = attr(tmp, "ids"), value = c(tmp)) ``` 304 4 ``` return(tmp[which(tmp\$value > 0),, drop = FALSE]) ``` 305 ```} ``` 306 307 ```#' Calculate zonal-means by processing data in chunks ``` 308 ```#' ``` 309 ```#' @noRd ``` 310 ```zonalMean.RasterLayerNotInMemory <- function(bs, polys, rast, speciesName, ``` 311 ``` ncores, registered, clust) { ``` 312 0 ``` if (registered & .Platform\$OS.type == "windows") ``` 313 0 ``` parallel::clusterExport(clust, c("bs", "polys", "rast", "rcpp_groupmean"), ``` 314 0 ``` envir = environment()) ``` 315 0 ``` tmp <- rcpp_groupcombine(plyr::llply(seq_len(bs\$n), ``` 316 0 ``` .parallel = registered, ``` 317 0 ``` function(i) { ``` 318 0 ``` rcpp_groupmean( ``` 319 0 ``` raster::getValues(polys, bs\$row[i], bs\$nrows[i]), ``` 320 0 ``` raster::getValues(rast, bs\$row[i], bs\$nrows[i])) ``` 321 ``` })) ``` 322 0 ``` tmp <- data.frame(species = speciesName, pu = attr(tmp, "ids"), ``` 323 0 ``` value = c(tmp)) ``` 324 0 ``` tmp[which(tmp\$value > 0),, drop = FALSE] ``` 325 ```} ``` 326 327 ```#' Merge list of RapResults into a single object ``` 328 ```#' ``` 329 ```#' @noRd ``` 330 ```mergeRapResults <- function(x) { ``` 331 4 ``` x <- RapResults(summary = plyr::ldply(x, methods::slot, name = "summary"), ``` 332 4 ``` selections = do.call(rbind, lapply(x, methods::slot, ``` 333 4 ``` name = "selections")), ``` 334 4 ``` amount.held = do.call(rbind, lapply(x, methods::slot, ``` 335 4 ``` name = "amount.held")), ``` 336 4 ``` space.held = do.call(rbind, lapply(x, methods::slot, ``` 337 4 ``` name = "space.held")), ``` 338 4 ``` logging.file = sapply(x, methods::slot, ``` 339 4 ``` name = "logging.file")) ``` 340 4 ``` x@summary\$Run_Number <- seq_len(nrow(x@summary)) ``` 341 4 ``` return(x) ``` 342 ```} ``` 343 344 ```#' Read RAP results ``` 345 ```#' ``` 346 ```#' This function reads files output from Gurobi and returns a `RapResults` ``` 347 ```#' object. ``` 348 ```#' ``` 349 ```#' @param opts `RapReliableOpts` or `RapUnreliableOpts` object ``` 350 ```#' ``` 351 ```#' @param data `RapData` object ``` 352 ```#' ``` 353 ```#' @param model.list `list` object containing Gurobi model data ``` 354 ```#' ``` 355 ```#' @param logging.file `character` Gurobi log files. ``` 356 ```#' ``` 357 ```#' @param solution.list `list` object containing Gurobi solution data. ``` 358 ```#' ``` 359 ```#' @param verbose `logical` print progress messages? Defaults to ``` 360 ```#' `FALSE`. ``` 361 ```#' ``` 362 ```#' @keywords internal ``` 363 ```#' ``` 364 ```#' @return `RapResults` object ``` 365 ```#' ``` 366 ```#' @seealso [RapReliableOpts()], [RapUnreliableOpts()], ``` 367 ```#' [RapData()], [RapResults()]. ``` 368 ```read.RapResults <- function(opts, data, model.list, logging.file, ``` 369 ``` solution.list, verbose = FALSE) { ``` 370 4 ``` x <- rcpp_extract_model_object(opts, inherits(opts, "RapUnreliableOpts"), ``` 371 4 ``` data, model.list, logging.file, solution.list, ``` 372 4 ``` verbose) ``` 373 4 ``` x@.cache <- new.env() ``` 374 4 ``` return(x) ``` 375 ```} ``` 376 377 ```#' Compare Rap objects ``` 378 ```#' ``` 379 ```#' This function checks objects to see if they share the same input data. ``` 380 ```#' ``` 381 ```#' @param x `RapData`, `RapUnsolved`, or `RapSolved` object. ``` 382 ```#' ``` 383 ```#' @param y `RapData`, `RapUnsolved`, or `RapSolved` object. ``` 384 ```#' ``` 385 ```#' @return `logical` are the objects based on the same data? ``` 386 ```#' ``` 387 ```#' @keywords internal ``` 388 ```#' ``` 389 ```#' @seealso [RapData-class], [RapUnsolved-class], ``` 390 ```#' [RapSolved-class]. ``` 391 ```#' ``` 392 ```#' @name is.comparable ``` 393 ```methods::setGeneric("is.comparable", ``` 394 0 ``` function(x, y) methods::standardGeneric("is.comparable")) ``` 395 396 ```#' Basemap ``` 397 ```#' ``` 398 ```#' This function retrieves google map data for planning units. The google map ``` 399 ```#' data is cached to provide fast plotting capabilities. ``` 400 ```#' ``` 401 ```#' @param x `RapData`, `RapUnsolved`, `RapSolved` object. ``` 402 ```#' ``` 403 ```#' @param basemap `character` type of base map to display. Valid names are ``` 404 ```#' `"roadmap"`, `"mobile"`, `"satellite"`, `"terrain"`, ``` 405 ```#' `"hybrid"`, `"mapmaker-roadmap"`, `"mapmaker-hybrid"`. ``` 406 ```#' ``` 407 ```#' @param grayscale `logical` should base map be gray scale? ``` 408 ```#' ``` 409 ```#' @param force.reset `logical` ignore data in cache? Setting this as ``` 410 ```#' ignore will make function slower but may avoid bugs in cache system. ``` 411 ```#' ``` 412 ```#' @return `list` with google map data. ``` 413 ```#' ``` 414 ```#' @keywords internal ``` 415 ```#' ``` 416 ```#' @seealso [RgoogleMaps::GetMap.bbox()], [plot()]. ``` 417 0 ```basemap <- function(x, basemap = "hybrid", grayscale = FALSE, ``` 418 0 ``` force.reset = FALSE) UseMethod("basemap") ``` 419 420 ```#' Test if hash is cached in a Rap object ``` 421 ```#' ``` 422 ```#' Tests if hash is cached in Rap object. ``` 423 ```#' ``` 424 ```#' @param x `RapData` or `RapResults` object ``` 425 ```#' ``` 426 ```#' @param name `character` hash. ``` 427 ```#' ``` 428 ```#' @note caches are implemented using environments, the hash is used as the ``` 429 ```#' name of the object in the environment. ``` 430 ```#' @return `logical` Is it cached? ``` 431 ```#' ``` 432 ```#' @keywords internal ``` 433 ```#' ``` 434 ```#' @name is.cached ``` 435 ```methods::setGeneric("is.cached", ``` 436 0 ``` function(x, name) methods::standardGeneric("is.cached")) ``` 437 438 ```#' Get and set cache methods ``` 439 ```#' ``` 440 ```#' Getter and setter methods for caches in RapData and RapResults object. ``` 441 ```#' ``` 442 ```#' @param x `RapData` or `RapResults` object ``` 443 ```#' ``` 444 ```#' @param name `character` hash. ``` 445 ```#' ``` 446 ```#' @param y if `ANY` this object gets cached with name, else if ``` 447 ```#' `missing` the object hashed at name gets returned. ``` 448 ```#' ``` 449 ```#' @note caches are implemented using environments, the hash is used as the ``` 450 ```#' name of the object in the environment. ``` 451 ```#' ``` 452 ```#' @return `ANY` or `NULL` depends on `y` argument. ``` 453 ```#' ``` 454 ```#' @keywords internal ``` 455 ```#' ``` 456 ```#' @name cache ``` 457 ```methods::setGeneric("cache", ``` 458 0 ``` function(x, name, y) methods::standardGeneric("cache")) ``` 459 460 ```#' Plot a 1-dimensional attribute space ``` 461 ```#' ``` 462 ```#' @noRd ``` 463 ```spacePlot.1d <- function(pu, dp, pu.color.palette, main) { ``` 464 ``` # create X2 vars ``` 465 4 ``` pu\$X2 <- 0 ``` 466 4 ``` dp\$X2 <- 0 ``` 467 ``` # create colors ``` 468 4 ``` if (length(pu.color.palette) == 1) ``` 469 0 ``` pu.color.palette <- brewerCols(seq(0, 1, 0.25), pu.color.palette, 4) ``` 470 ``` # make plot ``` 471 4 ``` ggplot2::ggplot() + ``` 472 4 ``` ggplot2::geom_point(ggplot2::aes_string(x = "X1", y = "X2", ``` 473 4 ``` alpha = "weights"), data = dp, color = "darkblue", ``` 474 4 ``` size = 5, ``` 475 4 ``` position = ggplot2::position_jitter(width = 0, ``` 476 4 ``` height = 5)) + ``` 477 4 ``` ggplot2::scale_alpha_continuous(name = "Demand point weight") + ``` 478 4 ``` ggplot2::geom_point(ggplot2::aes_string(x = "X1", y = "X2", ``` 479 4 ``` color = "status", size = "status"), data = pu, ``` 480 4 ``` position = ggplot2::position_jitter(width = 0, ``` 481 4 ``` height = 5)) + ``` 482 4 ``` ggplot2::scale_color_manual(name = "Planning unit status", ``` 483 4 ``` values = c("Locked Out" = pu.color.palette[4], ``` 484 4 ``` "Not Selected" = pu.color.palette[1], ``` 485 4 ``` "Selected" = pu.color.palette[2], ``` 486 4 ``` "Locked In" = pu.color.palette[3])) + ``` 487 4 ``` ggplot2::scale_size_manual(values = c("Locked Out" = 2, "Not Selected" = 2, ``` 488 4 ``` "Selected" = 4.5, "Locked In" = 4.5), ``` 489 4 ``` guide = FALSE) + ``` 490 4 ``` ggplot2::theme_classic() + ggplot2::coord_equal() + ``` 491 4 ``` ggplot2::theme(legend.position = "right", ``` 492 4 ``` axis.title.y = ggplot2::element_blank(), ``` 493 4 ``` axis.ticks.y = ggplot2::element_blank(), ``` 494 4 ``` axis.text.y = ggplot2::element_blank(), ``` 495 4 ``` axis.line.y = ggplot2::element_line(), ``` 496 4 ``` axis.line.x = ggplot2::element_line()) + ``` 497 4 ``` ggplot2::ggtitle(main) + ggplot2::xlab("Dimension 1") + ``` 498 4 ``` ggplot2::ylab("") ``` 499 ```} ``` 500 501 ```#' Plot a 2-d attribute space ``` 502 ```#' ``` 503 ```#' @noRd ``` 504 ```spacePlot.2d <- function(pu, dp, pu.color.palette, main) { ``` 505 ``` # create colors ``` 506 4 ``` if (length(pu.color.palette) == 1) ``` 507 0 ``` pu.color.palette <- brewerCols(seq(0, 1, 0.25), pu.color.palette, 4) ``` 508 ``` # make plot ``` 509 4 ``` ggplot2::ggplot() + ``` 510 4 ``` ggplot2::geom_point(ggplot2::aes_string(x = "X1", y = "X2", ``` 511 4 ``` alpha = "weights"), ``` 512 4 ``` data = dp, color = "darkblue", size = 5) + ``` 513 4 ``` ggplot2::scale_alpha_continuous(name = "Demand point weight") + ``` 514 4 ``` ggplot2::geom_point(ggplot2::aes_string(x = "X1", y = "X2", color = "status", ``` 515 4 ``` size = "status"), ``` 516 4 ``` data = pu) + ``` 517 4 ``` ggplot2::scale_color_manual(name = "Planning unit status", ``` 518 4 ``` values = c("Locked Out" = pu.color.palette[4], ``` 519 4 ``` "Not Selected" = pu.color.palette[1], ``` 520 4 ``` "Selected" = pu.color.palette[2], ``` 521 4 ``` "Locked In" = pu.color.palette[3])) + ``` 522 4 ``` ggplot2::scale_size_manual(values = c("Locked Out" = 2, "Not Selected" = 2, ``` 523 4 ``` "Selected" = 4.5, "Locked In" = 4.5), ``` 524 4 ``` guide = FALSE) + ``` 525 4 ``` ggplot2::theme_classic() + ggplot2::coord_equal() + ``` 526 4 ``` ggplot2::theme(legend.position = "right", ``` 527 4 ``` axis.line.y = ggplot2::element_line(), ``` 528 4 ``` axis.line.x = ggplot2::element_line()) + ``` 529 4 ``` ggplot2::ggtitle(main) + ggplot2::xlab("Dimension 1") + ``` 530 4 ``` ggplot2::ylab("Dimension 2") ``` 531 ```} ``` 532 533 ```#' Plot a 3-d attribute space ``` 534 ```#' ``` 535 ```#' @noRd ``` 536 ```spacePlot.3d <- function(pu, dp, pu.color.palette, main) { ``` 537 ``` # check if rgl is installed ``` 538 0 ``` if (!requireNamespace("rgl", quietly = TRUE)) ``` 539 0 ``` stop("The rgl R package must be installed to visualise 3d attribute spaces") ``` 540 ``` # create frame ``` 541 0 ``` rgl::open3d() ``` 542 ``` # add pu points ``` 543 0 ``` if (length(pu.color.palette) == 1) ``` 544 0 ``` pu.color.palette <- brewerCols(seq(0, 1, 0.25), pu.color.palette, 4) ``` 545 0 ``` pu.cols <- character(nrow(pu)) ``` 546 0 ``` pu.cols[which(pu\$status == "Not Selected")] <- pu.color.palette[1] ``` 547 0 ``` pu.cols[which(pu\$status == "Selected")] <- pu.color.palette[2] ``` 548 0 ``` pu.cols[which(pu\$status == "Locked In")] <- pu.color.palette[3] ``` 549 0 ``` pu.cols[which(pu\$status == "Locked Out")] <- pu.color.palette[4] ``` 550 0 ``` rgl::points3d(as.matrix(pu[, seq_len(3)]), col = pu.cols) ``` 551 ``` # add dp points ``` 552 0 ``` dp.cols <- ggplot2::alpha(rep("darkblue", nrow(dp)), ``` 553 0 ``` affineTrans(dp\$weights, min(dp\$weights), ``` 554 0 ``` max(dp\$weights), 0.1, 1)) ``` 555 0 ``` rgl::points3d(as.matrix(dp[, seq_len(3)]), col = dp.cols) ``` 556 0 ``` rgl::title3d(main) ``` 557 ```} ``` 558 559 ```#' General argument parsing function ``` 560 ```#' ``` 561 ```#' @noRd ``` 562 ```parseArgs <- function(fn, object = NULL, skip = -1, ...) { ``` 563 4 ``` if (!is.null(object)) ``` 564 4 ``` fn <- paste0(fn, ".", class(object)) ``` 565 4 ``` ellipses.args <- list(...) ``` 566 4 ``` fn.args <- names(formals(fn)) ``` 567 4 ``` if (!is.null(skip)) ``` 568 4 ``` fn.args <- fn.args[skip] ``` 569 4 ``` ellipses.args[intersect(names(ellipses.args), fn.args)] ``` 570 ```} ``` 571 572 ```#' Alternative argument parsing function ``` 573 ```#' ``` 574 ```#' @noRd ``` 575 ```parseArgs2 <- function(args, ...) { ``` 576 0 ``` ellipses.args <- list(...) ``` 577 0 ``` ellipses.args[intersect(names(ellipses.args), args)] ``` 578 ```} ``` 579 580 ```#' Create an empty PolySet object ``` 581 ```#' @noRd ``` 582 ```emptyPolySet <- function() { ``` 583 0 ``` structure(list(PID = integer(0), SID = integer(0), POS = integer(0), ``` 584 0 ``` X = numeric(0), Y = numeric(0)), ``` 585 0 ``` .Names = c("PID", "SID", "POS", "X", "Y"), ``` 586 0 ``` row.names = integer(0), ``` 587 0 ``` class = c("PolySet", "data.frame")) ``` 588 ```} ``` 589 590 ```#' Calculate distances between points using URAP ``` 591 ```#' ``` 592 ```#' @noRd ``` 593 ```urap.squared.distance <- function(x, y, y.weights = rep(1, nrow(y))) { ``` 594 4 ``` assertthat::assert_that(inherits(x, "matrix"), inherits(y, "matrix"), ``` 595 4 ``` is.numeric(y.weights), nrow(y) == length(y.weights), ``` 596 4 ``` all(is.finite(c(x))), all(is.finite(c(y))), ``` 597 4 ``` all(is.finite(c(y.weights))), all(y.weights >= 0)) ``` 598 4 ``` rcpp_squared_distance(x, y, y.weights) ``` 599 ```} ``` 600 601 ```#' Calculate distances between points using RRAP ``` 602 ```#' ``` 603 ```#' @noRd ``` 604 ```rrap.squared.distance <- function(pu.coordinates, pu.probabilities, ``` 605 ``` dp.coordinates, dp.weights, failure.distance, ``` 606 ``` maximum.r.level = ``` 607 ``` as.integer(length(pu.probabilities))) { ``` 608 ``` # data integreity checks ``` 609 0 ``` assertthat::assert_that(inherits(pu.coordinates, "matrix"), ``` 610 0 ``` inherits(dp.coordinates, "matrix"), ``` 611 0 ``` inherits(pu.probabilities, "numeric"), ``` 612 0 ``` is.numeric(dp.weights), ``` 613 0 ``` assertthat::is.scalar(failure.distance), ``` 614 0 ``` assertthat::is.count(maximum.r.level), ``` 615 0 ``` nrow(pu.coordinates) == length(pu.probabilities), ``` 616 0 ``` nrow(dp.coordinates) == length(dp.weights), ``` 617 0 ``` ncol(dp.coordinates) == ncol(pu.coordinates), ``` 618 0 ``` all(is.finite(c(dp.weights))), ``` 619 0 ``` all(is.finite(c(pu.probabilities))), ``` 620 0 ``` all(is.finite(c(pu.coordinates))), ``` 621 0 ``` all(is.finite(c(dp.coordinates))), ``` 622 0 ``` all(is.finite(c(failure.distance))), ``` 623 0 ``` all(is.finite(c(maximum.r.level))), ``` 624 0 ``` maximum.r.level <= nrow(pu.coordinates), ``` 625 0 ``` failure.distance >= 0, ``` 626 0 ``` nrow(pu.coordinates) >= 1, ``` 627 0 ``` nrow(dp.coordinates) >= 1) ``` 628 ``` # main processing ``` 629 0 ``` rcpp_rrap_squared_distance(pu.coordinates, pu.probabilities, dp.coordinates, ``` 630 0 ``` dp.weights, failure.distance, maximum.r.level) ``` 631 ```} ``` 632 633 ```#' Dump object from model cache ``` 634 ```#' ``` 635 ```#' @noRd ``` 636 ```dump_object <- function(x, mode = c("numeric", "integer", "character")) { ``` 637 4 ``` assertthat::assert_that(inherits(x, "externalptr")) ``` 638 4 ``` mode <- match.arg(mode) ``` 639 4 ``` if (mode == "numeric") { ``` 640 4 ``` return(rcpp_dump_numeric_object(x)) ``` 641 ``` } ``` 642 0 ``` if (mode == "integer") { ``` 643 0 ``` return(rcpp_dump_integer_object(x)) ``` 644 ``` } ``` 645 0 ``` if (mode == "character") { ``` 646 0 ``` return(rcpp_dump_character_object(x)) ``` 647 ``` } ``` 648 ```} ``` 649 650 651 ```# define function to avoid CRAN check issue ``` 652 ```tmp.function <- rgdal::readOGR ```

Read our documentation on viewing source code .