R/AddInsetMap.R

In inlmisc: Miscellaneous Functions for the USGS INL Project Office

#' Add Inset Map to Plot
#'
#' Add an inset map to a plot.
#'
#' @param p 'SpatialPolygons'.
#'   Polygon describing the large map.
#' @param col 'character' vector of length 2.
#'   Colors for filling the large map polygon \code{p} and the smaller plot extent rectangle.
#' @param main.label 'list'.
#'   List with components \code{label} and \code{adj}.
#'   The text label and position (x and y adjustment of the label) for the large map, respectively.
#' @param sub.label 'list'.
#'   Identical to the \code{main.label} argument but for the plot extent rectangle.
#' @param loc 'character' string.
#'   Position of the inset map in the main plot region;
#'   see \code{\link{GetInsetLocation}} function for keyword descriptions.
#' @param inset 'numeric' vector of length 1 or 2, value is recycled as necessary.
#'   Inset distance(s) from the margins as a fraction of the main plot region.
#'   Defaults to 2 percent of the axis range.
#' @param width 'numeric' number.
#'   Width of the inset map in inches.
#' @param e 'numeric' vector of length 4.
#'   Extent of the smaller axis-aligned rectangle (relative to the larger map polygon).
#'   Defaults to the user coordinate extent of the main plot region.
#' @param bty 'character' string.
#'   Type of box to be drawn about the inset map.
#'   A value of \code{"o"} (the default) results in a box and a value of \code{"n"} suppresses the box.
#' @param feature 'list'.
#'   One or more spatial objects, along with style arguments, to add to the inset map.
#'   Each list element is a 'list'-class object that contains the following components:
#'   the first component is the name of the plotting function;
#'   the second component is the object to be plotted; and
#'   the remaining components are reserved for arguments to be passed to the function.
#'
#' @return Invisible \code{NULL}
#'
#' @author J.C. Fisher, U.S. Geological Survey, Idaho Water Science Center
#'
#' @seealso \code{\link{PlotMap}}
#'
#' @keywords hplot
#'
#' @export
#'
#' @examples
#' file <- system.file("extdata/county.geojson",
#'                     package = "inlmisc")[1]
#' county <- rgdal::readOGR(file)
#' ext <- c(-113.4005, -112.2764, 43.30, 44.11)
#' PlotMap(county, xlim = ext[1:2], ylim = ext[3:4],
#'         dms.tick = TRUE)
#' sp::plot(county, add = TRUE)
#' AddInsetMap(county, width = 2,
#'             main.label = list("IDAHO", "adj" = c(0, -10)),
#'             sub.label = list("Map area", "adj" = c(0, -4)),
#'             loc = "topright")
#'

AddInsetMap <- function(p, col=c("#D8D8D8", "#BFA76F"),
                        main.label=list("label"=NA, "adj"=NULL),
                        sub.label=list("label"=NA, "adj"=NULL), loc="topright",
                        inset=0.02, width=NULL, e=graphics::par("usr"),
                        bty=c("o", "n"), feature=NULL) {

  checkmate::assertClass(p, "SpatialPolygons")
  checkmate::assertCharacter(col, any.missing=FALSE, len=2)
  checkmate::assertList(main.label)
  checkmate::assertList(sub.label)
  checkmate::assertNumeric(inset, finite=TRUE, min.len=1, max.len=2)
  checkmate::assertNumber(width, finite=TRUE, null.ok=TRUE)
  checkmate::assertNumeric(e, finite=TRUE, len=4, null.ok=TRUE)
  bty <- match.arg(bty)
  checkmate::assertList(feature, types="list", any.missing=FALSE, null.ok=TRUE)

  op <- graphics::par(no.readonly=TRUE)
  on.exit(graphics::par(op))

  usr <- graphics::par("usr")

  if (is.null(e)) {
    ext <- raster::extent(p)
  } else {
    crds <- cbind(c(e[1:2], e[2:1], e[1]), c(rep(e[3], 2), rep(e[4], 2), e[3]))
    b <- sp::SpatialPolygons(list(sp::Polygons(list(sp::Polygon(crds)), "bbox")),
                             proj4string=raster::crs(p))
    if (length(rgeos::gIntersection(p, b, checkValidity=2L)) == 0)
    stop("user coordinates of the plotting region do not intersect polygon")
    ext <- raster::extent(rgeos::gUnion(p, b, checkValidity=2L))
  }

  if (is.null(width)) {
    dx  <- 0.2 * diff(usr[1:2])
  } else {
    dx <- width * (diff(usr[1:2]) / graphics::par("pin")[1])
  }
  dy <- dx * (diff(ext[3:4]) / diff(ext[1:2]))
  xy <- GetInsetLocation(dx, dy, loc=loc, inset=inset)
  graphics::rect(xy[1], xy[2], xy[1] + dx, xy[2] + dy, col="#FFFFFFE7", border=NA)

  plt <- c(graphics::grconvertX(c(xy[1], xy[1] + dx), "user", "nfc"),
           graphics::grconvertY(c(xy[2], xy[2] + dy), "user", "nfc"))
  graphics::par(plt=plt, bg="#FFFFFFCC", new=TRUE)

  xlim <- range(ext[1:2])
  ylim <- range(ext[3:4])
  graphics::plot.window(xlim=xlim, ylim=ylim)

  sp::plot(p, col=col[1], border=NA, lwd=0.25, add=TRUE)
  sp::plot(p, col=NA, border="#090909", lwd=0.25, add=TRUE)

  if (!is.null(e))
    sp::plot(b, col=col[2], border="#090909", lwd=0.25, add=TRUE)

  for (item in feature) do.call(item[[1]], item[-1])

  if (!is.na(main.label[[1]])) {
    x <- sp::coordinates(rgeos::gUnaryUnion(p, checkValidity=2L))[1, ]
    graphics::text(x[1], x[2], labels=main.label[[1]], adj=main.label$adj, cex=0.7, font=2)
  }
  if (!is.na(sub.label[[1]]) && !is.null(e)) {
    x <- sp::coordinates(rgeos::gUnaryUnion(b, checkValidity=2L))[1, ]
    graphics::text(x[1], x[2], labels=sub.label[[1]], adj=sub.label$adj, cex=0.6)
  }

  if (bty != "n") graphics::box(lwd=0.5)

  invisible()
}