RapSolved.R

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

#' RapSolved: An S4 class to represent RAP inputs and outputs
#'
#' This class is used to store RAP input and output data in addition to input
#' parameters.
#'
#' @slot opts [RapReliableOpts()] or [RapUnreliableOpts()]
#'   object used to store input parameters.
#'
#' @slot solver [GurobiOpts()] or [ManualOpts()] object
#'   used to store solver information/parameters.
#'
#' @slot data [RapData()] object used to store input data.
#'
#' @slot results [RapResults()] object used to store results.
#'
#' @seealso [RapReliableOpts-class],
#'   [RapUnreliableOpts-class], [RapData-class],
#'   [RapResults-class].
#'
#' @name RapSolved-class
#'
#' @rdname RapSolved-class
#'
#' @exportClass RapSolved
methods::setClass("RapSolved", methods::representation(opts = "RapOpts",
                                                       solver = "SolverOpts",
                                                       data = "RapData",
                                                       results = "RapResults"))

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

#' Create new RapSolved object
#'
#' This function creates a [RapSolved()] object.
#'
#' @param unsolved [RapUnsolved()] object.
#'
#' @param solver [GurobiOpts()] or [ManualOpts()] object.
#'
#' @param results [RapResults()] object.
#'
#' @return [RapSolved()] object.
#'
#' @seealso [RapSolved-class], [RapResults-class],
#'   \code{link{solve}}.
#'
#' @export
RapSolved <- function(unsolved, solver, results) {
  methods::new("RapSolved", opts = unsolved@opts, solver = solver,
               data = unsolved@data, results = results)
}

#' @rdname solve
#'
#' @usage \S4method{solve}{RapUnsolOrSol,missing}(a, b, ..., verbose = FALSE)
#'
#' @name solve
#'
#' @aliases solve,RapUnsolOrSol,missing-method
methods::setMethod("solve",
  methods::representation(a = "RapUnsolOrSol", b = "missing"),
  function(a, b, ..., verbose = FALSE)
    solve(a, b = GurobiOpts(...), verbose))


#' @rdname solve
#'
#' @usage \S4method{solve}{RapUnsolOrSol,GurobiOpts}(a, b, verbose = FALSE)
#'
#' @name solve
#'
#' @aliases solve,RapUnsolOrSol,GurobiOpts-method
methods::setMethod("solve",
  methods::representation(a = "RapUnsolOrSol", b = "GurobiOpts"),
  function(a, b, verbose = FALSE) {
    ## init
    # run object checks
    if (!a@data@skipchecks) methods::validObject(a@data, test = FALSE)
    methods::validObject(a@opts, test = FALSE)
    # check that gurobi is installed
    if (!is.null(options()$GurobiInstalled))
        is.GurobiInstalled()
    if (!options()$GurobiInstalled$gurobi) {
      is.GurobiInstalled()
      if (!options()$GurobiInstalled$gurobi)
        stop(paste0("The Gurobi software package and the \"gurobi\" R package ",
                    "must be installed."))
    }
    # generate model object
    model <- rcpp_generate_model_object(a@opts,
                                        inherits(a@opts, "RapUnreliableOpts"),
                                        a@data, verbose)
    model$A <- Matrix::sparseMatrix(i = model$Ar$row + 1, j = model$Ar$col + 1,
                                    x = model$Ar$value,
                                    dims = c(max(model$Ar$row) + 1,
                                             length(model$obj)))
    # run basic checks that the model matrix has been constructed correctly
    assertthat::assert_that(
      sum(!is.finite(model$Ar$value)) == 0,
      msg = "Invalid model matrix constructed.")
    ## Initial run
    # run model
    log.pth <- tempfile(fileext = ".log")
    gparams <- append(as.list(b), list("LogFile" = log.pth))
    gparams$LogToConsole <- as.integer(verbose)
    if (b@MultipleSolutionsMethod == "benders.cuts") {
      igparams <- gparams
    } else {
      pool_mode <- as.numeric(
        gsub("solution.pool.", "",  b@MultipleSolutionsMethod,
       fixed = TRUE))
      igparams <- append(gparams, list(PoolSolutions = b@NumberSolutions,
                                       PoolSearchMode = pool_mode))
    }
    solution <- withr::with_locale(
      c(LC_CTYPE = "C"),
      gurobi::gurobi(model = model, params = igparams))
    if (file.exists("gurobi.log")) unlink("gurobi.log")
    # check solution object
    if (!is.null(solution$status))
      if (solution$status == "INFEASIBLE") {
        stop(paste0("No solution found because the problem cannot be solved ",
                    "because space-based targets are too high. Try setting ",
                    "lower space-based targets. See ?maximum.targets"))
      }
    if (is.null(solution$x)) {
      stop(paste0("No solution found because Gurobi parameters do not allow ",
                  "sufficient time."))
    }
    ## Subsequent runs if using Bender's cuts to obtain multiple solutions
    if (b@MultipleSolutionsMethod == "benders.cuts") {
      # store results
      results <- list(read.RapResults(a@opts, a@data, model,
                                      paste(readLines(log.pth),
                                            collapse = "\n"),
                                      solution, verbose))
      existing.solutions <- list(selections(results[[1]]))
      ## subsequent runs
      for (i in seq_len(b@NumberSolutions - 1)) {
        # create new model object, eacluding existing solutions as valid
        # solutions to ensure a different solution is obtained
        model <- rcpp_append_model_object(
          model, existing.solutions[length(existing.solutions)])
        model$A <- Matrix::sparseMatrix(i = model$Ar$row + 1,
                                        j = model$Ar$col + 1,
                                        x = model$Ar$value,
                                        dims = c(max(model$Ar$row) + 1,
                                                 length(model$obj)))
        # run model
        solution <- withr::with_locale(
          c(LC_CTYPE = "C"),
          gurobi::gurobi(model = model, params = gparams))
        if (file.exists("gurobi.log")) unlink("gurobi.log")
        # load results
        if (!is.null(solution$status))
          if (solution$status == "INFEASIBLE") {
            warning(paste0("only ", i, " solutions found"))
            break
          }
        if (is.null(solution$x)) {
          warning(paste0("only ", i, " solutions found"))
          break
        }
        # store results
        currResult <- read.RapResults(a@opts, a@data, model,
                                      paste(readLines(log.pth),
                                            collapse = "\n"), solution, verbose)
        results <- append(results, currResult)
        existing.solutions <- append(existing.solutions,
                                     list(selections(currResult)))
      }
    } else {
      # format results into a single list
      raw.results <- list(solution[c("x", "objval", "status", "runtime")])
      if (!is.null(solution$pool))
        raw.results <- append(raw.results,
          lapply(solution$pool, function(z)
            list(x = z$xn, objval = z$objval,
                 status = ifelse(abs(z$objval - raw.results[[1]]$objval) < 1e-10, "OPTIMAL", "SUBOPTIMAL"),
                 runtime = solution$runtime)))
      if (length(raw.results) > b@NumberSolutions)
        raw.results <- raw.results[seq_len(b@NumberSolutions)]
      # extract solutions
      results <- lapply(raw.results, function(z) {
        read.RapResults(a@opts, a@data, model,
                        paste(readLines(log.pth), collapse = "\n"),
                        z, verbose)
      })
    }
    # return RapSolved object
    RapSolved(unsolved = a, solver = b, results = mergeRapResults(results))
})

