1
#' @include RcppExports.R raptr-internal.R misc.R generics.R RapReliableOpts.R RapUnreliableOpts.R RapData.R RapUnsolved.R RapResults.R
2
NULL
3

4
#' RapSolved: An S4 class to represent RAP inputs and outputs
5
#'
6
#' This class is used to store RAP input and output data in addition to input
7
#' parameters.
8
#'
9
#' @slot opts [RapReliableOpts()] or [RapUnreliableOpts()]
10
#'   object used to store input parameters.
11
#'
12
#' @slot solver [GurobiOpts()] or [ManualOpts()] object
13
#'   used to store solver information/parameters.
14
#'
15
#' @slot data [RapData()] object used to store input data.
16
#'
17
#' @slot results [RapResults()] object used to store results.
18
#'
19
#' @seealso [RapReliableOpts-class],
20
#'   [RapUnreliableOpts-class], [RapData-class],
21
#'   [RapResults-class].
22
#'
23
#' @name RapSolved-class
24
#'
25
#' @rdname RapSolved-class
26
#'
27
#' @exportClass RapSolved
28
methods::setClass("RapSolved", methods::representation(opts = "RapOpts",
29
                                                       solver = "SolverOpts",
30
                                                       data = "RapData",
31
                                                       results = "RapResults"))
32

33
methods::setClassUnion("RapUnsolOrSol", c("RapSolved", "RapUnsolved"))
34

35
#' Create new RapSolved object
36
#'
37
#' This function creates a [RapSolved()] object.
38
#'
39
#' @param unsolved [RapUnsolved()] object.
40
#'
41
#' @param solver [GurobiOpts()] or [ManualOpts()] object.
42
#'
43
#' @param results [RapResults()] object.
44
#'
45
#' @return [RapSolved()] object.
46
#'
47
#' @seealso [RapSolved-class], [RapResults-class],
48
#'   \code{link{solve}}.
49
#'
50
#' @export
51
RapSolved <- function(unsolved, solver, results) {
52 4
  methods::new("RapSolved", opts = unsolved@opts, solver = solver,
53 4
               data = unsolved@data, results = results)
54
}
55

56
#' @rdname solve
57
#'
58
#' @usage \S4method{solve}{RapUnsolOrSol,missing}(a, b, ..., verbose = FALSE)
59
#'
60
#' @name solve
61
#'
62
#' @aliases solve,RapUnsolOrSol,missing-method
63
methods::setMethod("solve",
64
  methods::representation(a = "RapUnsolOrSol", b = "missing"),
65 0
  function(a, b, ..., verbose = FALSE)
66 0
    solve(a, b = GurobiOpts(...), verbose))
67

68

