plotting-helpers.R

### deal with spurious data.table warnings
if (getRversion() >= "3.1.0") {
  utils::globalVariables(c(".", ".N"))
}

################################################################################
#' Find the number of layers in a Spatial Object
#'
#' There are already methods for \code{Raster*} in the raster package.
#' Adding methods for \code{list}, \code{SpatialPolygons}, \code{SpatialLines},
#' and \code{SpatialPoints}, \code{gg}, \code{histogram}, \code{igraph}.
#' These latter classes return \code{1}.
#'
#' @param x A \code{.quickPlotObjects} object or list of these.
#'
#' @return The number of layers in the object.
#'
#' @author Eliot McIntire
#' @export
#' @include plotting-classes.R
#' @rdname numLayers
#'
#' @examples
#' library(igraph)
#' library(raster)
#'
#' files <- system.file("maps", package = "quickPlot") %>%
#'   dir(., full.names = TRUE, pattern = "tif")
#' maps <- lapply(files, function(x) raster(x))
#' names(maps) <- sapply(basename(files), function(x) {
#'   strsplit(x, split = "\\.")[[1]][1]
#' })
#' stck <- stack(maps)
#'
#' numLayers(maps)
#' numLayers(stck)
#'
setGeneric("numLayers", function(x) standardGeneric("numLayers"))

#' @export
#' @rdname numLayers
setMethod(
  "numLayers",
  signature = "list",
  definition = function(x) {
    sum(unlist(lapply(x, function(x) {
      if (inherits(x, "RasterStack")) {
        numLayers(x)
      } else {
        1L
      }
    })))
})

#' @rdname numLayers
setMethod(
  "numLayers",
  signature = ".quickPlot",
  definition = function(x) {
    return(length(x@arr@extents))
})

#' @export
#' @importFrom raster nlayers
#' @rdname numLayers
setMethod(
  "numLayers",
  signature = "Raster",
  definition = function(x) {
    return(nlayers(x))
})

#' @export
#' @rdname numLayers
setMethod(
  "numLayers",
  signature = "Spatial",
  definition = function(x) {
    return(1L)
})

#' @export
#' @rdname numLayers
setMethod(
  "numLayers",
  signature = "ANY",
  definition = function(x) {
    return(1L)
})

################################################################################
#' Extract the layer names of Spatial Objects
#'
#' There are already methods for \code{Raster*} objects. This adds methods for
#' \code{SpatialPoints*}, \code{SpatialLines*}, and \code{SpatialPolygons*},
#' returning an empty character vector of length 1.
#' This function was created to give consistent, meaningful results for all
#' classes of objects plotted by \code{Plot}.
#'
#' @param object  A \code{Raster*}, \code{SpatialPoints*}, \code{SpatialLines*},
#'                or \code{SpatialPolygons*} object; or list of these.
#'
#' @author Eliot McIntire
#' @export
#' @include plotting-classes.R
#' @rdname layerNames
#'
#' @examples
#' library(igraph)
#' library(raster)
#'
#' ## RasterLayer objects
#' files <- system.file("maps", package = "quickPlot") %>%
#'   dir(., full.names = TRUE, pattern = "tif")
#' maps <- lapply(files, function(x) raster(x))
#' names(maps) <- sapply(basename(files), function(x) {
#'   strsplit(x, split = "\\.")[[1]][1]
#' })
#' layerNames(maps)
#'
#' ## Spatial* objects
#' caribou <- SpatialPoints(coords = cbind(x = stats::runif(1e2, -50, 50),
#'                                         y = stats::runif(1e2, -50, 50)))
#' layerNames(caribou)
#'
#' sr1 <- Polygon(cbind(c(2, 4, 4, 1, 2), c(2, 3, 5, 4, 2)) * 20 - 50)
#' sr2 <- Polygon(cbind(c(5, 4, 2, 5), c(2, 3, 2, 2)) * 20 - 50)
#' srs1 <- Polygons(list(sr1), "s1")
#' srs2 <- Polygons(list(sr2), "s2")
#' spP <- SpatialPolygons(list(srs1, srs2), 1:2)
#' layerNames(spP)
#'
#' l1 <- cbind(c(10, 2, 30), c(30, 2, 2))
#' l1a <- cbind(l1[, 1] + .05, l1[, 2] + .05)
#' l2 <- cbind(c(1, 20, 3), c(10, 1.5, 1))
#' sl1 <- Line(l1)
#' sl1a <- Line(l1a)
#' sl2 <- Line(l2)
#' s1 <- Lines(list(sl1, sl1a), ID = "a")
#' s2 <- Lines(list(sl2), ID = "b")
#' sl <- SpatialLines(list(s1, s2))
#' layerNames(sl)
#'
setGeneric("layerNames", function(object) {
  standardGeneric("layerNames")
})

#' @export
#' @rdname layerNames
setMethod(
  "layerNames",
  signature = "list",
  definition = function(object) {
    unlist(lapply(object, layerNames))
})

#' @export
#' @rdname layerNames
setMethod(
  "layerNames",
  signature = "ANY",
  definition = function(object) {
    return("")
})

#' @export
#' @rdname layerNames
setMethod(
  "layerNames",
  signature = "Raster",
  definition = function(object) {
    names(object)
})

#' @rdname layerNames
setMethod(
  "layerNames",
  signature = ".quickPlot",
  definition = function(object) {
    return(unlist(lapply(object@quickPlotGrobList, function(x) {
      unlist(lapply(x, function(y) y@plotName))[[1]]
    })))
})

#' @export
#' @rdname layerNames
setMethod(
  "layerNames",
  signature = "igraph",
  definition = function(object) {
    return("")
})

################################################################################
#' Assess whether a list of extents are all equal
#'
#' @param extents list of extents objects
#'
#' @author Eliot McIntire
#' @export
#' @rdname equalExtent
#'
#' @examples
#' library(igraph)
#' library(raster)
#'
#' files <- system.file("maps", package = "quickPlot") %>%
#'   dir(., full.names = TRUE, pattern = "tif")
#' maps <- lapply(files, function(x) raster(x))
#' names(maps) <- sapply(basename(files), function(x) {
#'   strsplit(x, split = "\\.")[[1]][1]
#' })
#' extnts <- lapply(maps, extent)
#' equalExtent(extnts) ## TRUE
#'
setGeneric("equalExtent", function(extents) {
  standardGeneric("equalExtent")
})

#' @export
#' @rdname equalExtent
setMethod(
  "equalExtent",
  signature = "list",
  definition = function(extents) {
    all(
      c(
        sapply(extents, function(x) x@xmin) == extents[[1]]@xmin,
        sapply(extents, function(x) x@xmax) == extents[[1]]@xmax,
        sapply(extents, function(x) x@ymin) == extents[[1]]@ymin,
        sapply(extents, function(x) x@ymax) == extents[[1]]@ymax
      )
    )
})

################################################################################
#' Make a \code{.quickPlot} class object
#'
#' Builds a \code{.quickPlot} object from a list of objects.
#'
#' @param plotObjects list. Any plot objects.
#'
#' @param plotArgs list. Any arguments that the the grid package can accept for
#' the specific grob types, e.g., rasterGrob, polygonGrob, etc.
#'
#' @param whichQuickPlottables  Logical indicating which objects in the
#' \code{Plot} call can be plotted by \code{Plot}.
#'
#' @param ... additional arguments. Currently nothing.
#'
#' @return A \code{\link{.quickPlot}} object, which has 2 slots, one for the plot arrangement
#' (i.e., layout and dimensions) and one for all of the \code{quickPlotGrobs}
#' (stored as a quickPlotGrobList of lists \code{.quickPlotGrob} objects).
#'
#' @author Eliot McIntire
#' @export
#' @include plotting-classes.R
#' @include plotting-helpers.R
#' @keywords internal
#' @rdname makeQuickPlot
#'
setGeneric(".makeQuickPlot", function(plotObjects, plotArgs, whichQuickPlottables, ...) {
  standardGeneric(".makeQuickPlot")
})

#' @export
#' @rdname makeQuickPlot
setMethod(
  ".makeQuickPlot",
  signature = c(plotObjects = "list", plotArgs = "list"),
  definition = function(plotObjects, plotArgs, whichQuickPlottables, ...) {

    isSpatialObjects <- unlist(lapply(plotObjects, function(x) {
      inherits(x, "spatialObjects")
    }))

    env <- list(...)$env
    suppliedNames <- names(plotObjects)
    if (any(!nzchar(suppliedNames, keepNA = TRUE))) {
      suppliedNames <- NULL
    }
    if (is.null(suppliedNames)) {
      objs <- .objectNames()[whichQuickPlottables]
    } else {
      objs <- lapply(suppliedNames, function(x) {
        list(objs = x, envs = env)
      })
    }

    names(plotObjects) <- unlist(lapply(objs, function(x)
      x$objs))

    if (!is.null(suppliedNames)) {
      if (all(unlist(lapply(suppliedNames, nzchar, keepNA = TRUE)))) {
        names(plotObjects)[!is.na(suppliedNames)] <- suppliedNames
      }
    }
    numberLayers <- pmax(1, unlist(lapply(plotObjects, numLayers)))

    lNamesPlotObj <- layerNames(plotObjects)

    isQuickPlot <- unlist(lapply(plotObjects, function(x) inherits(x, ".quickPlot")))

    # The second component will test for a 3 dimensional array
    isStack <- unlist(lapply(plotObjects, function(x)
      inherits(x, "RasterStack") | isTRUE(dim(x)[3] > 1)))

    # Stacks are like lists in that they are a single object, with many
    # layers.  Plot must treat these as any other layers, except that
    # they are stored in single objects. The following set of objects
    # are the "long" versions of the layers, i.e,. a call to say
    # Plot(stack1, layerB) would have two objects, but maybe 5 layers,
    # if the stack had 4 layers in it.
    isQuickPlotLong <- rep(isQuickPlot, numberLayers)
    isStackLong <- rep(isStack, numberLayers)
    isSpatialObjects <- rep(isSpatialObjects, numberLayers)

    lN <- rep(names(plotObjects), numberLayers)
    lN[isQuickPlotLong] <- layerNames(plotObjects[isQuickPlot])
    objectNamesLong <- rep(names(plotObjects), numberLayers)

    # Full layer names, including object name.
    # If layer name is same as object name omit it, and if layer name
    # is "layer", omit it if within a RasterLayer
    lN[isStackLong] <- paste(objectNamesLong[isStackLong],
                             lNamesPlotObj[isStackLong],
                             sep = "$")
    names(lN) <- rep(names(plotObjects), numberLayers)
    names(lN)[isQuickPlotLong] <- layerNames(plotObjects)[isQuickPlotLong]

    # Create long version of environments
    lEnvs <- rep(unlist(lapply(objs, function(x) x$envs)), numberLayers)

    plotArgs <- .makeList(plotArgs, length(lN))

    # Make new .quickPlot object.
    # This will be merged to existing later.
    newPlots <- new(".quickPlot")

    newPlots@arr <- new(".arrangement")

    newPlots@quickPlotGrobList <- lapply(1:length(lN), function(x) {
      quickPlotGrobList <- list()

      if (isQuickPlotLong[x]) {
        quickPlotGrobList[[lN[x]]] <-
          plotObjects[[match(
            names(isQuickPlotLong)[x],
            names(plotObjects)
          )]]@quickPlotGrobList[[match(
            lN[x], lNamesPlotObj[isQuickPlotLong]
          )]][[1]]
      } else {
        quickPlotGrobList[[lN[x]]] <- new(".quickPlotGrob")
        quickPlotGrobList[[lN[x]]]@plotArgs <- lapply(plotArgs, function(y) y[[x]])
        quickPlotGrobList[[lN[x]]]@plotArgs$gpText <- plotArgs$gpText[x]
        quickPlotGrobList[[lN[x]]]@plotArgs$gpAxis <- plotArgs$gpAxis[x]
        quickPlotGrobList[[lN[x]]]@plotArgs$gp <- plotArgs$gp[x]
        quickPlotGrobList[[lN[x]]]@plotName <- lN[x]
        quickPlotGrobList[[lN[x]]]@objName <- objectNamesLong[x]
        quickPlotGrobList[[lN[x]]]@envir <- lEnvs[[x]]
        quickPlotGrobList[[lN[x]]]@layerName <- lNamesPlotObj[x]
        quickPlotGrobList[[lN[x]]]@objClass <- class(
          eval(parse(text = objectNamesLong[x]), lEnvs[[x]])
        )
        quickPlotGrobList[[lN[x]]]@isSpatialObjects <- isSpatialObjects[x]
      }
      return(quickPlotGrobList)
    })

    names(newPlots@quickPlotGrobList) <- lN
    return(newPlots)
})