#' @rdname solve
#'
#' @usage \S4method{solve}{RapUnsolOrSol,matrix}(a, b, verbose = FALSE)
#'
#' @name solve
#'
#' @aliases solve,RapUnsolOrSol,matrix-method
methods::setMethod("solve",
  methods::representation(a = "RapUnsolOrSol", b = "matrix"),
  function(a, b, verbose = FALSE) {
    # check arguments for validity
    assertthat::assert_that(
      ncol(b) == nrow(a@data@pu),
      msg = "argument to b has different number of planning units to a")
    assertthat::assert_that(
      all(is.finite(b)),
      msg = "argument to b must not contain any NA values")
    assertthat::assert_that(
      all(b %in% c(0, 1)),
      msg = "argument to b must be binary selections when b is a matrix")
    # generate result objects
    model <- rcpp_generate_model_object(a@opts,
                                        inherits(a@opts, "RapUnreliableOpts"),
                                        a@data, verbose)
    results <- list()
    for (i in seq_len(nrow(b))) {
      # generate result object
      currResult <- read.RapResults(a@opts, a@data, model,
                                    "User specified solution",
                                     list(x = b[i, ], objval = NA,
                                          status = "MANUAL"), verbose)
      results <- append(results, currResult)
    }
    # return RapSolved object
    RapSolved(unsolved = a, solver = ManualOpts(NumberSolutions = nrow(b)),
              results = mergeRapResults(results))
})

#' @rdname solve
#'
#' @usage \S4method{solve}{RapUnsolOrSol,numeric}(a, b, verbose = FALSE)
#'
#' @name solve
#'
#' @aliases solve,RapUnsolOrSol,numeric-method
methods::setMethod("solve",
  methods::representation(a = "RapUnsolOrSol",  b = "numeric"),
  function(a, b, verbose = FALSE) {
    # check arguments for validity
    assertthat::assert_that(all(b %in% seq_len(nrow(a@data@pu))),
      msg = "argument to b refers to planning unit indices not in a")
    # return RapSolved object
    solve(a, b = matrix(replace(rep(0, nrow(a@data@pu)), b,
                                rep(1, length(b))), nrow = 1),
          verbose = verbose)
})