69
#' @rdname solve
70
#'
71
#' @usage \S4method{solve}{RapUnsolOrSol,GurobiOpts}(a, b, verbose = FALSE)
72
#'
73
#' @name solve
74
#'
75
#' @aliases solve,RapUnsolOrSol,GurobiOpts-method
76
methods::setMethod("solve",
77
  methods::representation(a = "RapUnsolOrSol", b = "GurobiOpts"),
78
  function(a, b, verbose = FALSE) {
79
    ## init
80
    # run object checks
81 0
    if (!a@data@skipchecks) methods::validObject(a@data, test = FALSE)
82 0
    methods::validObject(a@opts, test = FALSE)
83
    # check that gurobi is installed
84 0
    if (!is.null(options()$GurobiInstalled))
85 0
        is.GurobiInstalled()
86 0
    if (!options()$GurobiInstalled$gurobi) {
87 0
      is.GurobiInstalled()
88 0
      if (!options()$GurobiInstalled$gurobi)
89 0
        stop(paste0("The Gurobi software package and the \"gurobi\" R package ",
90 0
                    "must be intalled."))
91
    }
92
    # generate model object
93 0
    model <- rcpp_generate_model_object(a@opts,
94 0
                                        inherits(a@opts, "RapUnreliableOpts"),
95 0
                                        a@data, verbose)
96 0
    model$A <- Matrix::sparseMatrix(i = model$Ar$row + 1, j = model$Ar$col + 1,
97 0
                                    x = model$Ar$value,
98 0
                                    dims = c(max(model$Ar$row) + 1,
99 0
                                             length(model$obj)))
100
    # run basic checks that the model matrix has been constructed correctly
101 0
    assertthat::assert_that(
102 0
      sum(!is.finite(model$Ar$value)) == 0,
103 0
      msg = "Invalid model matrix constructed.")
104
    ## Initial run
105
    # run model
106 0
    log.pth <- tempfile(fileext = ".log")
107 0
    gparams <- append(as.list(b), list("LogFile" = log.pth))
108 0
    if (b@MultipleSolutionsMethod == "benders.cuts") {
109 0
      solution <- gurobi::gurobi(model, gparams)
110
    } else {
111 0
      solution <- gurobi::gurobi(model,
112 0
          append(gparams,
113 0
                 list(PoolSolutions = b@NumberSolutions,
114 0
                      PoolSearchMode = as.numeric(
115 0
                        gsub("solution.pool.", "",  b@MultipleSolutionsMethod,
116 0
                             fixed = TRUE)))))
117
    }
118 0
    if (file.exists("gurobi.log")) unlink("gurobi.log")
119
    # check solution object
120 0
    if (!is.null(solution$status))
121 0
      if (solution$status == "INFEASIBLE") {
122 0
        stop(paste0("No solution found because the problem cannot be solved ",
123 0
                    "because space-based targets are too high. Try setting ",
124 0
                    "lower space-based targets. See ?maximum.targets"))
125
      }
126 0
    if (is.null(solution$x)) {
127 0
      stop(paste0("No solution found because Gurobi parameters do not allow ",
128 0
                  "sufficient time."))
129
    }
130
    ## Subsequent runs if using Bender's cuts to obtain multiple solutions
131 0
    if (b@MultipleSolutionsMethod == "benders.cuts") {
132
      # store results
133 0
      results <- list(read.RapResults(a@opts, a@data, model,
134 0
                                      paste(readLines(log.pth),
135 0
                                            collapse = "\n"),
136 0
                                      solution, verbose))
137 0
      existing.solutions <- list(selections(results[[1]]))
138
      ## subsequent runs
139 0
      for (i in seq_len(b@NumberSolutions - 1)) {
140
        # create new model object, eacluding existing solutions as valid
141
        # solutions to ensure a different solution is obtained
142 0
        model <- rcpp_append_model_object(
143 0
          model, existing.solutions[length(existing.solutions)])
144 0
        model$A <- Matrix::sparseMatrix(i = model$Ar$row + 1,
145 0
                                        j = model$Ar$col + 1,
146 0
                                        x = model$Ar$value,
147 0
                                        dims = c(max(model$Ar$row) + 1,
148 0
                                                 length(model$obj)))
149
        # run model
150 0
        solution <- gurobi::gurobi(model, gparams)
151 0
        if (file.exists("gurobi.log")) unlink("gurobi.log")
152
        # load results
153 0
        if (!is.null(solution$status))
154 0
          if (solution$status == "INFEASIBLE") {
155 0
            warning(paste0("only ", i, " solutions found"))
156 0
            break
157
          }
158 0
        if (is.null(solution$x)) {
159 0
          warning(paste0("only ", i, " solutions found"))
160 0
          break
161
        }
162
        # store results
163 0
        currResult <- read.RapResults(a@opts, a@data, model,
164 0
                                      paste(readLines(log.pth),
165 0
                                            collapse = "\n"), solution, verbose)
166 0
        results <- append(results, currResult)
167 0
        existing.solutions <- append(existing.solutions,
168 0
                                     list(selections(currResult)))
169
      }
170
    } else {
171
      # format results into a single list
172 0
      raw.results <- list(solution[c("x", "objval", "status", "runtime")])
173 0
      if (!is.null(solution$pool))
174 0
        raw.results <- append(raw.results,
175 0
          lapply(solution$pool, function(z)
176 0
            list(x = z$xn, objval = z$objval,
177 0
                 status = ifelse(abs(z$objval - raw.results[[1]]$objval) < 1e-10, "OPTIMAL", "SUBOPTIMAL"),
178 0
                 runtime = solution$runtime)))
179 0
      if (length(raw.results) > b@NumberSolutions)
180 0
        raw.results <- raw.results[seq_len(b@NumberSolutions)]
181
      # extract solutions
182 0
      results <- lapply(raw.results, function(z) {
183 0
        read.RapResults(a@opts, a@data, model,
184 0
                        paste(readLines(log.pth), collapse = "\n"),
185 0
                        z, verbose)
186
      })
187
    }
188
    # return RapSolved object
189 0
    RapSolved(unsolved = a, solver = b, results = mergeRapResults(results))
190
})
191

192
#' @rdname solve
193
#'
194
#' @usage \S4method{solve}{RapUnsolOrSol,matrix}(a, b, verbose = FALSE)
195
#'
196
#' @name solve
197
#'
198
#' @aliases solve,RapUnsolOrSol,matrix-method
199
methods::setMethod("solve",
200
  methods::representation(a = "RapUnsolOrSol", b = "matrix"),
201
  function(a, b, verbose = FALSE) {
202
    # check arguments for validity
203 4
    assertthat::assert_that(
204 4
      ncol(b) == nrow(a@data@pu),
205 4
      msg = "argument to b has different number of planning units to a")
206 4
    assertthat::assert_that(
207 4
      all(is.finite(b)),
208 4
      msg = "argument to b must not contain any NA values")
209 4
    assertthat::assert_that(
210 4
      all(b %in% c(0, 1)),
211 4
      msg = "argument to b must be binary selections when b is a matrix")
212
    # generate result objects
213 4
    model <- rcpp_generate_model_object(a@opts,
214 4
                                        inherits(a@opts, "RapUnreliableOpts"),
215 4
                                        a@data, verbose)
216 4
    results <- list()
217 4
    for (i in seq_len(nrow(b))) {
218
      # generate result object
219 4
      currResult <- read.RapResults(a@opts, a@data, model,
220 4
                                    "User specified solution",
221 4
                                     list(x = b[i, ], objval = NA,
222 4
                                          status = "MANUAL"), verbose)
223 4
      results <- append(results, currResult)
224
    }
225
    # return RapSolved object
226 4
    RapSolved(unsolved = a, solver = ManualOpts(NumberSolutions = nrow(b)),
227 4
              results = mergeRapResults(results))
228
})
229

230
#' @rdname solve
231
#'
232
#' @usage \S4method{solve}{RapUnsolOrSol,numeric}(a, b, verbose = FALSE)
233
#'
234
#' @name solve
235
#'
236
#' @aliases solve,RapUnsolOrSol,numeric-method
237
methods::setMethod("solve",
238
  methods::representation(a = "RapUnsolOrSol",  b = "numeric"),
239
  function(a, b, verbose = FALSE) {
240
    # check arguments for validity
241 4
    assertthat::assert_that(all(b %in% seq_len(nrow(a@data@pu))),
242 4
      msg = "argument to b refers to planning unit indices not in a")
243
    # return RapSolved object
244 4
    solve(a, b = matrix(replace(rep(0, nrow(a@data@pu)), b,
245 4
                                rep(1, length(b))), nrow = 1),
246 4
          verbose = verbose)
247
})
248