#' @rdname makeQuickPlot
setMethod(
  ".makeQuickPlot",
  signature = c(plotObjects = "list", plotArgs = "missing"),
  definition = function(plotObjects, ...) {
    plotArgs <- formals("Plot")[-1]
    newPlots <- .makeQuickPlot(plotObjects, plotArgs, ...)
    return(newPlots)
})

#' @rdname makeQuickPlot
setMethod(
  ".makeQuickPlot",
  signature = c(plotObjects = "missing", plotArgs = "missing"),
  definition = function(...) {
    newPlots <- new(".quickPlot")
    newPlots@quickPlotGrobList <- lapply(1:1, function(x) {
      quickPlotGrobList <- list()
      quickPlotGrobList[[1]] <- new(".quickPlotGrob")
      return(quickPlotGrobList)
    })
    return(newPlots)
})

################################################################################
#' Convert \code{plotArgs} to list of lists
#'
#' Internal function. Take the inputs as plotArgs to the Plot function, and make
#' them a list of length \code{numQuickPlotObjects} entries of lists.
#'
#' @inheritParams .makeQuickPlot
#'
#' @param numQuickPlotObjects Numeric. The number of \code{.quickPlotObjects}.
#'                 This can't easily be deduced from the \code{plotArgs} because
#'                 of the \code{RasterStack}s. So passed manually.
#'
#' @author Eliot McIntire
#' @include plotting-classes.R
#' @keywords internal
#' @rdname makeList
#'
setGeneric(".makeList", function(plotArgs, numQuickPlotObjects) {
  standardGeneric(".makeList")
})

#' @rdname makeList
setMethod(
  ".makeList",
  signature = c("list"),
  definition = function(plotArgs, numQuickPlotObjects) {
    p <- plotArgs
    n <- numQuickPlotObjects

    p$new <- if (is.list(p$new)) {
      if (length(p$new) != n) {
        rep(p$new, length.out = n)
      } else {
        p$new
      }
    } else {
      if (length(p$new) == n) {
        as.list(p$new)
      } else {
        rep(list(p$new), length.out = n)
      }
    }

    # character or logical or numeric of length 1 per entry
    p$addTo <- if (is.list(p$addTo)) {
      if (length(p$addTo) != n) {
        rep(p$addTo, length.out = n)
      } else {
        p$addTo
      }
    } else {
      if (length(p$addTo) == n) {
        as.list(p$addTo)
      } else {
        rep(list(p$addTo), length.out = n)
      }
    }

    p$gp <- if (inherits(p$gp, "gpar")) {
      rep(list(p$gp), n)
    } else {
      if (is.list(p$gp)) {
        rep(p$gp, n)
      }
    }

    p$gpText <- if (inherits(p$gpText, "gpar")) {
      rep(list(p$gpText), n)
    } else {
      if (is.list(p$gpText)) {
        rep(p$gpText, n)
      }
    }

    p$gpAxis <- if (inherits(p$gpAxis, "gpar")) {
      rep(list(p$gpAxis), n)
    } else {
      if (is.list(p$gpAxis)) {
        rep(p$gpAxis, n)
      }
    }

    p$axes <- if (is.list(p$axes)) {
      if (length(p$axes) != n) {
        rep(p$axes, length.out = n)
      } else {
        p$axes
      }
    } else {
      if (length(p$axes) == n) {
        as.list(p$axes)
      } else {
        rep(list(p$axes), length.out = n)
      }
    }

    p$speedup <- if (is.list(p$speedup)) {
      if (length(p$speedup) != n) {
        rep(p$speedup, length.out = n)
      }
      else {
        p$speedup
      }
    } else {
      if (length(p$speedup) == n) {
        as.list(p$speedup)
      } else {
        rep(list(p$speedup), length.out = n)
      }
    }

    p$size <- if (is.list(p$size)) {
      if (length(p$size) != n) {
        rep(p$size, length.out = n)
      } else {
        p$size
      }
    } else {
      if (length(p$size) == n) {
        as.list(p$size)
      } else {
        rep(list(p$size), length.out = n)
      }
    }

    p$visualSqueeze <- if (is.list(p$visualSqueeze)) {
      if (length(p$visualSqueeze) != n) {
        rep(p$visualSqueeze, length.out = n)
      } else {
        p$visualSqueeze
      }
    } else {
      if (length(p$visualSqueeze) == n) {
        as.list(p$visualSqueeze)
      } else {
        rep(list(p$visualSqueeze), length.out = n)
      }
    }

    p$legend <- if (is.list(p$legend)) {
      if (length(p$legend) != n) {
        rep(p$legend, length.out = n)
      } else {
        p$legend
      }
    } else {
      if (length(p$legend) == n) {
        as.list(p$legend)
      } else {
        rep(list(p$legend), length.out = n)
      }
    }

    p$pch <- if (is.list(p$pch)) {
      if (length(p$pch) != n) {
        rep(p$pch, length.out = n)
      } else {
        p$pch
      }
    } else {
      if (length(p$pch) == n) {
        as.list(p$pch)
      } else {
        rep(list(p$pch), length.out = n)
      }
    }

    p$title <- if (is.list(p$title)) {
      if (length(p$title) != n) {
        rep(p$title, length.out = n)
      } else {
        p$title
      }
    } else {
      if (length(p$title) == n) {
        as.list(p$title)
      } else {
        rep(list(p$title), length.out = n)
      }
    }

    p$na.color <- if (is.list(p$na.color)) { # nolint
      if (length(p$na.color) != n) {
        rep(p$na.color, length.out = n)
      } else {
        p$na.color
      }
    } else {
      if (length(p$na.color) == n) {
        as.list(p$na.color)
      } else {
        rep(list(p$na.color), length.out = n)
      }
    }

    p$zero.color <- if (is.list(p$zero.color)) { # nolint
      if (length(p$zero.color) != n) {
        rep(p$zero.color, length.out = n)
      } else {
        p$zero.color
      }
    } else {
      if (length(p$zero.color) == n) {
        as.list(p$zero.color)
      } else {
        rep(list(p$zero.color), length.out = n)
      }
    }

    p$cols <- if (is.list(p$cols)) {
      p$cols
    } else {
      rep(list(p$cols), length.out = n)
    }

    p$zoomExtent <- if (is.list(p$zoomExtent)) {
      p$zoomExtent
    } else {
      rep(list(p$zoomExtent), length.out = n)
    }

    p$legendText <- if (is.list(p$legendText)) {
      p$legendText
    } else {
      rep(list(p$legendText), length.out = n)
    }

    p$legendRange <- if (is.list(p$legendRange)) {
      p$legendRange
    } else {
      rep(list(p$legendRange), length.out = n)
    }

    p$plotFn <- if (is.list(p$plotFn)) {
      p$plotFn
    } else {
      rep(list(p$plotFn), length.out = n)
    }

    return(p)
})

################################################################################
#' Make \code{SpatialLines} object from two \code{SpatialPoints} objects
#'
#' The primary conceived usage of this is to draw arrows following the
#' trajectories of agents.
#'
#' @param from  Starting spatial coordinates (\code{SpatialPointsDataFrame}).
#'
#' @param to    Ending spatial coordinates (\code{SpatialPointsDataFrame}).
#'
#' @return A \code{SpatialLines} object. When this object is used within a
#'         \code{Plot} call and the \code{length} argument is specified, then
#'         arrow heads will be drawn. See examples.
#'
#' @author Eliot McIntire
#' @export
#' @include plotting-classes.R
#' @importFrom raster crs
#' @importFrom sp coordinates Line Lines SpatialLines
#' @rdname makeLines
#'
#' @example inst/examples/example_makeLines.R
#'
setGeneric("makeLines", function(from, to) {
  standardGeneric("makeLines")
})

#' @export
#' @rdname makeLines
setMethod(
  "makeLines",
  signature = c("SpatialPoints", "SpatialPoints"),
  definition = function(from, to) {
    SpatialLines(lapply(seq_len(length(from)), function(x) {
      Lines(list(Line(
        coords = rbind(coordinates(from)[x, ], coordinates(to)[x, ])
      )), ID = x)
    }), proj4string = crs(from)) # nolint
})

################################################################################
#' Parse arguments and find environments
#'
#' Internal function used within objectNames.
#'
#' @param y  A character representation of the arguments passed to a function,
#'           e.g., \code{Plot}.
#'
#' @param e  Environment in which the function (e.g., \code{Plot}) was called.
#'
#' @param eminus1  The parent environment of \code{e}.
#'
#' @return A list of length 2, with names \code{objs} and \code{envs} giving the
#' standardized representation (i.e., replacing \code{[[]]} with \code{$}
#' notation for objects) of objects and their layers (if \code{RasterStacks}).
#'
#' @importFrom grDevices dev.cur
#' @include plotting-classes.R
#' @keywords internal
#' @rdname parseArgs
#' @author Eliot McIntire and Alex Chubaty
#'
# igraph exports %>% from magrittr
.parseArgs <- function(y, e, eminus1) {
  elems <- list()
  i <- 1
  parseTxt <- parse(text = y)[[1]]
  elems[[i]] <- parseTxt
  lastOneDone <- TRUE

  while (length(parse(text = deparse(parseTxt))[[1]]) != 1) {
    if (length(parseTxt) == 2) {
      stop("Please pass an object directly, or use get(x, envir = envName) or ",
           "eval(x, envir = envName). ",
           "Plot can not yet accept functions or complex objects internally.")
    }

    lastOneDone <- FALSE
    if (grepl(deparse(parseTxt[[1]]), pattern = "^eval")) {
      callEnv <- tryCatch(
        eval(
          match.call(definition = eval, call = parseTxt)$envir,
          envir = eminus1
        ),
        error = function(x) {
          tryCatch(
            eval(
              match.call(definition = eval, call = parseTxt)$envir,
              envir = e
            ),
            error = function(x) .GlobalEnv
          )
        }
      )

      parseTxt[[3]] <- match.call(definition = eval, call = parseTxt)$expr
      if (is.name(match.call(definition = parse, call = parseTxt[[3]])$text)) {
        parseTxt <- parseTxt[[3]]
        parseTxt[[3]] <- match.call(definition = parse, call = parseTxt)$text
      }
      lastOneDone <- TRUE
    }
    if (is.call(parseTxt[[3]])) {
      parseTxt[[3]] <- tryCatch(
        eval(parseTxt[[3]], envir = e),
        error = function(x) {
          eval(parseTxt[[3]], envir = eminus1)
        }
      )
    }
    if (as.character(parseTxt[[1]]) == "[[") {
      parseTxt[[3]] <- tryCatch(
        eval(parseTxt[[3]], envir = e),
        error = function(x) {
          eval(parseTxt[[3]], envir = eminus1)
        }
      )
    }
    if (grepl(deparse(parseTxt[[1]]), pattern = "^get")) {
      callEnv <- tryCatch(
        eval(
          match.call(definition = eval,
                     call = parseTxt)$envir,
          envir = eminus1
        ),
        error = function(x) {
          tryCatch(
            eval(
              match.call(definition = eval, call = parseTxt)$envir,
              envir = e
            ),
            error = function(x) .GlobalEnv
          )
        }
      )
      parseTxt[[3]] <- match.call(definition = get, call = parseTxt)$x
      tmpParseTxt3 <- tryCatch(
        eval(parseTxt[[3]], envir = e),
        error = function(x) {
          eval(parseTxt[[3]], envir = eminus1)
        }
      )

      lastOneDone <- TRUE
      parseTxt[[3]] <- tmpParseTxt3
    }
    if (is.character(parseTxt[[3]])) {
      parseTxt[[3]] <- as.name(parseTxt[[3]])
    }
    if (is.numeric(parseTxt[[3]])) {
      if (!is.null(names(eval(parseTxt[[2]], envir = e)))) {
        parseTxt[[3]] <- names(eval(parseTxt[[2]], envir = e))[parseTxt[[3]]]
        if (is.na(parseTxt[[3]])) {
          stop("Please pass an object directly, or use get(x, envir = envName) ",
               "or eval(x, envir = envName). ",
               "Plot can not yet accept functions or complex objects internally.")
        }
      }

    }

    # override previous elems entry if length(parseTxt)>1:
    elems[[i]] <- parseTxt[[3]]

    # if evaluating the parsed text is a character,
    # then this is likely then name we want to keep:
    isChar <- tryCatch(
      is.character(eval(elems[[i]], envir = eminus1)),
      error = function(x) FALSE
    )
    if (isChar) {
      elems[[i]] <- as.name(eval(elems[[i]], envir = eminus1))
    }
    parseTxt <- parse(text = deparse(parseTxt[[2]]))[[1]]
    i <- i + 1
  }

  deparsedTxt <- deparse(parseTxt)
  sframes <- sys.frames()
  envs <- append(.GlobalEnv, sframes) %>%
    .[c(TRUE, unlist(lapply(sframes, function(x) {
      exists(deparsedTxt, envir = x, inherits = FALSE)
    })))] %>%
    .[[length(.)]]

  inGlobal <- identical(envs, .GlobalEnv)
  if (is.environment(eval(parse(text = deparsedTxt), envir = envs))) {
    envs <- eval(parse(text = deparsedTxt), envir = envs)
  } else {
    if (!lastOneDone) elems[[i]] <- parseTxt
  }
  if (exists("callEnv", inherits = FALSE)) {
    envs <- callEnv
  }

  if (!inGlobal) {
    devCur <- paste0("dev", dev.cur())
    if (!exists(devCur, envir = .quickPlotEnv)) {
      .quickPlotEnv[[devCur]] <- new.env(parent = emptyenv())
    }

    tmp <- get(deparse(rev(elems)[[1]]), envir = envs) ## the sim object
    .quickPlotEnv[[devCur]] <- .parseElems(tmp = tmp, elems = elems, envir = envs)
  }

  if (unlist(lapply(elems[[1]], is.numeric))) {
    return(list(objs = paste0(paste0(unlist(lapply(rev(elems), deparse)),
                                     collapse = "[["), "]]"),
                envs = envs))
  }
  return(list(objs = paste(unlist(lapply(rev(elems), deparse, backtick = TRUE)), collapse = "$"),
              envs = envs))
}