#' @rdname solve
#'
#' @usage \S4method{solve}{RapUnsolOrSol,logical}(a, b, verbose = FALSE)
#'
#' @name solve
#'
#' @aliases solve,RapUnsolOrSol,logical-method
methods::setMethod("solve",
  methods::representation(a = "RapUnsolOrSol", b = "logical"),
  function(a, b, verbose = FALSE) {
    # check arguments for validity
    assertthat::assert_that(
      length(b) == nrow(a@data@pu),
      msg = "argument to b has different number of planning units to a")
    # generate RapSolved object with user-specified solution
    solve(a, b = matrix(as.numeric(b), nrow = 1), verbose = verbose)
})

#' @rdname selections
#'
#' @export
selections.RapSolved <- function(x, y = 0) {
  selections.RapResults(x@results, y)
}

#' @rdname score
#'
#' @export
score.RapSolved <- function(x, y = 0) {
  score.RapResults(x@results, y)
}

#' @method summary RapSolved
#'
#' @export
summary.RapSolved <- function(object, ...) {
  summary.RapResults(object@results)
}

#' @export
#'
#' @rdname amount.held
amount.held.RapSolved <- function(x, y = 0, species = NULL) {
  # get solution numbers
  if (is.null(y))
    y <- seq_len(nrow(x@results@selections))
  if (all(y == 0))
    y <- x@results@best
  # get species numbers
  if (is.null(species))
    species <- seq_len(nrow(x@data@species))
  if (is.character(species))
    species <- match(species, x@data@species$name)
  # return named vector
  structure(x@results@amount.held[y, species],
            .Dim = c(length(y), length(species)),
            .Dimnames = list(seq_along(y),
                             x@data@species$name[species]))
}

#' @rdname space.held
#'
#' @export
space.held.RapSolved <- function(x, y = 0, species = NULL, space = NULL) {
  # get solution numbers
  if (is.null(y))
    y <- seq_len(nrow(x@results@selections))
  if (all(y == 0))
    y <- x@results@best
  # convert species to numeric
  if (is.character(species)) {
    species <- match(species, x@data@species[[1]])
    assertthat::assert_that(
      all(!is.na(species)),
      msg = "argument to species not found in argument to x")
  }
  # convert space to numeric
  if (is.character(space)) {
    space <- match(space, sapply(x@data@attribute.spaces, methods::slot,
                                 "name"))
    assertthat::assert_that(
      all(!is.na(space)),
      msg = "argument to species not found in argument to x")
  }
  # get species number
  if (is.null(species))
    species <- seq_len(nrow(x@data@species))
  # get space numbers
  if (is.null(space))
    space <- seq_along(x@data@attribute.spaces)
  # return named array
  as_ind <- rep(seq_along(x@data@attribute.spaces), nrow(x@data@species))
  sp_ind <- rep(seq_len(nrow(x@data@species)),
                each = length(x@data@attribute.spaces))
  structure(c(x@results@space.held[y, sp_ind %in% species & as_ind %in% space]),
            dim = c(length(y), length(species) * length(space)),
            dimnames = list(seq_along(y),
                            paste0(rep(x@data@species$name[species],
                                       each = length(space)),
                                   rep(paste0(" (Space ", space, ")"),
                                       length(species)))))
}

#' @rdname logging.file
#'
#' @export
logging.file.RapSolved <- function(x, y = 0) {
  logging.file.RapResults(x@results, y)
}

#' @method print RapSolved
#'
#' @rdname print
#'
#' @export
print.RapSolved <- function(x, ...) {
  message("RapSolved object\n")
  message("Parameters")
  print(x@opts, header = FALSE)
  message("Solver settings")
  print(x@solver, header = FALSE)
  message("Data")
  print.RapData(x@data, header = FALSE)
  message("Results")
  print.RapResults(x@results, header = FALSE)
  invisible()
}

#' @rdname spp.subset
#'
#' @method spp.subset RapUnsolOrSol
#'
#' @export
spp.subset.RapUnsolOrSol <- function(x, species) {
  RapUnsolved(opts = x@opts, data = spp.subset(x@data, species))
}

#' @rdname pu.subset
#'
#' @method pu.subset RapUnsolOrSol
#'
#' @export
pu.subset.RapUnsolOrSol <- function(x, pu) {
  RapUnsolved(opts = x@opts, data = pu.subset(x@data, pu))
}

#' @rdname dp.subset
#'
#' @method dp.subset RapUnsolOrSol
#'
#' @export
dp.subset.RapUnsolOrSol <- function(x, space, species, points) {
  RapUnsolved(opts = x@opts, data = dp.subset(x@data, space, species, points))
}

#' @rdname prob.subset
#'
#' @method prob.subset RapUnsolOrSol
#'
#' @export
prob.subset.RapUnsolOrSol <- function(x, species, threshold) {
  RapUnsolved(opts = x@opts, data = prob.subset(x@data, species, threshold))
}