249
#' @rdname solve
250
#'
251
#' @usage \S4method{solve}{RapUnsolOrSol,logical}(a, b, verbose = FALSE)
252
#'
253
#' @name solve
254
#'
255
#' @aliases solve,RapUnsolOrSol,logical-method
256
methods::setMethod("solve",
257
  methods::representation(a = "RapUnsolOrSol", b = "logical"),
258
  function(a, b, verbose = FALSE) {
259
    # check arguments for validity
260 0
    assertthat::assert_that(
261 0
      length(b) == nrow(a@data@pu),
262 0
      msg = "argument to b has different number of planning units to a")
263
    # generate RapSolved object with user-specified solution
264 0
    solve(a, b = matrix(as.numeric(b), nrow = 1), verbose = verbose)
265
})
266

267
#' @rdname selections
268
#'
269
#' @export
270
selections.RapSolved <- function(x, y = 0) {
271 4
  selections.RapResults(x@results, y)
272
}
273

274
#' @rdname score
275
#'
276
#' @export
277
score.RapSolved <- function(x, y = 0) {
278 4
  score.RapResults(x@results, y)
279
}
280

281
#' @method summary RapSolved
282
#'
283
#' @export
284
summary.RapSolved <- function(object, ...) {
285 4
  summary.RapResults(object@results)
286
}
287

288
#' @export
289
#'
290
#' @rdname amount.held
291
amount.held.RapSolved <- function(x, y = 0, species = NULL) {
292
  # get solution numbers
293 4
  if (is.null(y))
294 4
    y <- seq_len(nrow(x@results@selections))
295 4
  if (all(y == 0))
296 4
    y <- x@results@best
297
  # get species numbers
298 4
  if (is.null(species))
299 4
    species <- seq_len(nrow(x@data@species))
300 4
  if (is.character(species))
301 0
    species <- match(species, x@data@species$name)
302
  # return named vector
303 4
  structure(x@results@amount.held[y, species],
304 4
            .Dim = c(length(y), length(species)),
305 4
            .Dimnames = list(seq_along(y),
306 4
                             x@data@species$name[species]))
307
}
308

309
#' @rdname space.held
310
#'
311
#' @export
312
space.held.RapSolved <- function(x, y = 0, species = NULL, space = NULL) {
313
  # get solution numbers
314 4
  if (is.null(y))
315 4
    y <- seq_len(nrow(x@results@selections))
316 4
  if (all(y == 0))
317 4
    y <- x@results@best
318
  # convert species to numeric
319 4
  if (is.character(species)) {
320 4
    species <- match(species, x@data@species[[1]])
321 4
    assertthat::assert_that(
322 4
      all(!is.na(species)),
323 4
      msg = "argument to species not found in argument to x")
324
  }
325
  # convert space to numeric
326 4
  if (is.character(space)) {
327 4
    space <- match(space, sapply(x@data@attribute.spaces, methods::slot,
328 4
                                 "name"))
329 4
    assertthat::assert_that(
330 4
      all(!is.na(space)),
331 4
      msg = "argument to species not found in argument to x")
332
  }
333
  # get species number
334 4
  if (is.null(species))
335 4
    species <- seq_len(nrow(x@data@species))
336
  # get space numbers
337 4
  if (is.null(space))
338 4
    space <- seq_along(x@data@attribute.spaces)
339
  # return named array
340 4
  as_ind <- rep(seq_along(x@data@attribute.spaces), nrow(x@data@species))
341 4
  sp_ind <- rep(seq_len(nrow(x@data@species)),
342 4
                each = length(x@data@attribute.spaces))
343 4
  structure(c(x@results@space.held[y, sp_ind %in% species & as_ind %in% space]),
344 4
            dim = c(length(y), length(species) * length(space)),
345 4
            dimnames = list(seq_along(y),
346 4
                            paste0(rep(x@data@species$name[species],
347 4
                                       each = length(space)),
348 4
                                   rep(paste0(" (Space ", space, ")"),
349 4
                                       length(species)))))
350
}
351

352
#' @rdname logging.file
353
#'
354
#' @export
355
logging.file.RapSolved <- function(x, y = 0) {
356 4
  logging.file.RapResults(x@results, y)
357
}
358

359
#' @method print RapSolved
360
#'
361
#' @rdname print
362
#'
363
#' @export
364
print.RapSolved <- function(x, ...) {
365 0
  message("RapSolved object\n")
366 0
  message("Parameters")
367 0
  print(x@opts, header = FALSE)
368 0
  message("Solver settings")
369 0
  print(x@solver, header = FALSE)
370 0
  message("Data")
371 0
  print.RapData(x@data, header = FALSE)
372 0
  message("Results")
373 0
  print.RapResults(x@results, header = FALSE)
374 0
  invisible()
375
}
376

377
#' @rdname spp.subset
378
#'
379
#' @method spp.subset RapUnsolOrSol
380
#'
381
#' @export
382
spp.subset.RapUnsolOrSol <- function(x, species) {
383 4
  RapUnsolved(opts = x@opts, data = spp.subset(x@data, species))
384
}
385

386
#' @rdname pu.subset
387
#'
388
#' @method pu.subset RapUnsolOrSol
389
#'
390
#' @export
391
pu.subset.RapUnsolOrSol <- function(x, pu) {
392 4
  RapUnsolved(opts = x@opts, data = pu.subset(x@data, pu))
393
}
394

395
#' @rdname dp.subset
396
#'
397
#' @method dp.subset RapUnsolOrSol
398
#'
399
#' @export
400
dp.subset.RapUnsolOrSol <- function(x, space, species, points) {
401 4
  RapUnsolved(opts = x@opts, data = dp.subset(x@data, space, species, points))
402
}
403