################################################################################
#' Parsing of elements
#'
#' This is a generic definition that can be extended according to class. Intended
#' only for development use.
#'
#' @return An object, parsed from a character string and and environment
#'
#' @param tmp A evaluated object
#' @param elems A character string to be parsed
#' @param envir An environment
#'
#' @export
#' @rdname parseElems
#' @author Eliot McIntire
setGeneric(".parseElems", function(tmp, elems, envir) {
  standardGeneric(".parseElems")
})

#' @export
#' @rdname parseElems
setMethod(
  ".parseElems",
  signature = "ANY",
  definition = function(tmp, elems, envir) {
    eval(parse(text = paste(unlist(lapply(rev(elems), deparse)), collapse = "$")), envir = envir)
})

################################################################################
#' Extracts the object names
#'
#' Internal function primarily used from \code{Plot}.
#'
#' @param calledFrom  character vector of length 1, indicating which function
#'                    call is desired. Defaults to \code{Plot}.
#'
#' @param argClass    character vector of length 1, indicating which class is
#'                    being searched for among the arguments.
#'                    Defaults to \code{.quickPlotObjects}.
#'
#' @param argName     character vector of length 1, or \code{NULL}, indicating
#'                    if the arguments to select have a name, no name (empty
#'                    string), or do not use name (\code{NULL}).
#'
#' @return \code{NULL}. This function is invoked for its side effects.
#'
#' @author Eliot McIntire
#' @export
#' @include plotting-classes.R
#' @keywords internal
#' @rdname objectNames
#'
.objectNames <- function(calledFrom = "Plot", argClass = ".quickPlotObjects",
                         argName = "") {
  scalls <- sys.calls()
  # Extract from the sys.calls only the function "calledFrom"
  frameCalledFrom <- which(unlist(lapply(scalls, function(x) {
    grepl(x, pattern = paste0("^", calledFrom, "$"))[1]
  })))
  e <- sys.frame(frameCalledFrom[1])
  eminus1 <- sys.frame(frameCalledFrom - 1)

  if (!nzchar(argName, keepNA = TRUE)) {
    callNamedArgs <- as.character(substitute(list(...), env = e))[-1]
  } else {
    callNamedArgs <- as.character(substitute(parse(text = sim), env = e))[-1]
  }
  objs <- lapply(callNamedArgs, .parseArgs, e, eminus1)
  return(objs)
}

#' Importing some grid functions
#'
#' Currently only the gpar function is imported. This is a convenience so that users
#' can change \code{Plot} arguments without having to load the entire grid package.
#'
#' @inheritParams grid::gpar
#'
#' @aliases gpar
#' @export
#' @importFrom grid gpar
#' @name gpar
#' @rdname grid-functions
#' @seealso \code{\link[grid]{gpar}}
#'
setGeneric("gpar", function(...) {
  standardGeneric("gpar")
})

#' @export
#' @rdname grid-functions
setMethod("gpar",
          definition = function(...) {
            return(grid::gpar(...))
})

################################################################################
#' Internal functions used by Plot
#'
#' Extract colors, legends and other things from object, and convert to a plotGrob
#'
#' @param grobToPlot Graphical object to plot
#' @param sGrob quickPlotGrob object
#' @param takeFromPlotObj Logical indicating whether data for grobToPlot should be found in
#'        current call to Plot or from disk
#' @param arr An arrangement object
#' @param newArr Logical, whether there is a new arrangement happening
#' @param quickPlotGrobCounter Numeric. A counter. No meaning outside Plot function.
#' @param subPlots Character. Name of plot area.
#' @param cols Color vector.
#'
#' @aliases PlotHelpers
#' @author Eliot McIntire
#' @include plotting-classes.R
#' @keywords internal
#' @name .preparePlotGrob
#' @rdname Plot-internal
#'
setGeneric(".preparePlotGrob", function(grobToPlot, sGrob, takeFromPlotObj, arr, newArr,
                                                 quickPlotGrobCounter, subPlots, cols)
  standardGeneric(".preparePlotGrob")
)

#' @aliases PlotHelpers
#' @keywords internal
#' @rdname Plot-internal
setMethod(
  ".preparePlotGrob",
  signature = c("griddedClasses", ".quickPlotGrob"),
  definition = function(grobToPlot, sGrob, takeFromPlotObj, arr, newArr,
                        quickPlotGrobCounter, subPlots, cols) {

    # Rasters may be zoomed into and subsampled and have unique legend
    #            if (sGrob@plotArgs$new)
    pR <- .prepareRaster(grobToPlot, sGrob@plotArgs$zoomExtent,
                         sGrob@plotArgs$legendRange, takeFromPlotObj,
                         arr, sGrob@plotArgs$speedup, newArr = newArr)
    zMat <- .makeColorMatrix(grobToPlot, pR$zoom, pR$maxpixels,
                             pR$legendRange,
                             na.color = sGrob@plotArgs$na.color,
                             zero.color = sGrob@plotArgs$zero.color,
                             cols = sGrob@plotArgs$cols,
                             skipSample = pR$skipSample)
    return(zMat)
})

setMethod(
  ".preparePlotGrob",
  signature = c("Spatial", ".quickPlotGrob"),
  definition = function(grobToPlot, sGrob, takeFromPlotObj, arr, newArr,
                        quickPlotGrobCounter, subPlots, cols) {
    if (!is.null(sGrob@plotArgs$zoomExtent)) {
      grobToPlot <- crop(grobToPlot, sGrob@plotArgs$zoomExtent)
    }

    # This handles SpatialPointsDataFrames with column "color"
    if (any(grepl(pattern = "color", names(grobToPlot))) & is.null(cols))
      sGrob@plotArgs$cols <- unlist(getColors(grobToPlot))

    zMat <- list(z = grobToPlot, minz = 0, maxz = 0,
                 cols = sGrob@plotArgs$cols, real = FALSE)
    return(zMat)
  })


setMethod(
  ".preparePlotGrob",
  signature = c("ANY", ".quickPlotGrob"),
  definition = function(grobToPlot, sGrob, takeFromPlotObj, arr, newArr,
                        quickPlotGrobCounter, subPlots, cols) {
    if (any(grepl(pattern = "color", colnames(grobToPlot))) & is.null(cols))
      sGrob@plotArgs$cols <- grobToPlot$color

    list(z = grobToPlot, minz = 0, maxz = 0,
         cols = sGrob@plotArgs$cols, real = FALSE)
  })

setMethod(
  ".preparePlotGrob",
  signature = c("SpatialLines", ".quickPlotGrob"),
  definition = function(grobToPlot, sGrob, takeFromPlotObj, arr, newArr,
                        quickPlotGrobCounter, subPlots, cols) {
  if (!is.null(sGrob@plotArgs$zoomExtent)) {
    grobToPlot <- crop(grobToPlot, sGrob@plotArgs$zoomExtent)
  }
  zMat <- list(z = grobToPlot, minz = 0, maxz = 0,
               cols = sGrob@plotArgs$cols, real = FALSE)
  return(zMat)
})


################################################################################
#' @param whPlotFrame Numeric. Which plot within the quickPlotGrobPlots object.
#'
#' @include plotting-classes.R
#' @aliases PlotHelpers
#' @keywords internal
#' @name .xyAxes
#' @rdname Plot-internal
#'
setGeneric(".xyAxes", function(sGrob, arr, whPlotFrame) {
  standardGeneric(".xyAxes")
})

#' @rdname Plot-internal
#' @aliases PlotHelpers
#' @keywords internal
setMethod(
  ".xyAxes",
  signature = c(".quickPlotGrob", ".arrangement"),
  definition = function(sGrob, arr, whPlotFrame) {
    if (sGrob@plotArgs$axes == "L") {
      if (sGrob@objClass == "Raster" &
          (arr@extents[(whPlotFrame - 1) %% arr@columns + 1][[1]] ==
           arr@extents[max(
             which(
               (1:length(arr@names) - 1) %% arr@columns + 1 ==
               (whPlotFrame - 1) %% arr@columns + 1
             ))][[1]])) {
        if (whPlotFrame > (length(arr@names) - arr@columns)) {
          xaxis <- TRUE
        } else {
          xaxis <- FALSE
        }
      } else {
        # not the same extent as the final one in the column
        xaxis <- TRUE
      }
    } else {
      xaxis <- sGrob@plotArgs$axes
    }

    if (sGrob@plotArgs$axes == "L") {
      if (sGrob@objClass == "Raster" &
          (arr@extents[whPlotFrame][[1]] ==
           arr@extents[(ceiling(whPlotFrame / arr@columns) - 1) * arr@columns + 1][[1]])) {
        if ((whPlotFrame - 1) %% arr@columns == 0) { # nolint
          yaxis <- TRUE
        } else {
          yaxis <- FALSE
        }
      } else {
        yaxis <- TRUE
      }
    } else {
      yaxis <- sGrob@plotArgs$axes
    }

    return(list(x = xaxis, y = yaxis))
})

#' @param quickSubPlots List of many quickPlotGrobs
#' @param isBaseSubPlot Logical. Is the currently being plotted object a base layer
#' @param isNewPlot Logical. Is the currently being plotted object a new, additional plot
#' @param isReplot Logical. Is the currently being plotted object a replot due to something
#'                 like a rearrangement
#' @param zMat List resulting from \code{.preparePlotGrob}
#' @param wipe Logical. Is the currently being plotted object require a white rectangle to
#'             be plotted first, and subsequent other changes.
#' @param xyAxes List of length 2, resulting from \code{.xyAxes}
#' @inheritParams Plot
#' @param vps A viewport tree resulting from \code{.makeViewports}
#' @param nonPlotArgs Arguments passed to \code{Plot} that are not \code{.quickPlottables},
#'                    but are passed along with \code{.quickPlottables}.
#'
#' @include plotting-classes.R
#' @importFrom grid seekViewport grid.text
#' @aliases PlotHelpers
#' @keywords internal
#' @name .Plot
#' @rdname Plot-internal
#'
setGeneric(".Plot", function(sGrob, grobToPlot, subPlots, quickSubPlots, quickPlotGrobCounter,
                             isBaseSubPlot, isNewPlot, isReplot, zMat, wipe, xyAxes, legendText,
                             vps, nonPlotArgs) {
  standardGeneric(".Plot")
})