#' @rdname show
#'
#' @usage \S4method{show}{RapSolved}(object)
#'
#' @name show
#'
#' @aliases show,RapSolved-method
methods::setMethod("show", "RapSolved",
                   function(object) print.RapSolved(object))

#' @rdname is.comparable
#'
#' @usage \S4method{is.comparable}{RapUnsolOrSol,RapUnsolOrSol}(x, y)
#'
#' @name is.comparable
#'
#' @aliases is.comparable,RapUnsolOrSol,RapUnsolOrSol-method
methods::setMethod("is.comparable",
  methods::signature(x = "RapUnsolOrSol", y = "RapUnsolOrSol"),
  function(x, y) is.comparable(x@data, y@data))

#' @rdname is.comparable
#'
#' @usage \S4method{is.comparable}{RapData,RapUnsolOrSol}(x, y)
#'
#' @name is.comparable
#'
#' @aliases is.comparable,RapData,RapUnsolOrSol-method
setMethod("is.comparable",
  methods::signature(x = "RapData", y = "RapUnsolOrSol"),
  function(x, y) is.comparable(x, y@data))

#' @rdname is.comparable
#'
#' @usage \S4method{is.comparable}{RapUnsolOrSol,RapData}(x, y)
#'
#' @name is.comparable
#'
#' @aliases is.comparable,RapUnsolOrSol,RapData-method
methods::setMethod("is.comparable",
  methods::signature(x = "RapUnsolOrSol", y = "RapData"),
  function(x, y) is.comparable(x@data, y))

#' @rdname basemap
#'
#' @export
basemap.RapSolved <- function(x, basemap = "none", grayscale = FALSE,
                              force.reset = FALSE) {
  basemap.RapData(x@data, basemap, grayscale, force.reset)
}

#' @rdname plot
#'
#' @usage \S4method{plot}{RapSolved,numeric}(x, y, basemap = "none",
#'  pu.color.palette = c("#e5f5f9", "#00441b", "#FFFF00", "#FF0000"), alpha =
#'  ifelse(basemap == "none", 1, 0.7), grayscale = FALSE, main = NULL,
#'  force.reset = FALSE)
#'
#' @name plot
#'
#' @aliases plot,RapSolved,numeric-method
methods::setMethod("plot",
  methods::signature(x = "RapSolved", y = "numeric"),
  function(x, y, basemap = "none",
           pu.color.palette = c("#e5f5f9", "#00441b", "#FFFF00", "#FF0000"),
           alpha = ifelse(basemap == "none", 1, 0.7),
           grayscale = FALSE, main = NULL, force.reset = FALSE) {
    # check for issues
    assertthat::assert_that(nrow(x@data@polygons) > 0,
                            assertthat::is.scalar(alpha),
                            isTRUE(alpha <= 1), isTRUE(alpha >= 0),
                            is.character(pu.color.palette),
                            length(pu.color.palette) == 4,
                            all(!is.na(pu.color.palette)),
                            assertthat::is.flag(grayscale),
                            assertthat::is.string(main) || is.null(main),
                            assertthat::is.flag(force.reset),
                            assertthat::is.count(y + 1),
                            y <= nrow(x@results@selections))
    # get basemap data
    if (basemap != "none")
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
    # main processing
    if (y == 0)
      y <- x@results@best
    values <- x@results@selections[y, ]
    cols <- character(length(values))
    cols[which(values == 0)] <- pu.color.palette[1]
    cols[which(values == 1)] <- pu.color.palette[2]
    cols[which(x@data@pu$status == 2)] <- pu.color.palette[3]
    cols[which(x@data@pu$status == 3)] <- pu.color.palette[4]
    # set title
    if (is.null(main)) {
      if (y == x@results@best) {
        main <- paste0("Best solution (", y, ")")
      } else {
        main <- paste0("Solution ", y)
      }
    }
    prettyGeoplot(x@data@polygons, cols, basemap, main = main,
                  categoricalLegend(pu.color.palette[c(4, 1, 2, 3)],
                                    c("Locked Out", "Not Selected",
                                      "Selected", "Locked In")),
                  beside = FALSE,
                  border = "gray30")
})