404
#' @rdname prob.subset
405
#'
406
#' @method prob.subset RapUnsolOrSol
407
#'
408
#' @export
409
prob.subset.RapUnsolOrSol <- function(x, species, threshold) {
410 0
  RapUnsolved(opts = x@opts, data = prob.subset(x@data, species, threshold))
411
}
412

413
#' @rdname show
414
#'
415
#' @usage \S4method{show}{RapSolved}(object)
416
#'
417
#' @name show
418
#'
419
#' @aliases show,RapSolved-method
420
methods::setMethod("show", "RapSolved",
421 0
                   function(object) print.RapSolved(object))
422

423
#' @rdname is.comparable
424
#'
425
#' @usage \S4method{is.comparable}{RapUnsolOrSol,RapUnsolOrSol}(x, y)
426
#'
427
#' @name is.comparable
428
#'
429
#' @aliases is.comparable,RapUnsolOrSol,RapUnsolOrSol-method
430
methods::setMethod("is.comparable",
431
  methods::signature(x = "RapUnsolOrSol", y = "RapUnsolOrSol"),
432 4
  function(x, y) is.comparable(x@data, y@data))
433

434
#' @rdname is.comparable
435
#'
436
#' @usage \S4method{is.comparable}{RapData,RapUnsolOrSol}(x, y)
437
#'
438
#' @name is.comparable
439
#'
440
#' @aliases is.comparable,RapData,RapUnsolOrSol-method
441
setMethod("is.comparable",
442
  methods::signature(x = "RapData", y = "RapUnsolOrSol"),
443 0
  function(x, y) is.comparable(x, y@data))
444

445
#' @rdname is.comparable
446
#'
447
#' @usage \S4method{is.comparable}{RapUnsolOrSol,RapData}(x, y)
448
#'
449
#' @name is.comparable
450
#'
451
#' @aliases is.comparable,RapUnsolOrSol,RapData-method
452
methods::setMethod("is.comparable",
453
  methods::signature(x = "RapUnsolOrSol", y = "RapData"),
454 0
  function(x, y) is.comparable(x@data, y))
455

456
#' @rdname basemap
457
#'
458
#' @export
459
basemap.RapSolved <- function(x, basemap = "none", grayscale = FALSE,
460
                              force.reset = FALSE) {
461 0
  basemap.RapData(x@data, basemap, grayscale, force.reset)
462
}
463

464
#' @rdname plot
465
#'
466
#' @usage \S4method{plot}{RapSolved,numeric}(x, y, basemap = "none",
467
#'  pu.color.palette = c("#e5f5f9", "#00441b", "#FFFF00", "#FF0000"), alpha =
468
#'  ifelse(basemap == "none", 1, 0.7), grayscale = FALSE, main = NULL,
469
#'  force.reset = FALSE)
470
#'
471
#' @name plot
472
#'
473
#' @aliases plot,RapSolved,numeric-method
474
methods::setMethod("plot",
475
  methods::signature(x = "RapSolved", y = "numeric"),
476
  function(x, y, basemap = "none",
477
           pu.color.palette = c("#e5f5f9", "#00441b", "#FFFF00", "#FF0000"),
478
           alpha = ifelse(basemap == "none", 1, 0.7),
479
           grayscale = FALSE, main = NULL, force.reset = FALSE) {
480
    # check for issues
481 4
    assertthat::assert_that(nrow(x@data@polygons) > 0,
482 4
                            assertthat::is.scalar(alpha),
483 4
                            isTRUE(alpha <= 1), isTRUE(alpha >= 0),
484 4
                            is.character(pu.color.palette),
485 4
                            length(pu.color.palette) == 4,
486 4
                            all(!is.na(pu.color.palette)),
487 4
                            assertthat::is.flag(grayscale),
488 4
                            assertthat::is.string(main) || is.null(main),
489 4
                            assertthat::is.flag(force.reset),
490 4
                            assertthat::is.count(y + 1),
491 4
                            y <= nrow(x@results@selections))
492
    # get basemap data
493 4
    if (basemap != "none")
494 0
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
495
    # main processing
496 4
    if (y == 0)
497 4
      y <- x@results@best
498 4
    values <- x@results@selections[y, ]
499 4
    cols <- character(length(values))
500 4
    cols[which(values == 0)] <- pu.color.palette[1]
501 4
    cols[which(values == 1)] <- pu.color.palette[2]
502 4
    cols[which(x@data@pu$status == 2)] <- pu.color.palette[3]
503 4
    cols[which(x@data@pu$status == 3)] <- pu.color.palette[4]
504
    # set title
505 4
    if (is.null(main)) {
506 4
      if (y == x@results@best) {
507 4
        main <- paste0("Best solution (", y, ")")
508
      } else {
509 0
        main <- paste0("Solution ", y)
510
      }
511
    }
512 4
    prettyGeoplot(x@data@polygons, cols, basemap, main = main,
513 4
                  categoricalLegend(pu.color.palette[c(4, 1, 2, 3)],
514 4
                                    c("Locked Out", "Not Selected",
515 4
                                      "Selected", "Locked In")),
516 4
                  beside = FALSE,
517 4
                  border = "gray30")
518
})
519

520
#' @rdname plot
521
#'
522
#' @usage \S4method{plot}{RapSolved,missing}(x, y, basemap = "none",
523
#' pu.color.palette = c("PuBu", "#FFFF00", "#FF0000"),
524
#' alpha = ifelse(basemap == "none", 1, 0.7),
525
#' grayscale = FALSE, main = NULL,
526
#' force.reset = FALSE)
527
#'
528
#' @name plot
529
#'
530
#' @aliases plot,RapSolved,missing-method
531
methods::setMethod("plot",
532
  methods::signature(x = "RapSolved", y = "missing"),
533
  function(x, y, basemap = "none",
534
           pu.color.palette = c("PuBu", "#FFFF00", "#FF0000"),
535
           alpha = ifelse(basemap == "none", 1, 0.7),
536
           grayscale = FALSE, main = NULL,
537
           force.reset = FALSE) {
538
    # check for issues
539 4
    basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
540 4
                                    "terrain", "hybrid", "mapmaker-roadmap",
541 4
                                    "mapmaker-hybrid"))
