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 .

Loading