#' @rdname plot
#'
#' @usage \S4method{plot}{RapSolved,missing}(x, y, basemap = "none",
#' pu.color.palette = c("PuBu", "#FFFF00", "#FF0000"),
#' alpha = ifelse(basemap == "none", 1, 0.7),
#' grayscale = FALSE, main = NULL,
#' force.reset = FALSE)
#'
#' @name plot
#'
#' @aliases plot,RapSolved,missing-method
methods::setMethod("plot",
  methods::signature(x = "RapSolved", y = "missing"),
  function(x, y, basemap = "none",
           pu.color.palette = c("PuBu", "#FFFF00", "#FF0000"),
           alpha = ifelse(basemap == "none", 1, 0.7),
           grayscale = FALSE, main = NULL,
           force.reset = FALSE) {
    # check for issues
    basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
                                    "terrain", "hybrid", "mapmaker-roadmap",
                                    "mapmaker-hybrid"))
    assertthat::assert_that(nrow(x@data@polygons) > 0,
                            assertthat::is.string(basemap),
                            is.character(pu.color.palette),
                            length(pu.color.palette) == 3,
                            pu.color.palette[1] %in%
                              rownames(RColorBrewer::brewer.pal.info),
                            all(!is.na(pu.color.palette)),
                            assertthat::is.scalar(alpha),
                            isTRUE(alpha >= 0), isTRUE(alpha <= 1),
                            assertthat::is.flag(grayscale),
                            assertthat::is.string(main) || is.null(main),
                            assertthat::is.flag(force.reset))
    # get basemap data
    if (basemap != "none")
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
    # set title
    if (is.null(main)) {
      main <- "Selection frequencies (%)"
    }
    # main processing
    if (force.reset || !is.cached(x@results, "selectionfreqs")) {
      cache(x@results, "selectionfreqs", colMeans(x@results@selections))
    }
    values <- cache(x@results, "selectionfreqs")[which(x@data@pu$status < 2)]
    cols <- character(length(cache(x@results, "selectionfreqs")))
    cols[which(x@data@pu$status < 2)] <- brewerCols(
      scales::rescale(values, from = range(values), to = c(0, 1)),
      pal = pu.color.palette[1], alpha = alpha)
    cols[which(x@data@pu$status == 2)] <- pu.color.palette[2]
    cols[which(x@data@pu$status == 3)] <- pu.color.palette[3]
    # make plot
    prettyGeoplot(x@data@polygons, cols, basemap, main = main,
                  continuousLegend(values, pu.color.palette[1],
                                   posx = c(0.3, 0.4),posy = c(0.1, 0.9)),
                  beside = TRUE, border = "gray30")
})