#' @rdname Plot-internal
#' @importFrom raster crop is.factor
#' @aliases PlotHelpers
setMethod(
  ".Plot",
  signature = c(".quickPlotGrob"),
  definition = function(sGrob, grobToPlot, subPlots, quickSubPlots, quickPlotGrobCounter,
                        isBaseSubPlot, isNewPlot, isReplot, zMat, wipe, xyAxes, legendText,
                        vps, nonPlotArgs) {
    seekViewport(subPlots, recording = FALSE)

    if (is.list(grobToPlot)) {
      # This is for base plot calls... the grobToPlot is a call i.e,. a name
      # Because base plotting is not set up to overplot,
      # must plot a white rectangle
      par(fig = gridFIG())
      sGrob@plotArgs[names(grobToPlot)] <- grobToPlot

      # clear out all arguments that don't have meaning in plot.default
      if (inherits(grobToPlot, "gg")) {
        print(grobToPlot, vp = subPlots)
        a <- try(seekViewport(subPlots, recording = FALSE))
      } else {
        # plot y and x axes should use deparse(substitute(...)) names
        if (!identical(FALSE, sGrob@plotArgs$axes)) {
          if (!is.na(sGrob@plotArgs$axisLabels["x"])) {
            sGrob@plotArgs$xlab <- sGrob@plotArgs$axisLabels["x"]
          } else {
            if (!is.na(sGrob@plotArgs$axisLabels[1]))
              sGrob@plotArgs$xlab <- sGrob@plotArgs$axisLabels[1]
            else
              sGrob@plotArgs$xlab <- NULL
          }
          if (!is.na(sGrob@plotArgs$axisLabels["y"])) {
            sGrob@plotArgs$ylab <- sGrob@plotArgs$axisLabels["y"]
          } else {
            if (!is.na(sGrob@plotArgs$axisLabels[2]))
              sGrob@plotArgs$ylab <- sGrob@plotArgs$axisLabels[2]
            else
              sGrob@plotArgs$ylab <- NULL
          }
        } else {
          sGrob@plotArgs$xlab <- ""
          sGrob@plotArgs$ylab <- ""
        }

        isHist <- FALSE
        if (!is.null(grobToPlot$x)) {
          if (inherits(grobToPlot$x, "histogram")) {
            isHist <- TRUE
            sGrob@plotArgs$ylab <- if (is.null(sGrob@plotArgs$ylab)) "Frequency"
          } else if (is.numeric(grobToPlot$x)) {
            if (length(sGrob@plotArgs$axisLabels) == 1) {
              sGrob@plotArgs$ylab <- sGrob@plotArgs$xlab
              sGrob@plotArgs$xlab <- "Index"
            }
          }
        }

        argsPlot1 <- sGrob@plotArgs[!(names(sGrob@plotArgs) %in%
                                         c("new", "addTo", "gp", "gpAxis", "axisLabels",
                                         "zoomExtent", "gpText", "speedup", "size",
                                         "cols", "visualSqueeze", "legend", "legendRange",
                                         "legendText", "zero.color", "length", "arr",
                                         "na.color", "title", "userProvidedPlotFn"))]
        argsPlot1$axes <- isTRUE(sGrob@plotArgs$axes)
        makeSpaceForAxes <- as.numeric(
          !identical(FALSE, quickSubPlots[[subPlots]][[1]]@plotArgs$axes)
        )
        par(plt = c(0.18 + makeSpaceForAxes * 0.05, # left
                    0.95,                          # right
                    0.25 + makeSpaceForAxes * 0.05, # bottom
                    0.9))                         # top

        plotFn <- argsPlot1$plotFn
        argsPlot1$plotFn <- NULL

        # The actuall plot calls for base plotting
        if (inherits(grobToPlot, "igraph")) {
          # this next is a work around that I can't understand
          if (names(dev.cur()) == "null device") {
            plot(1, type = "n", axes = FALSE, xlab = "", ylab = "")
            clearPlot()
          }
          suppressWarnings(par(new = TRUE))
          plotCall <- list(x = grobToPlot)
          suppressWarnings(do.call(plot, args = plotCall))

        } else if (quickPlotGrobCounter == 1 | wipe | isHist) {
          suppressWarnings(par(new = TRUE))

          # This is a work around because I am not able to generically
          #  assess the formals of a function to remove any that aren't
          #  defined for that method... i.e., plot is the generic, but
          #  plot.igraph has different formals. Some of the functions
          #  are not exported, so their formals can't be found algorithmically
          tryCatch(do.call(plotFn, args = argsPlot1), error = function(x) {
            parsRm <- unlist(strsplit(gsub(x,
                                           pattern = ".*Unknown plot parameters: ",
                                           replacement = ""), split = ", "))
            parsRm <- gsub(parsRm, pattern = "\n", replacement = "")
            argsPlot1 <- argsPlot1[!(names(argsPlot1) %in% parsRm)]
            do.call(plotFn, args = argsPlot1)
          })
        } else {
          # adding points to a plot
          tmpPlotFn <- if (plotFn == "plot") "points" else plotFn
          argsPlot1[c("axes", "xlab", "ylab", "plotFn")] <- NULL
          suppressWarnings(do.call(tmpPlotFn, args = argsPlot1))
        }
      }

      if (any(unlist(xyAxes)) & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
        if (xyAxes$x | xyAxes$y & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
          axesArgs <- sGrob@plotArgs
          axesArgs$side <- 1
          axesArgs <- axesArgs[names(axesArgs) %in% c(
            "at", "labels", "tick", "line", "pos", "outer", "font",
            "lty", "lwd", "lwd.ticks", "col.ticks", "hadj", "padj")]
        }

        if (xyAxes$x & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
          axesArgsX <- append(list(side = 1), axesArgs)
          suppressWarnings(do.call(axis, args = axesArgsX))
        }
        if (xyAxes$y & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
          axesArgsY <- append(list(side = 2), axesArgs)
          suppressWarnings(do.call(axis, args = axesArgsY))
        }
      }
    } else {
      # This is for Rasters and Sp objects only
      # Extract legend text if the raster is a factored raster
      if (is.null(legendText)) {
        if (is.null(sGrob@plotArgs$legendTxt)) {
          if (any(raster::is.factor(grobToPlot))) {
            if (all(grobToPlot[]%%1==0)) {
              sGrob@plotArgs$legendTxt <- raster::levels(grobToPlot)[[1]]
            }
          }
        }
      } else {
        sGrob@plotArgs$legendTxt <- legendText
        cTxt <- legendText
      }

      if (!isBaseSubPlot) {
        sGrob@plotArgs$legendTxt <- NULL
      }

      plotGrobCall <- list(grobToPlot = zMat$z, col = zMat$cols,
                           size = unit(sGrob@plotArgs$size, "points"),
                           real = zMat$real,
                           minv = zMat$minz, maxv = zMat$maxz,
                           pch = sGrob@plotArgs$pch, name = subPlots,
                           vp = vps,
                           legend = #sGrob@plotArgs$legend  &  isBaseSubPlot &
                             #isReplot |
                             sGrob@plotArgs$legend & (isBaseSubPlot &
                                                        (isNewPlot | wipe | isReplot)),
                           legendText = sGrob@plotArgs$legendTxt,
                           gp = sGrob@plotArgs$gp,
                           gpText = sGrob@plotArgs$gpText,
                           speedup = sGrob@plotArgs$speedup,
                           length = sGrob@plotArgs$length
      ) %>% append(., nonPlotArgs)

      seekViewport(subPlots, recording = FALSE)
      suppressWarnings(do.call(.plotGrob, args = plotGrobCall))

      if (any(unlist(xyAxes)) & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
        seekViewport(paste0("outer", subPlots), recording = FALSE)
        if (xyAxes$x & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
          grid.xaxis(name = "xaxis", gp = sGrob@plotArgs$gpAxis)
        }
        if (xyAxes$y & (isBaseSubPlot & (isNewPlot | isReplot) | wipe)) {
          grid.yaxis(name = "yaxis", gp = sGrob@plotArgs$gpAxis,
                     vp = vps$wholeVp$children[[paste0("outer", subPlots)]])
        }
        seekViewport(subPlots, recording = FALSE)
      }
    } #gg vs histogram vs spatialObject
    # print Title on plot
    if (is.null(sGrob@plotArgs$title)) sGrob@plotArgs$title <- TRUE
    if (!identical(FALSE, sGrob@plotArgs$title) | (isBaseSubPlot & (isNewPlot | isReplot))) {
      plotName <- if (isTRUE(sGrob@plotArgs$title)) sGrob@plotName else sGrob@plotArgs$title
      a <- try(seekViewport(paste0("outer", subPlots), recording = FALSE))
      suppressWarnings(grid.text(plotName, name = "title",
                                 y = 1.08 - is.list(grobToPlot) * 0.02,
                                 vjust = 0.5, # tweak... not good practice.
                                              # Should find original reason why this is
                                              # not same y for rasters and all others
                                 gp = sGrob@plotArgs$gpText))
      a <- try(seekViewport(subPlots, recording = FALSE))
    }
    return(sGrob)
})

#' @param nColumns Numeric, length 1, indicating how many columns are in the device arrangement
#' @param nRows Numeric, length 1, indicating how many rows are in the device arrangement
#' @param whPlotObj Numeric. Length 1, indicating which of the currently objects passed into
#'                  \code{Plot} is currently being plotted, i.e., a counter of sorts.
#'
#' @include plotting-classes.R
#' @inheritParams .makeQuickPlot
#' @aliases PlotHelpers
#' @keywords internal
#' @name .refreshGrob
#' @rdname Plot-internal
#'
setGeneric(".refreshGrob", function(sGrob, subPlots, legendRange,
                                    grobToPlot, plotArgs, nColumns, nRows, whPlotObj) {
  standardGeneric(".refreshGrob")
})

#' @rdname Plot-internal
#' @aliases PlotHelpers
#' @keywords internal
setMethod(
  ".refreshGrob",
  signature = c(".quickPlotGrob"),
  definition = function(sGrob, subPlots, legendRange,
                        grobToPlot, plotArgs, nColumns, nRows, whPlotObj) {
    seekViewport(paste0("outer", subPlots), recording = FALSE)
    needsNewTitle <- sGrob@plotArgs$new != FALSE
    grid.rect(x = 0, height = unit(1 + needsNewTitle * inherits(grobToPlot, "Raster") * 0.20 / (nRows / 2), "npc"),
              width = unit(1 + inherits(grobToPlot, "Raster") * 0.20 / (nColumns / 2), "npc"),
              gp = gpar(fill = "white", col = "white"), just = "left")
    plotArgsByPlot <- lapply(plotArgs, function(x) {
      if (is.list(x)) {
        if (length(x) > 1) {
          return(x[whPlotObj])
        }}
      x
    })
    sGrob@plotArgs[names(plotArgs)] <- plotArgsByPlot
    sGrob@plotArgs$new <- FALSE
    sGrob@plotArgs$legendRange <- if (is.null(legendRange)) {
      NULL
    } else if (is.list(legendRange) & length(legendRange) > 1) {
      legendRange[[whPlotObj]]
    } else {
      legendRange
    }
    sGrob@plotArgs$legendTxt <- NULL
    seekViewport(subPlots, recording = FALSE)
    return(sGrob)
})


#' @include plotting-classes.R
#' @aliases PlotHelpers
#' @keywords internal
#' @name .updateGrobGPTextAxis
#' @rdname Plot-internal
setGeneric(".updateGrobGPTextAxis", function(sGrob, arr, newArr) {
  standardGeneric(".updateGrobGPTextAxis")
})

#' @aliases PlotHelpers
#' @rdname Plot-internal
setMethod(
  ".updateGrobGPTextAxis",
  signature = c(".quickPlotGrob"),
  definition = function(sGrob, arr, newArr) {

    if (!inherits(sGrob@plotArgs$gpText, "gpar")) {
      sGrob@plotArgs$gpText <- as(sGrob@plotArgs$gpText, "gpar")
    }
    if (!inherits(sGrob@plotArgs$gpAxis, "gpar")) {
      sGrob@plotArgs$gpAxis <- as(sGrob@plotArgs$gpAxis, "gpar")
    }
    if (!inherits(sGrob@plotArgs$gp, "gpar")) {
      sGrob@plotArgs$gp <- as(sGrob@plotArgs$gp, "gpar")
    }

    if (is.null(sGrob@plotArgs$gpText$cex) | newArr) {
      # pipe won't work here :S
      sGrob@plotArgs$gpText$cex <- max(
        0.6,
        min(1.2, sqrt(prod(arr@ds) / prod(arr@columns, arr@rows)) * 0.3)
      )
    }
    if (is.null(sGrob@plotArgs$gpAxis$cex) | newArr) {
      # pipe won't work here :S
      sGrob@plotArgs$gpAxis$cex <- max(
        0.6,
        min(1.2, sqrt(prod(arr@ds) / prod(arr@columns, arr@rows)) * 0.3)
      )
    }
    return(sGrob)
})