542 4
    assertthat::assert_that(nrow(x@data@polygons) > 0,
543 4
                            assertthat::is.string(basemap),
544 4
                            is.character(pu.color.palette),
545 4
                            length(pu.color.palette) == 3,
546 4
                            pu.color.palette[1] %in%
547 4
                              rownames(RColorBrewer::brewer.pal.info),
548 4
                            all(!is.na(pu.color.palette)),
549 4
                            assertthat::is.scalar(alpha),
550 4
                            isTRUE(alpha >= 0), isTRUE(alpha <= 1),
551 4
                            assertthat::is.flag(grayscale),
552 4
                            assertthat::is.string(main) || is.null(main),
553 4
                            assertthat::is.flag(force.reset))
554
    # get basemap data
555 4
    if (basemap != "none")
556 0
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
557
    # set title
558 4
    if (is.null(main)) {
559 4
      main <- "Selection frequencies (%)"
560
    }
561
    # main processing
562 4
    if (force.reset || !is.cached(x@results, "selectionfreqs")) {
563 4
      cache(x@results, "selectionfreqs", colMeans(x@results@selections))
564
    }
565 4
    values <- cache(x@results, "selectionfreqs")[which(x@data@pu$status < 2)]
566 4
    cols <- character(length(cache(x@results, "selectionfreqs")))
567 4
    cols[which(x@data@pu$status < 2)] <- brewerCols(
568 4
      scales::rescale(values, from = range(values), to = c(0, 1)),
569 4
      pal = pu.color.palette[1], alpha = alpha)
570 4
    cols[which(x@data@pu$status == 2)] <- pu.color.palette[2]
571 4
    cols[which(x@data@pu$status == 3)] <- pu.color.palette[3]
572
    # make plot
573 4
    prettyGeoplot(x@data@polygons, cols, basemap, main = main,
574 4
                  continuousLegend(values, pu.color.palette[1],
575 4
                                   posx = c(0.3, 0.4),posy = c(0.1, 0.9)),
576 4
                  beside = TRUE, border = "gray30")
577
})
578

579
#' @rdname plot
580
#'
581
#' @usage \S4method{plot}{RapSolved,RapSolved}(x, y, i = NULL, j = i,
582
#' basemap = "none",
583
#' pu.color.palette = ifelse(is.null(i), c("RdYlBu", "#FFFF00",
584
#' "#FF0000"), "Accent"),
585
#' alpha = ifelse(basemap == "none", 1, 0.7),
586
#' grayscale = FALSE, main = NULL, force.reset = FALSE)
587
#'
588
#' @name plot
589
#'
590
#' @aliases plot,RapSolved,RapSolved-method
591
methods::setMethod("plot",
592
  methods::signature(x = "RapSolved", y = "RapSolved"),
593
  function(x, y, i = NULL, j = i, basemap = "none",
594
           pu.color.palette = ifelse(is.null(i), c("RdYlBu", "#FFFF00",
595
                                                   "#FF0000"), "Accent"),
596
           alpha = ifelse(basemap == "none", 1, 0.7),
597
           grayscale = FALSE, main = NULL, force.reset = FALSE) {
598
    # check for issues
599 4
    basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
600 4
                                    "terrain", "hybrid", "mapmaker-roadmap",
601 4
                                    "mapmaker-hybrid"))
602 4
    assertthat::assert_that(nrow(x@data@polygons) > 0,
603 4
                            is.comparable(x, y),
604 4
                            assertthat::is.string(basemap),
605 4
                            is.character(pu.color.palette),
606 4
                            length(pu.color.palette) == 1 ||
607 4
                            length(pu.color.palette) == 3,
608 4
                            all(!is.na(pu.color.palette)),
609 4
                            pu.color.palette[1] %in%
610 4
                              rownames(RColorBrewer::brewer.pal.info),
611 4
                            assertthat::is.scalar(alpha),
612 4
                            isTRUE(alpha >= 0), isTRUE(alpha <= 1),
613 4
                            assertthat::is.flag(grayscale),
614 4
                            assertthat::is.string(main) || is.null(main),
615 4
                            assertthat::is.flag(force.reset))
616
    # get basemap data
617 4
    if (basemap != "none")
618 0
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
619
    # main processing
620 4
    cols <- character(nrow(x@data@pu))