#' @rdname plot
#'
#' @usage \S4method{plot}{RapSolved,RapSolved}(x, y, i = NULL, j = i,
#' basemap = "none",
#' pu.color.palette = ifelse(is.null(i), c("RdYlBu", "#FFFF00",
#' "#FF0000"), "Accent"),
#' alpha = ifelse(basemap == "none", 1, 0.7),
#' grayscale = FALSE, main = NULL, force.reset = FALSE)
#'
#' @name plot
#'
#' @aliases plot,RapSolved,RapSolved-method
methods::setMethod("plot",
  methods::signature(x = "RapSolved", y = "RapSolved"),
  function(x, y, i = NULL, j = i, basemap = "none",
           pu.color.palette = ifelse(is.null(i), c("RdYlBu", "#FFFF00",
                                                   "#FF0000"), "Accent"),
           alpha = ifelse(basemap == "none", 1, 0.7),
           grayscale = FALSE, main = NULL, force.reset = FALSE) {
    # check for issues
    basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
                                    "terrain", "hybrid", "mapmaker-roadmap",
                                    "mapmaker-hybrid"))
    assertthat::assert_that(nrow(x@data@polygons) > 0,
                            is.comparable(x, y),
                            assertthat::is.string(basemap),
                            is.character(pu.color.palette),
                            length(pu.color.palette) == 1 ||
                            length(pu.color.palette) == 3,
                            all(!is.na(pu.color.palette)),
                            pu.color.palette[1] %in%
                              rownames(RColorBrewer::brewer.pal.info),
                            assertthat::is.scalar(alpha),
                            isTRUE(alpha >= 0), isTRUE(alpha <= 1),
                            assertthat::is.flag(grayscale),
                            assertthat::is.string(main) || is.null(main),
                            assertthat::is.flag(force.reset))
    # get basemap data
    if (basemap != "none")
      basemap <- basemap.RapData(x@data, basemap, grayscale, force.reset)
    # main processing
    cols <- character(nrow(x@data@pu))
    if (is.null(i) || is.null(j)) {
      if (is.null(main)) main <- "Difference in selection frequencies (%)"
      cols[which(x@data@pu$status == 2)] <- pu.color.palette[2]
      cols[which(y@data@pu$status == 2)] <- pu.color.palette[2]
      cols[which(x@data@pu$status == 3)] <- pu.color.palette[3]
      cols[which(y@data@pu$status == 3)] <- pu.color.palette[3]

      if (force.reset || !is.cached(x@results, "selectionfreqs"))
        cache(x@results, "selectionfreqs", colMeans(x@results@selections))
      xsc <- cache(x@results, "selectionfreqs")[which(nchar(cols) == 0)]
      if (force.reset || !is.cached(y@results, "selectionfreqs"))
        cache(y@results, "selectionfreqs", colMeans(y@results@selections))
      ysc <- cache(y@results, "selectionfreqs")[which(nchar(cols) == 0)]
      values <- xsc - ysc
      col.pos <- which(nchar(cols) == 0)
      cols[col.pos] <- brewerCols(scales::rescale(values, to = c(0, 1)),
                                                  pu.color.palette[1], alpha)
      # determine legend function
      if (length(unique(round(values, 5))) > 1) {
        legend.fun <- continuousLegend(values, pu.color.palette[1],
                                       posx = c(0.3, 0.4),
                                       posy = c(0.1, 0.9),
                                       center = TRUE,
                                       endlabs = c("+X", "+Y"))
        beside <- TRUE
      } else {
        # create legend entries
        leg.cols <- c(cols[col.pos[1]])
        leg.labs <- c(values[1])
        if (any(x@data@pu$status == 2) | any(y@data@pu$status == 2)) {
          leg.cols <- c(leg.cols, pu.color.palette[2])
          leg.labs <- c(leg.labs, "Locked in")
        }
        if (any(x@data@pu$status == 3) | any(y@data@pu$status == 3)) {
          leg.cols <- c(leg.cols, pu.color.palette[3])
          leg.labs <- c(leg.labs, "Locked out")
        }
        # create legend function
        legend.fun <- categoricalLegend(leg.cols, leg.labs, ncol = 1)
        beside <- FALSE
      }
      prettyGeoplot(x@data@polygons, cols, basemap, main = main,
                    fun = legend.fun, beside = beside, border = "gray30")
    } else {
      if (i == 0)
        i <- x@results@best
      if (j == 0)
        j <- y@results@best
      cols2 <- brewerCols(seq(0, 1, length.out = 8), pu.color.palette, alpha,
                          n = 8)
      cols[which(x@results@selections[i, ] == 1 &
                 y@results@selections[j, ] == 0)] <- cols2[1]
      cols[which(x@results@selections[i, ] == 0 &
                 y@results@selections[j, ] == 1)] <- cols2[2]
      cols[which(x@results@selections[i, ] == 1 &
                 y@results@selections[j, ] == 1)] <- cols2[3]
      cols[which(x@results@selections[i, ] == 0 &
                 y@results@selections[j, ] == 0)] <- cols2[4]

      cols[which(x@data@pu$status == 2)] <- cols2[5]
      cols[which(y@data@pu$status == 2)] <- cols2[6]
      cols[which(x@data@pu$status == 3)] <- cols2[7]
      cols[which(y@data@pu$status == 3)] <- cols2[8]

      if (is.null(main)) {
        main <- paste0("Difference between solution ",
                       i, ifelse(i == x@results@best, " (best)", ""),
                       " and solution ", j,
                       ifelse(j == y@results@best, " (best)", ""))
      }

      prettyGeoplot(x@data@polygons, cols, basemap, main=main,
                    categoricalLegend(c(cols2), c("Selected in X",
                                                  "Selected in Y",
                                                  "Both", "Neither",
                                                  "Locked in X",
                                                  "Locked in Y",
                                                  "Locked out X",
                                                  "Locked out Y"), ncol = 4),
                    beside = FALSE)
    }
})