################################################################################
#' Identify where to get the grob from
#'
#' Internal function.
#'
#' Because the Plot function can use the global environment as a source of
#' objects to plot, not just the call itself, this function identifies where
#' the data for the grob should come from, the current call or the global
#' environment.
#'
#' @param toPlot The object to plot. Should be a single layer if from a multi-layer
#'               object such as a RasterStack.
#' @param sGrob quickPlot grob object
#' @param takeFromPlotObj Logical. Should the data come from the argument passed
#'                        into Plot (\code{TRUE}), or from the (\code{.quickPlotEnv})
#'                        (\code{FALSE}).
#'
#' @author Eliot McIntire
#' @include plotting-classes.R
#' @keywords internal
#' @export
#' @rdname identifyGrobToPlot
setGeneric(".identifyGrobToPlot", function(toPlot, sGrob, takeFromPlotObj) {
  standardGeneric(".identifyGrobToPlot")
})

#' @rdname identifyGrobToPlot
setMethod(
  ".identifyGrobToPlot",
  signature = c("ANY", ".quickPlotGrob"),
  function(toPlot, sGrob, takeFromPlotObj) {
    ## get the object name associated with this grob

    if (length(toPlot) == 0) takeFromPlotObj <- FALSE

    # Does it already exist on the plot device or not
    if (nzchar(sGrob@layerName, keepNA = TRUE)) {
      # means it is in a raster
      if (takeFromPlotObj) {
          grobToPlot <- unlist(toPlot, recursive = FALSE)[[sGrob@layerName]]
      } else {
          grobToPlot <- eval(parse(text = sGrob@objName),
                           sGrob@envir)[[sGrob@layerName]]
      }
    } else {
      if (takeFromPlotObj) {
        if (!inherits(toPlot, "gg") & !inherits(toPlot, "igraph")) {
          grobToPlot <- unlist(toPlot, recursive = FALSE)
        } else {
          grobToPlot <- toPlot
        }
      } else {
        grobToPlot <- eval(parse(text = sGrob@objName), sGrob@envir)
      }
    }
    return(grobToPlot)
})

################################################################################
#' Prepare raster for plotting
#'
#' Internal function. Takes a raster .quickPlotGrob, and converts zoomExtent into
#' a zoom, and legendRange into a legend.
#' Then calculates the maxpixels to plot for speed.
#'
#' @param grobToPlot .quickPlotGrob
#'
#' @param zoomExtent an extent object
#'
#' @param legendRange a numeric vector of length >=2 indicating the desired legend range.
#'
#' @param takeFromPlotObj logical. Should the object be found in the Plot call or .GlobalEnv
#'
#' @param arr an \code{.arrangement} object
#'
#' @param speedup numeric, greater than 1 will usually speed up plotting at the
#'                expense of resolution
#'
#' @param newArr logical, whether this is a new arrangement or just adding to a previous one
#'
#' @author Eliot McIntire
#' @keywords internal
#' @importFrom raster ncell
#' @include plotting-classes.R
#' @rdname prepareRaster
# igraph exports %>% from magrittr
.prepareRaster <- function(grobToPlot, zoomExtent, legendRange,
                           takeFromPlotObj, arr, speedup, newArr) {
  if (is.null(zoomExtent)) {
    zoom <- extent(grobToPlot)
    npixels <- ncell(grobToPlot)
  } else {
    zoom <- zoomExtent
    npixels <- ncell(crop(grobToPlot, zoom))
  }
  if (is.null(legendRange)) {
    legendRange <- NA
  }

  if (speedup > 0.1) {
    maxpixels <- min(5e5, 3e4 / (arr@columns * arr@rows) * prod(arr@ds)) %>%
      `/`(., speedup) %>%
      min(., npixels)
  } else {
    maxpixels <- npixels
  }
  skipSample <- if (is.null(zoomExtent)) {
    maxpixels >= npixels
  } else {
    FALSE
  }

  return(list(maxpixels = maxpixels, skipSample = skipSample,
              legendRange = legendRange, zoom = zoom))
}


################################################################################
#' Merge two quickPlot objects
#'
#' Merges two \code{.quickPlot} objects
#'
#' @param newSP  The "new" \code{.quickPlot} object.
#'               I.e., the new merges and overwrites into current.
#'
#' @param curr   The "current" \code{.quickPlot} object.
#'               I.e., the one to be merged into.
#'
#' @param ...    Additional arguments. Currently none implemented.
#'
#' @importFrom stats na.omit
#' @include plotting-classes.R
#' @author Eliot McIntire
#' @keywords internal
#' @rdname updateQuickPlot
setGeneric(".updateQuickPlot", function(newSP, curr, ...) {
  standardGeneric(".updateQuickPlot")
})

#' @rdname updateQuickPlot
setMethod(
  ".updateQuickPlot",
  signature = c(newSP = ".quickPlot", curr = "list"),
  definition = function(newSP, curr, ...) {
    newNames <- names(newSP@quickPlotGrobList)
    currNames <- names(curr$curr@quickPlotGrobList)

    addToPlots <- unlist(lapply(newSP@quickPlotGrobList, function(x) {
      !is.null(x[[1]]@plotArgs$addTo)
    }))

    addToPlotsNames <- unlist(lapply(newSP@quickPlotGrobList, function(x) {
      x[[1]]@plotArgs$addTo
    })) %>% unlist() # nolint

    if (length(addToPlotsNames) == length(newNames)) {
      overplots <- integer(0)
    } else {
      overplots <- na.omit(match(currNames, newNames))
      addToPlots1 <- na.omit(match(currNames, addToPlotsNames))
      overplots <- overplots[!(overplots %in% addToPlots1)]
    }

    needNew <- -c(overplots, which(addToPlots))
    if (length(needNew) == 0) {
      needNew <- 1:length(newNames)
    }

    whichParamsChanged <- lapply(newNames[overplots], function(x) {
      plotArgsNames <- names(newSP@quickPlotGrobList[[x]][[1]]@plotArgs)
      aa <- unlist(lapply(plotArgsNames, function(y) {
        if (!is.null(newSP@quickPlotGrobList[[x]][[1]]@plotArgs[[y]])) {
          !identical(newSP@quickPlotGrobList[[x]][[1]]@plotArgs[[y]],
                     curr$curr@quickPlotGrobList[[x]][[1]]@plotArgs[[y]])
        } else {
          FALSE
        }
      }))
      names(aa) <- plotArgsNames
      aa
    })
    names(whichParamsChanged) <- newNames[overplots]

    # # Set FALSE as default for needPlotting
    needPlotting <- lapply(curr$curr@quickPlotGrobList, function(x) {
      lapply(x, function(y) FALSE)
    })
    #
    # # Set FALSE as default for isReplot
    isReplot <- lapply(curr$curr@quickPlotGrobList, function(x) {
      lapply(x, function(y) FALSE)
    })

    isNewPlot <- lapply(curr$curr@quickPlotGrobList, function(x) {
      lapply(x, function(y) FALSE)
    })

    isBaseLayer <- curr$isBaseLayer

    # For overplots
    for (plots in newNames[overplots]) {
      # update only those plotArgs that have changed.
      idNames <- names(whichParamsChanged[[plots]])[whichParamsChanged[[plots]]]
      curr$curr@quickPlotGrobList[[plots]][[1]]@plotArgs[idNames] <-
        newSP@quickPlotGrobList[[plots]][[1]]@plotArgs[idNames]

      needPlotting[[plots]][[plots]] <- TRUE
      isReplot[[plots]][[plots]] <- FALSE
      isNewPlot[[plots]][[plots]] <- FALSE
    }

    # put addTo plots into list of quickPlotGrobs that it will be added to
    if (!is.null(addToPlotsNames)) {
      for (plots in 1:length(addToPlotsNames)) {
        a2p <- addToPlotsNames[plots]
        nA2P <- names(a2p)

        curr$curr@quickPlotGrobList[[a2p]][nA2P] <- newSP@quickPlotGrobList[[nA2P]]

        # change the name of the plotName to the parent object
        curr$curr@quickPlotGrobList[[a2p]][[nA2P]]@plotName <-
          curr$curr@quickPlotGrobList[[a2p]][[1]]@plotName
        needPlotting[[a2p]][[nA2P]] <- TRUE
        isReplot[[a2p]][[nA2P]] <- FALSE
        isBaseLayer[[a2p]][[nA2P]] <- FALSE
        isNewPlot[[a2p]][[nA2P]] <- FALSE
      }
    }

    # for new plots
    for (plots in newNames[needNew]) {
      curr$curr@quickPlotGrobList[[plots]] <- newSP@quickPlotGrobList[[plots]]
      needPlotting[[plots]] <- TRUE
      isReplot[[plots]] <- FALSE
      isBaseLayer[[plots]] <- TRUE
      isNewPlot[[plots]] <- TRUE
    }
    return(
      list(
        curr = curr$curr, whichParamsChanged = whichParamsChanged,
        needPlotting = needPlotting, isReplot = isReplot,
        isBaseLayer = isBaseLayer, isNewPlot = isNewPlot
      )
    )
})

#' @rdname updateQuickPlot
setMethod(
  ".updateQuickPlot",
  signature = c(newSP = ".quickPlot", curr = "missing"),
  definition = function(newSP, ...) {

    return(list(
      curr = newSP, whichParamsChanged = NULL,
      needPlotting = lapply(newSP@quickPlotGrobList, function(x) {
        lapply(x, function(y) TRUE)
      }),
      isReplot = lapply(newSP@quickPlotGrobList, function(x) {
        lapply(x, function(y) FALSE)
      }),
      isNewPlot = lapply(newSP@quickPlotGrobList, function(x) {
        lapply(x, function(y) TRUE)
      }),
      isBaseLayer = lapply(newSP@quickPlotGrobList, function(x) {
        lapply(x, function(y) TRUE)
      })
    ))
  })

################################################################################
#' Determine optimal plotting arrangement of plot objects
#'
#' Internal function. Assesses the device geometry, the map geometry, and the
#' number of spatial objects to plot and builds an object that will be used by
#' the Plot functions to plot them efficiently.
#'
#' @param sPlot A \code{.quickPlot} object.
#' @inheritParams Plot
#'
#' @author Eliot McIntire
#' @export
#' @importFrom grDevices dev.cur dev.new dev.size
#' @importFrom sp bbox
#' @include plotting-classes.R
#' @keywords internal
#' @rdname arrangeViewports
#'
setGeneric(".arrangeViewports", function(sPlot, arr=NULL) {
  standardGeneric(".arrangeViewports")
})

#' @export
#' @rdname arrangeViewports
setMethod(
  ".arrangeViewports",
  signature = c(".quickPlot"),
  definition = function(sPlot, arr) {
    ds <- dev.size()
    ds.ratio <- ds[1] / ds[2] # nolint

    sgl <- sPlot@quickPlotGrobList

    dimx <- apply(do.call(
      rbind, sapply(1:length(sgl), function(x) {
        lapply(sgl[[x]][[1]]@isSpatialObjects, function(z) {
          .hasBbox(z, sgl[[x]][[1]]@objClass,
                   sgl[[x]][[1]]@objName,
                   sgl[[x]][[1]]@envir)

        })
      })), 2, max)

    dimensionRatio <- dimx[1] / dimx[2]

    dsDimensionRatio <- ds.ratio / dimensionRatio # nolint
    if (is.null(arr)) {

      nPlots <- length(sgl)
      names <- names(sgl)

      if (dev.cur() == 1) {
        dev.new(height = 8, width = 10)
      }

      colByRow <- data.frame(matrix(ncol = 2, nrow = nPlots))

      colByRow[, 1] <- ceiling(nPlots / (1:nPlots))
      colByRow[, 2] <- ceiling(nPlots / colByRow[, 1])

      # rewritten for clarity/brevity with pipes below
      whBest <- apply(colByRow, 1, function(x) x[1] / x[2]) %>%
        `-`(., dsDimensionRatio) %>%
        abs() %>%
        which.min()

      columns <- colByRow[whBest, 1]
      rows <- colByRow[whBest, 2]
    } else {
      columns <- arr[2]
      rows <- arr[1]
    }

    actualRatio <- columns / rows

    out <- new(
      ".arrangement", rows = rows, columns = columns,
      actual.ratio = actualRatio,
      ds.dimensionRatio = dsDimensionRatio,
      ds = ds
    )
    return(out)
})