621 4
    if (is.null(i) || is.null(j)) {
622 4
      if (is.null(main)) main <- "Difference in selection frequencies (%)"
623 4
      cols[which(x@data@pu$status == 2)] <- pu.color.palette[2]
624 4
      cols[which(y@data@pu$status == 2)] <- pu.color.palette[2]
625 4
      cols[which(x@data@pu$status == 3)] <- pu.color.palette[3]
626 4
      cols[which(y@data@pu$status == 3)] <- pu.color.palette[3]
627

628 4
      if (force.reset || !is.cached(x@results, "selectionfreqs"))
629 4
        cache(x@results, "selectionfreqs", colMeans(x@results@selections))
630 4
      xsc <- cache(x@results, "selectionfreqs")[which(nchar(cols) == 0)]
631 4
      if (force.reset || !is.cached(y@results, "selectionfreqs"))
632 4
        cache(y@results, "selectionfreqs", colMeans(y@results@selections))
633 4
      ysc <- cache(y@results, "selectionfreqs")[which(nchar(cols) == 0)]
634 4
      values <- xsc - ysc
635 4
      col.pos <- which(nchar(cols) == 0)
636 4
      cols[col.pos] <- brewerCols(scales::rescale(values, to = c(0, 1)),
637 4
                                                  pu.color.palette[1], alpha)
638
      # determine legend function
639 4
      if (length(unique(round(values, 5))) > 1) {
640 4
        legend.fun <- continuousLegend(values, pu.color.palette[1],
641 4
                                       posx = c(0.3, 0.4),
642 4
                                       posy = c(0.1, 0.9),
643 4
                                       center = TRUE,
644 4
                                       endlabs = c("+X", "+Y"))
645 4
        beside <- TRUE
646
      } else {
647
        # create legend entries
648 0
        leg.cols <- c(cols[col.pos[1]])
649 0
        leg.labs <- c(values[1])
650 0
        if (any(x@data@pu$status == 2) | any(y@data@pu$status == 2)) {
651 0
          leg.cols <- c(leg.cols, pu.color.palette[2])
652 0
          leg.labs <- c(leg.labs, "Locked in")
653
        }
654 0
        if (any(x@data@pu$status == 3) | any(y@data@pu$status == 3)) {
655 0
          leg.cols <- c(leg.cols, pu.color.palette[3])
656 0
          leg.labs <- c(leg.labs, "Locked out")
657
        }
658
        # create legend function
659 0
        legend.fun <- categoricalLegend(leg.cols, leg.labs, ncol = 1)
660 0
        beside <- FALSE
661
      }
662 4
      prettyGeoplot(x@data@polygons, cols, basemap, main = main,
663 4
                    fun = legend.fun, beside = beside, border = "gray30")
664
    } else {
665 4
      if (i == 0)
666 4
        i <- x@results@best
667 4
      if (j == 0)
668 0
        j <- y@results@best
669 4
      cols2 <- brewerCols(seq(0, 1, length.out = 8), pu.color.palette, alpha,
670 4
                          n = 8)
671 4
      cols[which(x@results@selections[i, ] == 1 &
672 4
                 y@results@selections[j, ] == 0)] <- cols2[1]
673 4
      cols[which(x@results@selections[i, ] == 0 &
674 4
                 y@results@selections[j, ] == 1)] <- cols2[2]
675 4
      cols[which(x@results@selections[i, ] == 1 &
676 4
                 y@results@selections[j, ] == 1)] <- cols2[3]
677 4
      cols[which(x@results@selections[i, ] == 0 &
678 4
                 y@results@selections[j, ] == 0)] <- cols2[4]
679

680 4
      cols[which(x@data@pu$status == 2)] <- cols2[5]
681 4
      cols[which(y@data@pu$status == 2)] <- cols2[6]
682 4
      cols[which(x@data@pu$status == 3)] <- cols2[7]
683 4
      cols[which(y@data@pu$status == 3)] <- cols2[8]
684

685 4
      if (is.null(main)) {
686 4
        main <- paste0("Difference between solution ",
687 4
                       i, ifelse(i == x@results@best, " (best)", ""),
688 4
                       " and solution ", j,
689 4
                       ifelse(j == y@results@best, " (best)", ""))
690
      }
691

692 4
      prettyGeoplot(x@data@polygons, cols, basemap, main=main,
693 4
                    categoricalLegend(c(cols2), c("Selected in X",
694 4
                                                  "Selected in Y",
695 4
                                                  "Both", "Neither",
696 4
                                                  "Locked in X",
697 4
                                                  "Locked in Y",
698 4
                                                  "Locked out X",
699 4
                                                  "Locked out Y"), ncol = 4),
700 4
                    beside = FALSE)
701
    }
702
})
703

704
#' @rdname spp.plot
705
#'
706
#' @method spp.plot RapSolved
707
#'
708
#' @export
709
spp.plot.RapSolved<-function(x, species, y = 0, prob.color.palette = "YlGnBu",
710
                             pu.color.palette = c("#4D4D4D", "#00FF00",
711
                                                  "#FFFF00", "#FF0000"),
712
                             basemap = "none",
713
                             alpha = ifelse(basemap == "none", 1, 0.7),
714
                             grayscale = FALSE, main = NULL,
715
                             force.reset = FALSE, ...) {
716
  # data checks
717 4
  basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
718 4
                                  "terrain", "hybrid", "mapmaker-roadmap",
719 4
                                  "mapmaker-hybrid"))
720 4
  assertthat::assert_that(nrow(x@data@polygons) > 0,
721 4
                          assertthat::is.count(y + 1),
722 4
                          y %in% seq(0, nrow(x@results@selections)),
723 4
                          assertthat::is.count(species) ||
724 4
                            assertthat::is.string(species),
725 4
                          assertthat::is.string(basemap),
726 4
                          is.character(pu.color.palette),
727 4
                          length(pu.color.palette) %in% c(1, 4),
728 4
                          all(!is.na(pu.color.palette)),
729 4
                          assertthat::is.scalar(alpha),
730 4
                          isTRUE(alpha >= 0), isTRUE(alpha <= 1),
731 4
                          assertthat::is.flag(grayscale),
732 4
                          assertthat::is.string(main) || is.null(main),
733 4
                          assertthat::is.flag(force.reset))
734 4
  if (is.character(species)) {
735 0
    spp_pos <- match(species, x@data@species$name)
736 0
    assertthat::assert_that(
737 0
      !is.na(spp_pos),
738 0
      msg = "argument to species is not a species name in argument to x")
739
  } else {
740 4
    if (is.numeric(species)) {
741 4
      assertthat::assert_that(
742 4
        species %in% seq_along(x@data@species$name),
743 4
        msg = paste0("argument to species is not a valid index for species ",
744 4
                     "in argument to x"))
745 4
      spp_pos <- species
746
    }
747
  }