#' @rdname spp.plot
#'
#' @method spp.plot RapSolved
#'
#' @export
spp.plot.RapSolved<-function(x, species, y = 0, prob.color.palette = "YlGnBu",
                             pu.color.palette = c("#4D4D4D", "#00FF00",
                                                  "#FFFF00", "#FF0000"),
                             basemap = "none",
                             alpha = ifelse(basemap == "none", 1, 0.7),
                             grayscale = FALSE, main = NULL,
                             force.reset = FALSE, ...) {
  # data checks
  basemap <- match.arg(basemap, c("none", "roadmap", "mobile", "satellite",
                                  "terrain", "hybrid", "mapmaker-roadmap",
                                  "mapmaker-hybrid"))
  assertthat::assert_that(nrow(x@data@polygons) > 0,
                          assertthat::is.count(y + 1),
                          y %in% seq(0, nrow(x@results@selections)),
                          assertthat::is.count(species) ||
                            assertthat::is.string(species),
                          assertthat::is.string(basemap),
                          is.character(pu.color.palette),
                          length(pu.color.palette) %in% c(1, 4),
                          all(!is.na(pu.color.palette)),
                          assertthat::is.scalar(alpha),
                          isTRUE(alpha >= 0), isTRUE(alpha <= 1),
                          assertthat::is.flag(grayscale),
                          assertthat::is.string(main) || is.null(main),
                          assertthat::is.flag(force.reset))
  if (is.character(species)) {
    spp_pos <- match(species, x@data@species$name)
    assertthat::assert_that(
      !is.na(spp_pos),
      msg = "argument to species is not a species name in argument to x")
  } else {
    if (is.numeric(species)) {
      assertthat::assert_that(
        species %in% seq_along(x@data@species$name),
        msg = paste0("argument to species is not a valid index for species ",
                     "in argument to x"))
      spp_pos <- species
    }
  }
  # set title
  if (is.null(main)) {
    if ("name" %in% names(x@data@species) & is.numeric(species)) {
      main <- paste0(x@data@species$name[species])
    } else if (is.numeric(species)) {
      main <- paste0("Species ", species)
    } else {
      main <- paste0(species)
    }
  }
  # get basemap
  if (basemap != "none")
    basemap <- basemap.RapData(x, basemap, grayscale, force.reset)
  ## main processing
  # extract planning fill unit colors
  values <- numeric(nrow(x@data@pu))
  rows <- which(x@data@pu.species.probabilities$species == spp_pos)
  values[x@data@pu.species.probabilities$pu[rows]] <-
    x@data@pu.species.probabilities$value[rows]
  if (length(unique(values)) > 1) {
    cols <- brewerCols(scales::rescale(values, to = c(0,1)),
                       prob.color.palette, alpha)
  } else {
    cols <- brewerCols(rep(values[1], length(values)), prob.color.palette,
                       alpha)
    values <- c(0, values[1])
  }
  # get selected rows
  sel.pu.ids <- which(as.logical(selections(x, y)))
  unsel.pu.ids <- which(!as.logical(selections(x, y)))
  # extract planning unit border colors
  border.cols <- rep(pu.color.palette[1], nrow(x@data@pu))
  border.cols[sel.pu.ids] <- pu.color.palette[2]
  border.cols[which(x@data@pu$status == 2)] <- pu.color.palette[3]
  border.cols[which(x@data@pu$status == 3)] <- pu.color.palette[4]
  # make plot
  prettyGeoplot(list(x@data@polygons[x@data@polygons$PID %in% unsel.pu.ids, ],
                     x@data@polygons[x@data@polygons$PID %in% sel.pu.ids, ]),
                list(cols[unsel.pu.ids], cols[sel.pu.ids]),
                basemap, main,
                continuousLegend(values, prob.color.palette,
                                 posx = c(0.3, 0.4),posy = c(0.1, 0.9)),
                beside = TRUE, border = list(border.cols[unsel.pu.ids],
                                             border.cols[sel.pu.ids]),
                lwd = list(1, 5))
}

#' @rdname space.plot
#'
#' @method space.plot RapSolved
#'
#' @export
space.plot.RapSolved <- function(x, species, space = 1, y = 0,
                                 pu.color.palette = c("#4D4D4D4D", "#00FF0080",
                                                      "#FFFF0080", "#FF00004D"),
                                 main = NULL, ...) {
  # data checks
  assertthat::assert_that(assertthat::is.count(species) ||
                            assertthat::is.string(species),
                          assertthat::is.count(space),
                          assertthat::is.count(y + 1),
                          y %in% seq(0, nrow(x@results@selections)),
                          is.character(pu.color.palette),
                          length(pu.color.palette) %in% c(1, 4),
                          all(!is.na(pu.color.palette)),
                          assertthat::is.string(main) || is.null(main))
  if (is.character(species)) {
    spp_pos <- match(species, x@data@species$name)
    assertthat::assert_that(
      !is.na(spp_pos),
      msg = "argument to species is not a species name in argument to x")
  } else{
    if (is.numeric(species)) {
      assertthat::assert_that(
        species %in% seq_along(x@data@species$name),
        msg = paste0("argument to species is not a valid index for species ",
                     "in argument to x"))
      spp_pos <- species
    }
  }
  # set title
  if (is.null(main)) {
    if ("name" %in% names(x@data@species) & is.numeric(species)) {
      main <- paste0(x@data@species$name[species], " in space ", space)
    } else if (is.numeric(species)) {
      main <- paste0("Species ", species, " in space ", space)
    } else {
      main<-paste0(species, " in space ", space)
    }
  }
  # extract pu data
  pu <- as.data.frame(x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
                      planning.unit.points@coords)
  names(pu) <- paste0("X", seq_len(ncol(pu)))
  pu_ids <- x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
              planning.unit.points@ids
  pu$status <- "Not Selected"
  pu$status[as.logical(selections(x, y)[pu_ids])] <- "Selected"
  pu$status[which(x@data@pu$status[pu_ids] == 2)] <- "Locked In"
  pu$status[which(x@data@pu$status[pu_ids] == 3)] <- "Locked Out"
  # extract dp data
  dp <- as.data.frame(x@data@attribute.spaces[[space]]@
                        spaces[[spp_pos]]@demand.points@coords)
  names(dp) <- paste0("X",seq_len(ncol(dp)))
  dp$weights <- x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
                  demand.points@weights
  # make plots
  n_dim <- ncol(x@data@attribute.spaces[[space]]@spaces[[spp_pos]]@
                  planning.unit.points@coords)
  do.call(paste0("spacePlot.", n_dim, 'd' ),
          list(pu, dp, pu.color.palette, main))
}