################################################################################
#' Plot spatial grobs (using \pkg{grid} package)
#'
#' Internal function. Plot a raster Grob, a points Grob, polygon Grob.
#'
#' \code{speedup} is only used for \code{SpatialPolygons}, \code{SpatialPoints},
#' and \code{SpatialLines} in this function.
#' Attempts have been made to subsample at a good level that optimizes speed of
#' plotting, without losing visible quality. Nevertheless, to force all points to
#' be plotted, use a speedup value less than 0.1.
#' From a speed perspective, there appears to be an optimal subsampling when
#' using \code{thin} from the \pkg{fastshp} package.
#' Presumably, too much thinning requires large distance matrices to be
#' calculated, slowing plotting down.
#' Too little thinning causes an overabundance of points to be plotted, slowing
#' plotting down.
#'
#' The suggested package \code{fastshp} can be installed with:
#' \code{install.packages("fastshp", repos = "http://rforge.net", type = "source")}.
#'
#' NOTE: you may get errors relating to not having installed the software tools
#' required for building R packages on your system.
#' For building on Windows, you'll need to install \code{Rtools} from
#' \url{https://cran.r-project.org/bin/windows/Rtools/}.
#'
#' @param grobToPlot  \code{Raster*}, \code{SpatialLines*},
#'                    \code{SpatialPoints*}, or \code{SpatialPolygons*} object.
#'
#' @param col     Currently only used for the legend of a \code{Raster*} object.
#'
#' @param size    The size of the \code{SpatialPoints}.
#'
#' @param gp      \code{grid} parameters, usually the output of a call to
#'                \code{\link{gpar}}.
#'
#' @param gpText  \code{gpar} object for legend label text.
#'
#' @param legend  Logical indicating whether a legend should be drawn.
#'                Default \code{TRUE}.
#'
#' @param legendText  Vector of values to use for legend value labels.
#'                    Defaults to \code{NULL} which results in a pretty numeric
#'                    representation. If \code{Raster*} has a Raster Attribute
#'                    Table (rat; see \pkg{raster} package), this will be used
#'                    by default. Currently, only a single vector is accepted.
#'
#' @param length  Numeric.
#'
#' @param minv    The minimum value on a \code{Raster*}. Required because not
#'                all Rasters have this defined internally.
#'
#' @param maxv    The maximum value on a \code{Raster*}. Required because not
#'                all Rasters have this defined internally.
#'
#' @param pch     Point character for \code{SpatialPoints}, as \code{par}.
#'
#' @param real    Logical indicating whether the data are \code{real} numbers
#'                (i.e., as opposed to \code{integer} or \code{factor}).
#'
#' @param speedup Numeric. The factor by which the number of vertices in
#'                \code{SpatialPolygons} and \code{SpatialLines*} will be
#'                subsampled. The vertices are already subsampled by default to
#'                make plotting faster.
#'
#' @param vp      whole viewport tree of \code{quickPlotGrob}
#'
#' @param name    Character string of name of object being plotted.
#'
#' @param ...     Additional arguments. None currently implemented.
#'
#' @author Eliot McIntire
#' @importFrom data.table ':=' data.table
#' @importFrom grDevices as.raster
#' @importFrom grid gpar gTree gList rasterGrob textGrob grid.draw
#' @importFrom sp proj4string
#' @importFrom raster extent pointDistance xmin xmax ymin ymax
#' @keywords internal
#' @rdname plotGrob
#' @export
#' @exportMethod .plotGrob
#'
setGeneric(
  ".plotGrob",
  function(grobToPlot, col = NULL, real = FALSE, size = unit(5, "points"), minv, maxv,
           legend = TRUE, legendText = NULL, length = NULL, gp = gpar(), gpText = gpar(),
           pch = 19, speedup = 1, name = character(), vp = list(), ...) {
  standardGeneric(".plotGrob")
})

############## SpatialPoints - thin
#' @rdname plotGrob
#' @importFrom grid pointsGrob
setMethod(
  ".plotGrob",
  signature = c("SpatialPoints"),
  definition = function(grobToPlot, col, size,
                        legend, gp = gpar(), pch, speedup, name, vp, ...) {
    speedupScale <- 40
    speedupScale <- if (grepl(proj4string(grobToPlot), pattern = "longlat")) {
      pointDistance(
        p1 = c(xmax(extent(grobToPlot)), ymax(extent(grobToPlot))),
        p2 = c(xmin(extent(grobToPlot)), ymin(extent(grobToPlot))),
        lonlat = TRUE
      ) / (4.8e5 * speedupScale)
    } else {
      max(ymax(extent(grobToPlot)) - ymin(extent(grobToPlot)),
          xmax(extent(grobToPlot)) - xmin(extent(grobToPlot))) /
        speedupScale
    }
    xyOrd <- coordinates(grobToPlot)

    if (!is.null(col)) {
      if (!is.null(gp)) {
        gp$col <- col # Accept col argument
      } else {
        gp <- gpar(col) #
      }
    }

    if (NROW(xyOrd) > 1e3) {
      # thin if greater than 1000 pts
      if (speedup > 0.1) {
        if (requireNamespace("fastshp", quietly = TRUE)) {
          thinned <- data.table(
            thin = fastshp::thin(xyOrd[, 1], xyOrd[, 2],
                                 tolerance = speedupScale * speedup)
          )
          xyOrd <- xyOrd[thinned$thin, ]
        } else {
          message(
            paste(
              "To speed up Polygons plotting using Plot install the fastshp package:\n",
              "install.packages(\"fastshp\", repos=\"http://rforge.net\", type=\"source\")."
            )
          )
          if (Sys.info()[["sysname"]] == "Windows") {
            message(
              paste(
                "You may also need to download and install Rtools from:\n",
                " https://cran.r-project.org/bin/windows/Rtools/"
              )
            )
          }
        }
      }
    }

    pntGrob <- gTree(
      grobToPlot = grobToPlot,
      children = gList(
        pointsGrob(
          x = xyOrd[, 1], y = xyOrd[, 2],
          pch = pch, size = size
        )
      ),
      gp = gp,
      cl = "plotPoint"
    )
    grid.draw(pntGrob, recording = FALSE)
    return(invisible(pntGrob))
})

#' @rdname plotGrob
setMethod(
  ".plotGrob",
  signature = c("matrix"),
  definition = function(grobToPlot, col, real, size, minv, maxv,
                        legend, legendText, gp, gpText, pch, name, vp, ...) {

    pr <- if (real) {
      pretty(range(minv, maxv))
    } else {
      if (!is.null(legendText)) {
        nrowLegText <- NROW(legendText)
        if (NCOL(legendText) > 1) {
          # means it was a factor
          legendText$contigValue <- 1:nrowLegText
          if (nrowLegText > 20) {
            pr <- pretty(legendText$contigValue)
            pr <- pr - min(pr) + 1 # start it at one
          } else {
            legendText$contigValue
          }

        } else {
          unique(round(pretty(range(minv, maxv), n = length(legendText))))
        }
      } else {
        unique(round(pretty(range(minv, maxv))))
      }
    }

    if (NCOL(legendText) == 1) {
      # means it was not a factor
      pr <- pr[pr <= maxv & pr >= minv]
    } else {
      pr <- pr[pr <= nrowLegText & pr >= 1]
    }
    if (length(pr) == 0) pr <- seq(minv, maxv, by = 2)
    maxcol <- length(col)
    mincol <- 2

    gpText$cex <- gpText$cex * 0.6
    if (length(gpText) == 0)
      gpText <- gpar(col = "black", cex = 0.6)

    rastGrob2 <- gTree(
      grobToPlot = grobToPlot, pr = pr, col = col,
      children = gList(
        rasterGrob(
          as.raster(grobToPlot),
          interpolate = FALSE,
          name = "raster"
        ),
        if (legend) {
          if (NCOL(legendText) > 1) {
            # for factors
            colForLegend <- col[rev(legendText$contigValue - min(legendText$contigValue) + 2)]
          } else {
            colForLegend <- col[(maxcol):mincol]
          }
          rasterGrob(
            as.raster(colForLegend),
            x = 1.04, y = 0.5,
            height = 0.5, width = 0.03,
            interpolate = FALSE,
            name = "legend"
          )
        },
        if (legend) {
          txt <- if (is.null(legendText)) {
            pr
          } else {
            # factor legends
            if (NCOL(legendText) > 1) {
              legendIndex <- pr
              legendText[legendIndex, 2]
            } else {
              legendIndex <- pr - min(pr) + 1
              legendText[legendIndex]
            }
          }
          textGrob(
            txt,
            x = 1.08,
            y = if (!real) {
              # factors
              if (NCOL(legendText) > 1) {
                maxv <- legendText$contigValue[nrowLegText]
                minv <- legendText$contigValue[1]
              }
              ((pr - minv) / ((maxv + 1) - minv)) / 2 + 0.25 + 1 / # nolint
                (diff(range(minv, maxv)) + 1) / 4
            } else {
              ((pr - minv) / ((maxv) - minv)) / 2 + 0.25 # nolint
            },
            gp = gpText,
            just = "left", check.overlap =
              TRUE,
            name = "legendText"
          )
        }
      ),
      gp = gp, cl = "plotRast2"
    )

    seekViewport(paste0("outer", name), recording = FALSE)
    grid.draw(rastGrob2, recording = FALSE)

    return(invisible())
})

################################################################################
#' @rdname plotGrob
#' @importFrom grid polygonGrob
setMethod(
  ".plotGrob",
  signature = c("SpatialPolygons"),
  definition = function(grobToPlot, col, size,
                        legend, gp = gpar(), pch, speedup, name, vp, ...) {

    speedupScale <- if (grepl(proj4string(grobToPlot), pattern = "longlat")) {
      pointDistance(
        p1 = c(xmax(extent(grobToPlot)), ymax(extent(grobToPlot))),
        p2 = c(xmin(extent(grobToPlot)), ymin(extent(grobToPlot))),
        lonlat = TRUE
      ) / 1.2e10
    } else {
      max(ymax(extent(grobToPlot)) - ymin(extent(grobToPlot)),
          xmax(extent(grobToPlot)) - xmin(extent(grobToPlot))) / 2.4e4
    }

    # For speed of plotting
    xyOrd <- quickPlot::thin(grobToPlot, tolerance = speedupScale * speedup,
                             returnDataFrame = TRUE, minCoordsToThin = 1e3)

    gp$fill[xyOrd[["hole"]]] <- "#FFFFFF00"
    polyGrob <- gTree(children = gList(
      polygonGrob(
        x = xyOrd[["xyOrd"]]$x, y = xyOrd[["xyOrd"]]$y,
        id.lengths = xyOrd[["idLength"]]$V1,
        gp = gp, default.units = "native"
      )
    ),
    gp = gp,
    cl = "plotPoly")
    grid.draw(polyGrob, recording = FALSE)
    return(invisible(polyGrob))
})