748
  # set title
749 4
  if (is.null(main)) {
750 4
    if ("name" %in% names(x@data@species) & is.numeric(species)) {
751 4
      main <- paste0(x@data@species$name[species])
752 0
    } else if (is.numeric(species)) {
753 0
      main <- paste0("Species ", species)
754
    } else {
755 0
      main <- paste0(species)
756
    }
757
  }
758
  # get basemap
759 4
  if (basemap != "none")
760 0
    basemap <- basemap.RapData(x, basemap, grayscale, force.reset)
761
  ## main processing
762
  # extract planning fill unit colors
763 4
  values <- numeric(nrow(x@data@pu))
764 4
  rows <- which(x@data@pu.species.probabilities$species == spp_pos)
765 4
  values[x@data@pu.species.probabilities$pu[rows]] <-
766 4
    x@data@pu.species.probabilities$value[rows]
767 4
  if (length(unique(values)) > 1) {
768 0
    cols <- brewerCols(scales::rescale(values, to = c(0,1)),
769 0
                       prob.color.palette, alpha)
770
  } else {
771 4
    cols <- brewerCols(rep(values[1], length(values)), prob.color.palette,
772 4
                       alpha)
773 4
    values <- c(0, values[1])
774
  }
775
  # get selected rows
776 4
  sel.pu.ids <- which(as.logical(selections(x, y)))
777 4
  unsel.pu.ids <- which(!as.logical(selections(x, y)))
778
  # extract planning unit border colors
779 4
  border.cols <- rep(pu.color.palette[1], nrow(x@data@pu))
780 4
  border.cols[sel.pu.ids] <- pu.color.palette[2]
781 4
  border.cols[which(x@data@pu$status == 2)] <- pu.color.palette[3]
782 4
  border.cols[which(x@data@pu$status == 3)] <- pu.color.palette[4]
783
  # make plot
784 4
  prettyGeoplot(list(x@data@polygons[x@data@polygons$PID %in% unsel.pu.ids, ],
785 4
                     x@data@polygons[x@data@polygons$PID %in% sel.pu.ids, ]),
786 4
                list(cols[unsel.pu.ids], cols[sel.pu.ids]),
787 4
                basemap, main,
788 4
                continuousLegend(values, prob.color.palette,
789 4
                                 posx = c(0.3, 0.4),posy = c(0.1, 0.9)),
790 4
                beside = TRUE, border = list(border.cols[unsel.pu.ids],
791 4
                                             border.cols[sel.pu.ids]),
792 4
                lwd = list(1, 5))
793
}
794

795
#' @rdname space.plot
796
#'
797
#' @method space.plot RapSolved
798
#'
799
#' @export
800
space.plot.RapSolved <- function(x, species, space = 1, y = 0,
801
                                 pu.color.palette = c("#4D4D4D4D", "#00FF0080",
802
                                                      "#FFFF0080", "#FF00004D"),
803
                                 main = NULL, ...) {
804
  # data checks
805 4
  assertthat::assert_that(assertthat::is.count(species) ||
806 4
                            assertthat::is.string(species),
807 4
                          assertthat::is.count(space),
808 4
                          assertthat::is.count(y + 1),
809 4
                          y %in% seq(0, nrow(x@results@selections)),
810 4
                          is.character(pu.color.palette),
811 4
                          length(pu.color.palette) %in% c(1, 4),
812 4
                          all(!is.na(pu.color.palette)),
813 4
                          assertthat::is.string(main) || is.null(main))
814 4
  if (is.character(species)) {
815 0
    spp_pos <- match(species, x@data@species$name)
816 0
    assertthat::assert_that(
817 0
      !is.na(spp_pos),
818 0
      msg = "argument to species is not a species name in argument to x")
819
  } else{
820 4
    if (is.numeric(species)) {
821 4
      assertthat::assert_that(
822 4
        species %in% seq_along(x@data@species$name),
823 4
        msg = paste0("argument to species is not a valid index for species ",
824 4
                     "in argument to x"))
825 4
      spp_pos <- species
826
    }
827
  }
828
  # set title
829 4
  if (is.null(main)) {
830 4
    if ("name" %in% names(x@data@species) & is.numeric(species)) {
831 4
      main <- paste0(x@data@species$name[species], " in space ", space)
832 0
    } else if (is.numeric(species)) {
833 0
      main <- paste0("Species ", species, " in space ", space)
834
    } else {
835 0
      main<-paste0(species, " in space ", space)
836
    }
837
  }
838
  # extract pu data
839 4
  pu <- as.data.frame(x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
840 4
                      planning.unit.points@coords)
841 4
  names(pu) <- paste0("X", seq_len(ncol(pu)))
842 4
  pu_ids <- x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
843 4
              planning.unit.points@ids
844 4
  pu$status <- "Not Selected"
845 4
  pu$status[as.logical(selections(x, y)[pu_ids])] <- "Selected"
846 4
  pu$status[which(x@data@pu$status[pu_ids] == 2)] <- "Locked In"
847 4
  pu$status[which(x@data@pu$status[pu_ids] == 3)] <- "Locked Out"
848
  # extract dp data
849 4
  dp <- as.data.frame(x@data@attribute.spaces[[space]]@
850 4
                        spaces[[spp_pos]]@demand.points@coords)
851 4
  names(dp) <- paste0("X",seq_len(ncol(dp)))
852 4
  dp$weights <- x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
853 4
                  demand.points@weights
854
  # make plots
855 4
  n_dim <- ncol(x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
856 4
                  planning.unit.points@coords)
857 4
  do.call(paste0("spacePlot.", n_dim, 'd' ),
858 4
          list(pu, dp, pu.color.palette, main))
859
}
860