#' @rdname update
#'
#' @method update RapUnsolOrSol
#'
#' @export
update.RapUnsolOrSol <- function(object, ..., formulation  =NULL,
                                 solve = TRUE) {
  assertthat::assert_that(is.null(formulation) ||
                            assertthat::is.string(formulation),
                          assertthat::is.flag(solve))
  # update formulation
  opts <- object@opts
  if (!is.null(formulation)) {
    match.arg(formulation, c("unreliable", "reliable"))
    # create new opts object
    if (formulation == "unreliable") {
      opts <- RapUnreliableOpts()
    } else {
      opts <- RapReliableOpts()
    }
    # fill in matching slots
    for (i in methods::slotNames(object@opts)) {
      if (i %in% methods::slotNames(opts))
        methods::slot(opts, i) <- methods::slot(object@opts, i)
    }
  }
  # return updated object
  object <- RapUnsolved(opts = do.call("update", append(list(object = opts),
                                                        parseArgs("update",
                                                                  opts, ...))),
                        data = do.call("update", append(list(object =
                                                               object@data),
                                                        parseArgs("update",
                                                          object@data, ...))))
  # solve it
  if (solve) {
    # get any new specified GurobiOpts
    goLST <- parseArgs2(c("Threads", "MIPGap", "NumberSolutions", "TimeLimit",
                          "Presolve", "Method", "MultipleSolutionsMethod"), ...)
    # get old GurobiOpt
    if (inherits(object, "RapSolved")) {
      oldGoLST <- list(Threads = object@Threads, MIPGap = object@MIPGap,
                       NumberSolutions = object@NumberSolutions,
                       TimeLimit = object@TimeLimit,
                       Presolve = object@Presolve, Method = object@Method,
                       MultipleSolutionsMethod = object@MultipleSolutionsMethod)
      if (any(!names(oldGoLST %in% names(goLST)))) {
        goLST<-append(goLST, oldGoLST[!names(oldGoLST %in% names(goLST))])
      }
    }
    # generate new RapSolved object
    object <- do.call(raptr::solve,
                      append(append(list(a = object), goLST),
                             parseArgs2(c("verbose", "b"), ...)))
  }
  object
}

#' @rdname amount.target
#'
#' @method amount.target RapUnsolOrSol
#'
#' @export
amount.target.RapUnsolOrSol <- function(x, species = NULL) {
  amount.target.RapData(x@data, species)
}

#' @rdname space.target
#'
#' @method space.target RapUnsolOrSol
#'
#' @export
space.target.RapUnsolOrSol <- function(x, species = NULL, space = NULL) {
  space.target.RapData(x@data, species, space)
}

#' @rdname amount.target
#'
#' @method amount.target<- RapUnsolOrSol
#'
#' @export
`amount.target<-.RapUnsolOrSol` <- function(x,species = NULL, value) {
  x@data<-`amount.target<-.RapData`(x@data, species, value)
  x
}

#' @rdname space.target
#' @export
`space.target<-.RapUnsolOrSol`<-function(x, species = NULL, space = NULL,
                                         value) {
  x@data<-`space.target<-.RapData`(x@data, species, space, value)
  x
}

#' @rdname names
#'
#' @export
`names<-.RapUnsolOrSol` <- function(x, value) {
  x@data <- `names<-`(x@data, value)
  x
}

#' @rdname names
#'
#' @export
names.RapUnsolOrSol <- function(x) {
  names(x@data)
}

#' @rdname maximum.targets
#'
#' @export
maximum.targets.RapUnsolOrSol <- function(x, verbose = FALSE) {
  assertthat::assert_that(assertthat::is.flag(verbose))
  # generate model object
  model <- rcpp_generate_model_object(x@opts,
                                      inherits(x@opts, "RapUnreliableOpts"),
                                      x@data, verbose)
  # create data.frame
  retDF <- data.frame(species = rep(seq_along(x@data@species$name),
                                    each = length(x@data@attribute.spaces)),
                      target = rep(seq_along(x@data@attribute.spaces),
                                   length(x@data@species$name)),
                      proportion = c(dump_object(
                        model$cache$species_space_best_DBL, "numeric")))
  # merge with targets to get target names
  if ("name" %in% names(x@data@targets))
    retDF <- base::merge(retDF, x@data@targets[, c(1, 2, 4),drop = FALSE],
                         by = c("species", "target"), all = TRUE)
  # set amount-based targets to 1
  retDF[which(retDF$target == 0), "proportion"] <- 1
  # return object
  retDF
}