#' @rdname plotGrob
#' @importFrom grid polylineGrob arrow
setMethod(
  ".plotGrob",
  signature = c("SpatialLines"),
  definition = function(grobToPlot, col, size,
                        legend, length, gp = gpar(), pch, speedup, name, vp, ...) {
    speedupScale <- if (grepl(proj4string(grobToPlot), pattern = "longlat")) {
      pointDistance(
        p1 = c(xmax(extent(grobToPlot)), ymax(extent(grobToPlot))),
        p2 = c(xmin(extent(grobToPlot)), ymin(extent(grobToPlot))),
        lonlat = TRUE
      ) / 1.2e10
    } else {
      max(ymax(extent(grobToPlot)) - ymin(extent(grobToPlot)),
          xmax(extent(grobToPlot)) - xmin(extent(grobToPlot))) / 2.4e4
    }

    # For speed of plotting
    xy <- lapply(1:length(grobToPlot), function(i) {
      grobToPlot@lines[[i]]@Lines[[1]]@coords
    })
    idLength <- unlist(lapply(xy, length)) / 2
    xy <- do.call(rbind, xy)

    if (NROW(xy) > 1e3) {
      # thin if fewer than 1000 pts
      if (speedup > 0.1) {
        if (requireNamespace("fastshp", quietly = TRUE)) {
          thinned <- fastshp::thin(xy[, 1], xy[, 2],
                                   tolerance = speedupScale * speedup)

          # keep first and last points of every polyline,
          # if there are fewer than 10,000 vertices
          if (sum(thinned) < 1e4) {
            lastIDs <- cumsum(idLength)

            # Ensure first and last points of each line are kept:
            thinned[c(1, lastIDs + 1)[-(1 + length(lastIDs))]] <- TRUE # nolint
            thinned[lastIDs] <- TRUE
          }
          xy <- xy[thinned, ]
          idLength <- tapply(thinned, rep(1:length(idLength), idLength), sum)
        } else {
          message(
            paste(
              "To speed up Lines plotting using Plot, install the fastshp package:\n",
              "install.packages(\"fastshp\", repos=\"http://rforge.net\", type=\"source\")"
            )
          )
          if (Sys.info()[["sysname"]] == "Windows") {
            message(
              paste(
                "You may also need to download and install Rtools from:\n",
                "  https://cran.r-project.org/bin/windows/Rtools/"
              )
            )
          }
        }
      }
    }

    if (is.null(length)) {
      lineGrob <- gTree(children = gList(
        polylineGrob(
          x = xy[, 1], y = xy[, 2], id.lengths = idLength,
          gp = gp, default.units = "native"
        )
      ),
      gp = gp,
      cl = "plotLine")
    } else {
      lineGrob <- gTree(children = gList(
        polylineGrob(
          x = xy[, 1], y = xy[, 2], id.lengths = idLength,
          gp = gp, default.units = "native",
          arrow = arrow(length = unit(length, "inches"))
        )
      ),
      gp = gp,
      cl = "plotLine")
    }

    grid.draw(lineGrob, recording = FALSE)
    return(invisible(lineGrob))
})

################################################################################
#' Make an optimal layout of plots
#'
#' Internal function. Using the size of the current device, and number and
#' dimension ratios of the plots, place them optimally in the plotting region.
#'
#' @param arr an object of class \code{.arrangement}.
#'
#' @param visualSqueeze Numeric. The proportion of the white space to be used
#'                      for plots. Default is 0.75.
#'
#' @param legend Logical indicating whether legend should be included as part of
#'               layout calculation. Default is \code{TRUE}.
#'
#' @param axes Logical indicating whether the axes should be included as part of
#'             layout calculation. Default is \code{TRUE}.
#'
#' @param title Logical indicating whether the names of each plot should be
#'              written above plots and should be included as part of layout
#'               calculation. Default is \code{TRUE}.
#'
#' @include plotting-classes.R
#' @importFrom grid unit unit.c
#' @keywords internal
#' @rdname makeLayout
#' @author Eliot McIntire
#'
.makeLayout <- function(arr, visualSqueeze,
                        legend = TRUE, axes = TRUE, title = TRUE) {
  columns <- arr@columns
  rows <- arr@rows

  # Reduce by 40% of remaining space if each of the following is not wanted
  if (legend == FALSE) {
    visualSqueeze <- visualSqueeze + 0.4 * (1 - visualSqueeze)
  }
  if (axes == FALSE) {
    visualSqueeze <- visualSqueeze + 0.4 * (1 - visualSqueeze)
  }
  if (title == FALSE) {
    visualSqueeze <- visualSqueeze + 0.4 * (1 - visualSqueeze)
  }

  # calculate the visualSqueeze for the width (i.e., vS.w)
  vS.w <- min( # nolint
    visualSqueeze / columns,
    visualSqueeze / columns * arr@actual.ratio / arr@ds.dimensionRatio
  )

  wdth <- unit.c(unit(0.2, "null"),
                 unit(rep(c(0.875, vS.w, 0.875), columns),
                      rep(c("null", "npc", "null"), columns)),
                 unit(0.2, "null"))

  # calculate the visualSqueeze for the height (i.e., vS.h)
  vS.h <- min(visualSqueeze / rows, # nolint
              visualSqueeze / rows * arr@ds.dimensionRatio / arr@actual.ratio)
  ht <- unit.c(unit(0.2, "null"),
               unit(rep(c(0.875, vS.h, 0.875), rows),
                    rep(c("null", "npc", "null"), rows)),
               unit(0.2, "null"))

  return(list(wdth = wdth, ht = ht, wdthUnits = vS.w, htUnits = vS.h,
              visualSqueeze = visualSqueeze))
}

################################################################################
#' Make viewports
#'
#' Given a set of extents, and a layout for these extents, this function will
#' output a viewport tree to allow plotting.
#'
#' This function will either create a totally new set of viewports, or simply
#' add some nested viewports to an existing arrangement, i.e., is there still
#' white space available to plot.
#'
#' @param sPlot An object of class \code{.quickPlot}.
#'
#' @param newArr  Logical indicating whether this function will create a
#'                completely new viewport. Default \code{FALSE}.
#'
#' @author Eliot McIntire
#' @include plotting-classes.R
#' @importFrom grid viewport vpTree vpList
#' @importFrom raster xmin xmax ymin ymax extent
#' @keywords internal
#' @rdname makeViewports
#'
.makeViewports <- function(sPlot, newArr = FALSE) {

  arr <- sPlot@arr
  sgl <- sPlot@quickPlotGrobList

  extents <- unlist(sapply(sgl, function(x) {
    unname(lapply(x[[1]]@isSpatialObjects, function(z) {
      if (z == TRUE) {
        # for spatial objects
        if (!is.null(x[[1]]@plotArgs$zoomExtent)) {
          x[[1]]@plotArgs$zoomExtent
        } else {
          extent(eval(parse(text = x[[1]]@objName), envir = x[[1]]@envir))
        }
      } else {
        obj <- eval(parse(text = x[[1]]@objName), envir = x[[1]]@envir)
        # if the object has an extent method
        if (hasMethod("extent", is(obj)[1]) & !is.list(obj)) {
          # list has an extent method, but too general
          extent(obj)
        } else {
          # for non spatial objects
          extent(c(xmin = 0, xmax = 2, ymin = 0, ymax = 2))
        }

      }
    }))
  }))

  columns <- arr@columns
  rows <- arr@rows
  gl1 <- grid.layout(
    nrow = rows * 3 + 2, ncol = columns * 3 + 2,
    widths = arr@layout$wdth, heights = arr@layout$ht
  )
  topVp <- viewport(layout = gl1,
                    name = "top"
  )
  plotVps <- list()

  nam <- names(extents)

  # This is the biggest of the extents, and is used in .makeLayout
  #  Need to replicate it here because all plots are scaled to this
  biggestDims <- apply(do.call(rbind, sapply(1:length(sgl), function(x) {
    lapply(sgl[[x]][[1]]@isSpatialObjects, function(z) {
      .hasBbox(z, sgl[[x]][[1]]@objClass, sgl[[x]][[1]]@objName,
               sgl[[x]][[1]]@envir)
    })
  })), 2, max)

  for (extentInd in 1:length(extents)) {
    posInd <- match(nam[extentInd], names(sgl))
    lpc <- ceiling((posInd - 1) %% columns + 1) * 3 # nolint
    lpr <- ceiling(posInd / columns) * 3

    if (!sgl[[posInd]][[1]]@isSpatialObjects) {
      lpc <- c((lpc - 1):(lpc + 1)) # nolint
      lpr <- c((lpr):(lpr + 1)) # nolint
    }
    # makes equal scale
    yrange <- extents[[extentInd]]@ymax - extents[[extentInd]]@ymin
    if (yrange > 0) {
      if (abs((yrange / (extents[[extentInd]]@xmax - extents[[extentInd]]@xmin)) - # nolint
        (biggestDims[1] / biggestDims[2])) > getOption("quickPlot.tolerance")) {
        dimensionRatio <- arr@layout$wdthUnits * arr@ds[1] /
          (arr@layout$htUnits * arr@ds[2])
        plotScaleRatio <- (extents[[extentInd]]@xmin - extents[[extentInd]]@xmax) /
          (extents[[extentInd]]@ymin - extents[[extentInd]]@ymax)

        vS.w <- min(1, plotScaleRatio / dimensionRatio) # nolint
        vS.h <- min(1, dimensionRatio / plotScaleRatio) # nolint

        addX <- abs((extents[[extentInd]]@xmax - extents[[extentInd]]@xmin) * 0.025) # nolint
        addY <- abs((extents[[extentInd]]@ymax - extents[[extentInd]]@ymin) * 0.025) # nolint
        # addY <- abs(extents[[extentInd]]@ymax - extents[[extentInd]]@ymin -
        #               (extents[[extentInd]]@ymax - extents[[extentInd]]@ymin) /
        #               vS.h) / 2
        # addX <- abs(extents[[extentInd]]@xmax - extents[[extentInd]]@xmin -
        #               (extents[[extentInd]]@xmax - extents[[extentInd]]@xmin) /
        #               vS.w) / 2
      } else {
        addY <- addX <- 0
      }
    } else {
      addX <- abs((extents[[extentInd]]@xmax - extents[[extentInd]]@xmin) * 0.025) # nolint
      addY <- abs((extents[[extentInd]]@ymax - extents[[extentInd]]@ymin) * 0.025) # nolint
    }
    # end equal scale
    plotVps[[nam[extentInd]]] <- viewport(
      clip = "on",
      name = nam[extentInd],
      layout.pos.col = lpc,
      layout.pos.row = lpr,
      xscale = c(extents[[extentInd]]@xmin - addX, extents[[extentInd]]@xmax + addX),
      yscale = c(extents[[extentInd]]@ymin - addY, extents[[extentInd]]@ymax + addY)
    )
    plotVps[[paste0("outer", nam[extentInd])]] <- viewport(#clip = "on",
      name = paste0("outer", nam[extentInd]),
      layout.pos.col = lpc,
      layout.pos.row = lpr,
      xscale = c(extents[[extentInd]]@xmin - addX, extents[[extentInd]]@xmax + addX),
      yscale = c(extents[[extentInd]]@ymin - addY, extents[[extentInd]]@ymax + addY)
    )
  }

  wholeVp <- vpTree(topVp, do.call(vpList, plotVps))

  return(list(wholeVp = wholeVp, extents = extents))
}

#' Test whether class has bbox method
#'
#' For internal use only.
#'
#' @rdname hasBbox
#' @param z Logical, whether this object is a SpatialObject
#' @param objClass The class of the object
#' @param objName The character string name of the object
#' @param objEnv The environment where the object can be found
.hasBbox <- function(z, objClass, objName, objEnv) {
  if (z == TRUE) {
    hasBbox <- TRUE
  } else {
    if (existsMethod("bbox", objClass[1])) {
      hasBbox <- TRUE
    } else {
      hasBbox <- FALSE
    }
  }
  if (hasBbox) {
    # for spatial objects
    apply(bbox(eval(parse(text = objName), envir = objEnv)), 1, function(y) {
      diff(range(y))
    })
  } else {
    # for non spatial objects
    c(1, 1)
  }
}

#' Convert pairs of coordinates to SpatialLines
#'
#' This will convert 2 objects whose coordinates can be extracted with \code{coordinates}
#' (e.g., \code{sp::SpatialPoints*})
#' to a single SpatialLines
#' object. The first object is treated as the "to" or destination, and the
#' second object the "from" or source. This can be used to represent
#' directional SpatialLines, especially with with arrow heads, as in
#' \code{Plot(sl, length = 0.1)}
#'
#' @export
#' @importFrom sp SpatialLines Lines Line coordinates
#' @param sp1 SpatialPoints* object
#' @param from SpatialPoints* object. Optional. If not provided, then the function
#'             will attempt to find the "previous" coordinates as columns
#'             (\code{prevX}, \code{prevY}) in the \code{sp1} object.
#' @examples
#' caribou <- sp::SpatialPoints(coords = cbind(x = stats::runif(1e1, -50, 50),
#'                                         y = stats::runif(1e1, -50, 50)))
#' caribouFrom <- sp::SpatialPoints(coords = cbind(x = stats::runif(1e1, -50, 50),
#'                                         y = stats::runif(1e1, -50, 50)))
#' caribouLines <- sp2sl(caribou, caribouFrom)
#' Plot(caribouLines, length = 0.1)
sp2sl <- function(sp1, from) {
  l <- vector("list", NROW(sp1))
  beginCoord <- coordinates(sp1)
  if (missing(from)) {
    endCoord <- sp1[, c("prevX", "prevY")]
  } else {
    endCoord <- coordinates(from)
  }

  for (i in seq_along(l)) {
    l[[i]] <- Lines(list(Line(rbind(beginCoord[i, ], endCoord[i, ]))), as.character(i))
  }

  SpatialLines(l)
}