861
#' @rdname update
862
#'
863
#' @method update RapUnsolOrSol
864
#'
865
#' @export
866
update.RapUnsolOrSol <- function(object, ..., formulation  =NULL,
867
                                 solve = TRUE) {
868 4
  assertthat::assert_that(is.null(formulation) ||
869 4
                            assertthat::is.string(formulation),
870 4
                          assertthat::is.flag(solve))
871
  # update formulation
872 4
  opts <- object@opts
873 4
  if (!is.null(formulation)) {
874 4
    match.arg(formulation, c("unreliable", "reliable"))
875
    # create new opts object
876 4
    if (formulation == "unreliable") {
877 0
      opts <- RapUnreliableOpts()
878
    } else {
879 4
      opts <- RapReliableOpts()
880
    }
881
    # fill in matching slots
882 4
    for (i in methods::slotNames(object@opts)) {
883 4
      if (i %in% methods::slotNames(opts))
884 4
        methods::slot(opts, i) <- methods::slot(object@opts, i)
885
    }
886
  }
887
  # return updated object
888 4
  object <- RapUnsolved(opts = do.call("update", append(list(object = opts),
889 4
                                                        parseArgs("update",
890 4
                                                                  opts, ...))),
891 4
                        data = do.call("update", append(list(object =
892 4
                                                               object@data),
893 4
                                                        parseArgs("update",
894 4
                                                          object@data, ...))))
895
  # solve it
896 4
  if (solve) {
897
    # get any new specified GurobiOpts
898 0
    goLST <- parseArgs2(c("Threads", "MIPGap", "NumberSolutions", "TimeLimit",
899 0
                          "Presolve", "Method", "MultipleSolutionsMethod"), ...)
900
    # get old GurobiOpt
901 0
    if (inherits(object, "RapSolved")) {
902 0
      oldGoLST <- list(Threads = object@Threads, MIPGap = object@MIPGap,
903 0
                       NumberSolutions = object@NumberSolutions,
904 0
                       TimeLimit = object@TimeLimit,
905 0
                       Presolve = object@Presolve, Method = object@Method,
906 0
                       MultipleSolutionsMethod = object@MultipleSolutionsMethod)
907 0
      if (any(!names(oldGoLST %in% names(goLST)))) {
908 0
        goLST<-append(goLST, oldGoLST[!names(oldGoLST %in% names(goLST))])
909
      }
910
    }
911
    # generate new RapSolved object
912 0
    object <- do.call(raptr::solve,
913 0
                      append(append(list(a = object), goLST),
914 0
                             parseArgs2(c("verbose", "b"), ...)))
915
  }
916 4
  object
917
}
918

919
#' @rdname amount.target
920
#'
921
#' @method amount.target RapUnsolOrSol
922
#'
923
#' @export
924
amount.target.RapUnsolOrSol <- function(x, species = NULL) {
925 4
  amount.target.RapData(x@data, species)
926
}
927

928
#' @rdname space.target
929
#'
930
#' @method space.target RapUnsolOrSol
931
#'
932
#' @export
933
space.target.RapUnsolOrSol <- function(x, species = NULL, space = NULL) {
934 4
  space.target.RapData(x@data, species, space)
935
}
936

937
#' @rdname amount.target
938
#'
939
#' @method amount.target<- RapUnsolOrSol
940
#'
941
#' @export
942
`amount.target<-.RapUnsolOrSol` <- function(x,species = NULL, value) {
943 4
  x@data<-`amount.target<-.RapData`(x@data, species, value)
944 4
  x
945
}
946

947
#' @rdname space.target
948
#' @export
949
`space.target<-.RapUnsolOrSol`<-function(x, species = NULL, space = NULL,
950
                                         value) {
951 4
  x@data<-`space.target<-.RapData`(x@data, species, space, value)
952 4
  x
953
}
954

955
#' @rdname names
956
#'
957
#' @export
958
`names<-.RapUnsolOrSol` <- function(x, value) {
959 4
  x@data <- `names<-`(x@data, value)
960 4
  x
961
}
962

963
#' @rdname names
964
#'
965
#' @export
966
names.RapUnsolOrSol <- function(x) {
967 4
  names(x@data)
968
}
969

970
#' @rdname maximum.targets
971
#'
972
#' @export
973
maximum.targets.RapUnsolOrSol <- function(x, verbose = FALSE) {
974 4
  assertthat::assert_that(assertthat::is.flag(verbose))
975
  # generate model object
976 4
  model <- rcpp_generate_model_object(x@opts,
977 4
                                      inherits(x@opts, "RapUnreliableOpts"),
978 4
                                      x@data, verbose)
979
  # create data.frame
980 4
  retDF <- data.frame(species = rep(seq_along(x@data@species$name),
981 4
                                    each = length(x@data@attribute.spaces)),
982 4
                      target = rep(seq_along(x@data@attribute.spaces),
983 4
                                   length(x@data@species$name)),
984 4
                      proportion = c(dump_object(
985 4
                        model$cache$species_space_best_DBL, "numeric")))
986
  # merge with targets to get target names
987 4
  if ("name" %in% names(x@data@targets))
988 4
    retDF <- base::merge(retDF, x@data@targets[, c(1, 2, 4),drop = FALSE],
989 4
                         by = c("species", "target"), all = TRUE)
990
  # set amount-based targets to 1
991 4
  retDF[which(retDF$target == 0), "proportion"] <- 1
992
  # return object
993 4
  retDF
994
}

Read our documentation on viewing source code .

Loading