#' Thin a polygon using fastshp::thin
#'
#' For visualizing, it is sometimes useful to remove points in Spatial* objects.
#' This will change the geometry, so it is not recommended for computation. This
#' is similar to rgeos::gSimplify and sf::st_simplify, but faster than both (see examples)
#' for large shapefiles, particularly if \code{returnDataFrame} is \code{TRUE}.
#' \code{thin} will not attempt to preserve topology.
#' It is strictly for making smaller polygons for the purpose (likely)
#' of visualizing more quickly.
#'
#' @param x A Spatial* object
#' @param returnDataFrame If \code{TRUE}, this will return a list of 3 elements, xyOrd, hole,
#'        idLength. If \code{FALSE}, the default, it will return a \code{SpatialPolygons}
#'        object
#' @param minCoordsToThin If the number of coordinates is smaller than this number,
#'        then thin will just pass through, though it will take the time required to
#'        calculate how many points there are (which is not NROW(coordinates(x)) for
#'        a SpatialPolygon)
#'
#' @inheritParams fastshp::thin
#' @rdname thin
#' @importFrom data.table set data.table as.data.table
#' @importFrom sp Polygon Polygons SpatialPolygons CRS SpatialPolygonsDataFrame
#' @importFrom raster xmax xmin
#' @export
#' @examples
#' library(raster)
#'
#' b <- SpatialPoints(cbind(-110, 59, 1000))
#' crs(b) <- sp::CRS("+init=epsg:4326")
#'
#' crsObj <- CRS(paste0("+proj=tmerc +lat_0=0 +lon_0=-115 +k=0.9992 +x_0=500000 +y_0=0 ",
#'                      "+datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0"))
#'
#' # make a random polygon -- code adapted from SpaDES.tools::randomPolygon package:
#'   areaM2 <- 1000 * 1e4 * 1.304 # rescale so mean area is close to hectares
#'   b <- spTransform(b, crsObj)
#'
#'   radius <- sqrt(areaM2 / pi)
#'
#'   meanX <- mean(coordinates(b)[, 1]) - radius
#'   meanY <- mean(coordinates(b)[, 2]) - radius
#'
#'   minX <- meanX - radius
#'   maxX <- meanX + radius
#'   minY <- meanY - radius
#'   maxY <- meanY + radius
#'
#' # Add random noise to polygon
#'   xAdd <- round(runif(1, radius * 0.8, radius * 1.2))
#'   yAdd <- round(runif(1, radius * 0.8, radius * 1.2))
#'   nPoints <- 20
#'   betaPar <- 0.6
#'   X <- c(jitter(sort(rbeta(nPoints, betaPar, betaPar) * (maxX - minX) + minX)),
#'         jitter(sort(rbeta(nPoints, betaPar, betaPar) * (maxX - minX) + minX, decreasing = TRUE)))
#'   Y <- c(jitter(sort(rbeta(nPoints / 2, betaPar, betaPar) * (maxY - meanY) + meanY)),
#'          jitter(sort(rbeta(nPoints, betaPar, betaPar) * (maxY - minY) + minY, decreasing = TRUE)),
#'          jitter(sort(rbeta(nPoints / 2, betaPar, betaPar) * (meanY - minY) + minY)))
#'
#'   Sr1 <- Polygon(cbind(X + xAdd, Y + yAdd))
#'   Srs1 <- Polygons(list(Sr1), "s1")
#'   a <- SpatialPolygons(list(Srs1), 1L)
#'   crs(a) <- crsObj
#' # end of making random polygon
#'
#' clearPlot()
#' Plot(a)
#' NROW(a@polygons[[1]]@Polygons[[1]]@coords)
#' aThin <- thin(a, 200)
#' NROW(aThin@polygons[[1]]@Polygons[[1]]@coords) # fewer
#' Plot(aThin) # looks similar
#'
#' # compare -- if you have rgeos
#' # if (require("rgeos")) {
#' #   aSimplify <- gSimplify(a, tol = 200)
#' #   NROW(aSimplify@polygons[[1]]@Polygons[[1]]@coords) # fewer
#' #  Plot(aSimplify)
#' # }
#'
#' # compare -- if you have sf
#' # if (require("sf")) {
#' #   aSF <- st_simplify(st_as_sf(a), dTolerance = 200)
#' #   # convert to Spatial to see how many coordinates
#' #   aSF2 <- as(aSF, "Spatial")
#' #   NROW(aSF2@polygons[[1]]@Polygons[[1]]@coords) # fewer
#' #   Plot(aSF)
#' # }
#'
#' # thin is faster than rgeos::gSimplify and sf::st_simplify on large shapefiles
#' \dontrun{ # this involves downloading a 9 MB file
#'   setwd(tempdir())
#'   albertaEcozoneFiles <- c("Natural_Regions_Subregions_of_Alberta.dbf",
#'                            "Natural_Regions_Subregions_of_Alberta.lyr",
#'                            "Natural_Regions_Subregions_of_Alberta.prj",
#'                            "Natural_Regions_Subregions_of_Alberta.shp.xml",
#'                            "Natural_Regions_Subregions_of_Alberta.shx",
#'                            "natural_regions_subregions_of_alberta.zip",
#'                            "nsr2005_final_letter.jpg", "nsr2005_final_letter.pdf")
#'   albertaEcozoneURL <- paste0("https://www.albertaparks.ca/media/429607/",
#'                               "natural_regions_subregions_of_alberta.zip")
#'   albertaEcozoneFilename <- "Natural_Regions_Subregions_of_Alberta.shp"
#'   zipFilename <- basename(albertaEcozoneURL)
#'   download.file(albertaEcozoneURL, destfile = zipFilename)
#'   unzip(zipFilename, junkpaths = TRUE)
#'   a <- raster::shapefile(albertaEcozoneFilename)
#'
#'   # compare -- if you have rgeos and sf package
#'   # if (require("sf")) {
#'   #   aSF <- st_as_sf(a)
#'   # }
#'   # if (require("rgeos") && require("sf")) {
#'     # thin at 10m
#'     microbenchmark::microbenchmark(times = 20
#'                                    , thin(a, 10),
#'                                    , thin(a, 10, returnDataFrame = TRUE) # much faster
#'    #                               , gSimplify(a, 10),
#'    #                               , st_simplify(aSF, dTolerance = 10))
#'                                   )
#'    # Unit: milliseconds
#'    #                              expr      min   median      max neval cld
#'    # thin(a, 10)                        989.812 1266.393 1479.879     6  a
#'    # gSimplify(a, 10   )               4020.349 4211.414 8881.535     6   b
#'    # st_simplify(aSF, dTolerance = 10) 4087.343 4344.936 4910.299     6   b
#'   #}
#' }
thin <- function(x, tolerance, returnDataFrame, minCoordsToThin) {
  UseMethod("thin")
}

#' @rdname thin
#' @export
thin.SpatialPolygons <- function(x, tolerance = NULL, returnDataFrame = FALSE, minCoordsToThin = 0) {

  # For speed of plotting
  xyOrd <- .fortify(x, matchFortify = FALSE,
                    simple = returnDataFrame) # a list: out, hole, idLength
  if (is.null(tolerance)) {
    tolerance <- (raster::xmax(x) - raster::xmin(x)) * 0.0001
    message("tolerance set to ", tolerance)
  }
  if (requireNamespace("fastshp")) {
    if (NROW(xyOrd[["out"]]) > minCoordsToThin) {
      thinRes <- fastshp::thin(xyOrd[["out"]]$x, xyOrd[["out"]]$y,
                             tolerance = tolerance, id = xyOrd[["out"]]$groups)

      xyOrd[["out"]] <- xyOrd[["out"]][thinRes, ]# thin line
      if (returnDataFrame) {
        xyOrd[["idLength"]] <- xyOrd[["out"]][,list(V1=.N),by=groups]
      } else {
        # clean up a bit
        set(xyOrd[["out"]], , "order", NULL)
        set(xyOrd[["out"]], , "groups", NULL)


        polyList <- split(xyOrd[["out"]], by = c("Polygons", "Polygon"),
                           flatten = FALSE, keep.by = FALSE)
        bb <- lapply(unique(xyOrd$out$Polygons), function(outerI) {
          poly <- lapply(seq(polyList[[outerI]]), function(innerI) {
            #Polygon(as.matrix(polyList[[outerI]][[innerI]][, c("x", "y")]),
            Polygon(cbind(polyList[[outerI]][[innerI]]$x, polyList[[outerI]][[innerI]]$y),
                    hole = unique(as.logical(polyList[[outerI]][[innerI]]$hole)))
          })
          Polygons(poly, ID = outerI)
        })

        xyOrd <- SpatialPolygons(bb, proj4string = CRS(proj4string(x)))
        if (is(x, "SpatialPolygonsDataFrame"))
          xyOrd <- SpatialPolygonsDataFrame(xyOrd, data = x@data)
        return(xyOrd)

      }
    }
  } else {

    message(
      paste(
        "To speed up Polygons plotting using Plot install the fastshp package:\n",
        "install.packages(\"fastshp\", repos=\"http://rforge.net\", type=\"source\")."
      )
    )
    if (Sys.info()[["sysname"]] == "Windows") {
      message(
        paste(
          "You may also need to download and install Rtools from:\n",
          " https://cran.r-project.org/bin/windows/Rtools/"
        )
      )
    }
  }
  xyOrd <- list(xyOrd = xyOrd[["out"]], hole = xyOrd[["hole"]],
                idLength = xyOrd[["idLength"]])
}


#' @rdname thin
#' @export
thin.default <- function(x, tolerance, returnDataFrame, minCoordsToThin) {
  message("No method for that class of object exists. See methods('thin') to see current methods")
}

#' Fortify - i.e,. convert an artibrary object to a data.frame-like object
#'
#' This only deals with SpatialPolygons.
#'
#' @rdname fortify
#' @name fortify
#' @importFrom data.table setDT set
#' @keywords internal
.fortify <- function(x, matchFortify = TRUE, simple = FALSE) {
  ord <- x@plotOrder
  ordSeq <- seq(ord)
  xy <- lapply(ordSeq, function(i) {
    lapply(x@polygons[[i]]@Polygons, function(j) {
      j@coords
    })
  })

  hole <- tryCatch(unlist(lapply(ordSeq, function(xx) {
    lapply(x@polygons[[xx]]@Polygons, function(yy)
      yy@hole)
  })), error = function(xx) FALSE)

  IDs <- tryCatch(unlist(lapply(ordSeq, function(xx) {
    x@polygons[[xx]]@ID
  })), error = function(xx) FALSE)


  ordInner <- lapply(ordSeq, function(xx) {
    x@polygons[[xx]]@plotOrder
  })

  xyOrd.l <- lapply(ordSeq, function(i) { # nolint
    xy[[i]][ordInner[[i]]]
  })

  idLength <- data.table(V1 = unlist(lapply(xyOrd.l, function(i) {
    lapply(i, length)
  })) / 2)


  numPolygons <- unlist(length(xyOrd.l))
  numPolygon <- unlist(lapply(xyOrd.l, length))


  xyOrd <- do.call(rbind, lapply(xyOrd.l, function(i) {
    do.call(rbind, i)
  }))

  groups <- rep(1:NROW(idLength), idLength$V1)
  if (!simple | matchFortify) {
    # Polygons <- rep(rep(seq(numPolygons), numPolygon), idLength$V1) # sequential numbering
    Polygons <- rep(rep(IDs, numPolygon), idLength$V1) # actual ID labelling
    Polygon <- rep(unlist(lapply(numPolygon, seq)), idLength$V1)
    holes <- rep(hole, idLength$V1)
    orders <- unlist(lapply(idLength$V1, seq))
  }

  if (matchFortify) {
    if (!simple) message("for matchFortify = TRUE, simple is set to FALSE")
    return(data.frame(lat = xyOrd[,1], long = xyOrd[,2], order = orders,
                      hole = holes, id = Polygons, piece = Polygon,
                      #group = paste0(as.character(Polygons), ".", as.character(Polygon)))) # the actual fortify
                      group = groups))
  } else {
    out <- setDT(data.frame(x = xyOrd[,1], y = xyOrd[,2], groups = groups))
    if (!simple) {
      set(out, , "order", orders)
      set(out, , "hole", holes)
      set(out, , "Polygons", Polygons)
      set(out, , "Polygon", Polygon)
    }
    out <- list(out = out, hole = hole, idLength = idLength)

    return(out)
  }
}