R/facet_geo.R

In hafen/geofacet: 'ggplot2' Faceting Utilities for Geographical Data

#' Arrange a sequence of geographical panels into a grid that preserves some geographical orientation
#'
#' @param facets passed to \code{\link[ggplot2]{facet_wrap}}
#' @param \ldots additional parameters passed to \code{\link[ggplot2]{facet_wrap}}
#' @param grid character vector of the grid layout to use (currently only "us_state_grid1" and "us_state_grid2" are available)
#' @param label an optional string denoting the name of a column in \code{grid} to use for facet labels. If NULL, the variable that best matches that in the data specified with \code{facets} will be used for the facet labels.
#' @param move_axes should axis labels and ticks be moved to the closest panel along the margins?
#' @example man-roxygen/ex-facet_geo.R
#' @export
facet_geo <- function(facets, ..., grid = "us_state_grid1", label = NULL, move_axes = TRUE) {
  ret <- c(list(facets = facets, grid = grid, label = label, move_axes = move_axes), list(...))
  class(ret) <- "facet_geo_spec"
  ret
}

#' @importFrom ggplot2 ggplot_add
#' @importFrom ggplot2 %+%
#' @export
ggplot_add.facet_geo_spec <- function(object, plot, object_name) {
  facet_col <- setdiff(unlist(lapply(object$facets, as.character)), c("~", "+"))
  if (length(facet_col) > 1) {
    message_nice("Multiple facet columns specified... only using '", facet_col[1], "'")
    facet_col <- facet_col[1]
  }

  move_axes <- object$move_axes
  object$move_axes <- NULL

  grd <- get_full_geo_grid(object$grid)
  object$grid <- NULL

  label_col <- NULL
  if (!is.null(object$label)) {
    if (object$label %in% names(grd)) {
      label_col <- object$label
    } else {
      message_nice("Note: the specified label = '", object$label,
        "' does not exist in the supplied grid and it will be ignored.")
    }
  }
  object$label <- NULL

  if (!is.null(object$ncol))
    message_nice("replacing user-specified 'ncol'")
  if (!is.null(object$nrow))
    message_nice("replacing user-specified 'nrow'")
  if (!is.null(object$drop))
    message_nice("replacing user-specified 'drop'")

  object$nrow <- max(grd$row)
  object$ncol <- max(grd$col)
  object$drop <- FALSE
  object$facets <- "facet_col" # we will create a new column "facet_col"
  # this is done below in get_full_geo_data()

  # update the data to layers if specified independent of global data
  other_data <- lapply(plot$layers, function(x) x$data)

  tmp <- get_full_geo_data(plot$data, grd, facet_col, label_col, other_data)
  plot$data <- tmp$dat
  for (ii in seq_along(plot$layers))
    plot$layers[[ii]]$data <- tmp$other_data[[ii]]
  grd <- tmp$grd

  plot <- plot %+% do.call(ggplot2::facet_wrap, object)
  attr(plot, "geofacet") <- list(
    grid = grd,
    move_axes = move_axes,
    scales = object$scales
  )

  class(plot) <- c("facet_geo", class(plot))
  return(plot)
}

#' Perform post-processing on a facet_geo ggplot object
#' 
#' @param x object of class 'facet_geo'
#' @export
get_geofacet_grob <- function(x) {
  if (!inherits(x, "facet_geo"))
    stop("'x' must be an object of class 'facet_geo'.",
      call. = FALSE)

  attrs <- attr(x, "geofacet")
  grd <- attrs$grid

  g <- ggplot2::ggplotGrob(x)

  extra_rgx <- NULL

  if (attrs$move_axes) {
    scls <- attrs$scales
    if (is.null(scls))
      scls <- "same"
    if (!scls %in% c("free", "free_x")) {
      # do x-axis stuff
      nc <- max(grd$col)
      nr <- max(grd$row)
      for (ii in seq_len(nc)) {
        idx <- which(!is.na(grd$label[grd$col == ii]))
        l1 <- paste0("axis-b-", ii, "-", nr)
        if (length(idx) > 0) {
          last <- max(idx)
          l2 <- paste0("axis-b-", ii, "-", last)
          g$layout[g$layout$name == l1, c("t", "b")] <-
            g$layout[g$layout$name == l2, c("t", "b")]
        } else {
          extra_rgx <- c(extra_rgx, l1)
        }
      }
    }
    if (!scls %in% c("free", "free_y")) {
      # do y-axis stuff
      for (ii in seq_len(max(grd$row))) {
        idx <- which(!is.na(grd$label[grd$row == ii]))
        l1 <- paste0("axis-l-", ii, "-1")
        if (length(idx) > 0) {
          first <- min(idx)
          l2 <- paste0("axis-l-", ii, "-", first)
          g$layout[g$layout$name == l1, c("l", "r")] <-
            g$layout[g$layout$name == l2, c("l", "r")]
        } else {
          extra_rgx <- c(extra_rgx, l1)
        }
      }
    }
  }

  idx <- which(is.na(grd$label))
  tmp <- setdiff(g$layout$name, c(grd$strip[idx], grd$panel[idx], extra_rgx))
  # rgx <- paste0("(^", paste(tmp, collapse = "$|^"), "$)")

  # TODO: look into using extra grid space to draw cartographic map
  # https://github.com/baptiste/gridextra/wiki/gtable
  # https://stackoverflow.com/questions/30532889/ggplot-overlay-two-plots

  g <- gf_gtable_filter(g, tmp, trim = FALSE)
  # g <- gtable::gtable_filter(g, rgx, trim = FALSE)
  g
}

#' Print geofaceted ggplot2 object
#'
#' @param x plot object
#' @param newpage draw new (empty) page first?
#' @param vp viewport to draw plot in
#' @param ... other arguments not used by this method
#' @importFrom gtable gtable_filter
#' @importFrom graphics plot
#' @export
print.facet_geo <- function(x, newpage = is.null(vp), vp = NULL, ...) {
  if (newpage) grid::grid.newpage()

  g <- get_geofacet_grob(x)

  grid::grid.draw(g)
}

#' Plot geofaceted ggplot2 object
#'
#' @param x plot object
#' @param ... ignored
#' @importFrom gtable gtable_filter
#' @importFrom graphics plot
#' @export
plot.facet_geo <- function(x, ...) {
  print.facet_geo(x, ...)
}

#' Plot a preview of a grid
#'
#' @param x a data frame containing a grid
#' @param label the column name in \code{x} that should be used for text labels in the grid plot
#' @param label_raw the column name in the optional SpatialPolygonsDataFrame attached to \code{x} that should be used for text labels in the raw geography plot
#' @param do_plot should the grid preview be plotted?
#' @export
#' @importFrom ggplot2 ggplot geom_rect geom_text aes xlim ylim
#' @importFrom gridExtra grid.arrange
#' @importFrom rlang .data
#' @examples
#' grid_preview(us_state_grid2)
#' grid_preview(eu_grid1, label = "name")
grid_preview <- function(x, label = NULL, label_raw = NULL, do_plot = TRUE) {

  if (!inherits(x, "geofacet_grid"))
    x <- get_grid(x)

  x <- check_grid(x)
  x$col <- factor(x$col, levels = seq_len(max(x$col)))
  x$row <- factor(x$row, levels = rev(seq_len(max(x$row))))
  if (is.null(label)) {
    nms <- names(x)
    nm <- nms[grepl("^code", nms)][1]
    x$txt <- x[[nm]]
  } else {
    x$txt <- x[[label]]
  }

  p <- ggplot2::ggplot(x, ggplot2::aes(.data$col, .data$row, label = .data$txt)) +
    ggplot2::geom_rect(
      xmin = as.numeric(x$col) - 0.5, xmax = as.numeric(x$col) + 0.5,
      ymin = as.numeric(x$row) - 0.5, ymax = as.numeric(x$row) + 0.5,
      fill = "gray", color = "#e1e1e1", alpha = 0.7) +
    ggplot2::ylim(levels(x$row)) +
    ggplot2::xlim(levels(x$col)) +
    ggplot2::geom_text()

  spdf <- attr(x, "spdf")
  if (!is.null(spdf) && inherits(spdf, "SpatialPolygonsDataFrame")) {
    if (is.null(label_raw)) {
      if (label %in% names(spdf@data)) {
        label_raw <- label
      } else {
        stop("Couldn't find a variable with name '", label, "' ",
          "in the SpatialPolygonsDataFrame attached to the grid object. ",
          "Please explicity provide a variable name to use for plotting ",
          "This data using the argument label_raw.")
      }
    }

    p2 <- plot_geo_raw(spdf, label = label_raw)
    p <- gridExtra::grid.arrange(p2, p, nrow = 1)
  } else {
    if (do_plot)
      plot(p)
  }
  invisible(p)
}

#' Interactively design a grid
#'
#' @param data A data frame containing a grid to start from or NULL if starting from scratch.
#' @param img An optional URL pointing to a reference image containing a geographic map of the entities in the grid.
#' @param label An optional column name to use as the label for plotting the original geography, if attached to \code{data}.
#' @param auto_img If the original geography is attached to \code{data}, should a plot of that be created and uploaded to the viewer?
#' @export
#' @importFrom grDevices png dev.off
#' @importFrom imguR upload_image
#' @examples
#' # edit aus_grid1
#' grid_design(data = aus_grid1, img = "http://www.john.chapman.name/Austral4.gif")
#' # start with a clean slate
#' grid_design()
#' # arrange the alphabet
#' grid_design(data.frame(code = letters))
grid_design <- function(data = NULL, img = NULL, label = "code", auto_img = TRUE) {

  if (!is.null(data)) {
    # clean out data
    for (vr in names(data)) {
      if (is.factor(data[[vr]]))
        data[[vr]] <- as.character(data[[vr]])
      if (is.character(data[[vr]])) {
        data[[vr]] <- gsub("\\\n", " ", data[[vr]])
        # other things to get rid of?
      }
    }

    rows <- c(paste(names(data), collapse = ","),
      apply(data, 1, function(x) paste(x, collapse = ",")))
    data_csv <- paste(rows, collapse = "\n")
  } else {
    data_csv <- ""
  }

  spdf <- attr(data, "spdf")
  if (auto_img && is.null(img) && !is.null(spdf) &&
    inherits(spdf, "SpatialPolygonsDataFrame")) {

    message("Attempting to create and upload image of original geography...")

    p <- plot_geo_raw(spdf, label = label)
    grDevices::png(tmpfile <- tempfile(), res = 150, width = 1000, height = 1000)
    print(p)
    grDevices::dev.off()
    # system2("open", tmpfile)
    res <- imguR::upload_image(tmpfile)
    img <- res$link
  }

  if (is.null(img))
    img <- ""

  url <- sprintf("https://hafen.github.io/grid-designer/#img=%s&data=%s", img, data_csv)

  if (Sys.getenv("GEOFACET_PKG_TESTING") == "") browseURL(URLencode(url))
}

#' Submit a grid to be included in the package
#'
#' @param x a data frame containing a grid
#' @param name proposed name of the grid (if not supplied, will be asked for interactively)
#' @param desc a description of the grid (if not supplied, will be asked for interactively)
#' @details This opens up a github issue for this package in the web browser with pre-populated content for adding a grid to the package.
#' @importFrom utils write.csv browseURL URLencode
#' @examples
#' \dontrun{
#' my_grid <- us_state_grid1
#' my_grid$col[my_grid$label == "WI"] <- 7
#' grid_submit(my_grid, name = "us_grid_tweak_wi",
#'   desc = "Modified us_state_grid1 to move WI over")
#' }
#' @export
grid_submit <- function(x, name = NULL, desc = NULL) {
  x <- check_grid(x)

  prompt_txt <- "The"
  if (is.null(name) || is.null(desc)) prompt_txt <- "After you answer a few questions below, the"

  message_nice(
    "The data for your proposed grid will be added ",
    "as an issue in this package's github reposotory. ",
    prompt_txt, " issue will open in your web browser ",
    "and after you make any desired edits, you need to click 'Submit new issue'.")
  message_nice(
    "If you do not have a github account, you will first be prompted to create one. ",
    "Your github username will be credited with the submission in the grid's docs.")

  if (is.null(name)) name <- readline("Proposed name of grid: ")
  if (is.null(desc)) desc <- readline("Description of grid: ")

  tc <- textConnection("foo", "w")
  utils::write.csv(x, tc, row.names = FALSE)
  dat_txt <- paste(textConnectionValue(tc), collapse = "\n")
  close(tc)

  body <- paste0(desc, "\n\n",
    "[[Note: To help streamline the process of adding this grid, ",
    "please replace this text with an image of a map for the region for reference. ",
    "Also, please check the ISO_3166-2 (https://en.wikipedia.org/wiki/ISO_3166-2) ",
    "codes if your grid uses countries or states/provinces. Finally, if you can ",
    "provide an example of your grid in action with a data set and sample code, ",
    "that would be great but is not required.]]",
    "\n\nGrid data:\n\n```\n", dat_txt, "\n```\n\n")

  url <- sprintf(
    "https://github.com/hafen/geofacet/issues/new?title=new grid: '%s'&body=%s",
    name,
    body
  )

  if (Sys.getenv("GEOFACET_PKG_TESTING") == "") browseURL(URLencode(url))
}

check_grid <- function(d) {
  nms <- names(d)
  if (! all(c("row", "col") %in% nms))
    stop("A custom grid must contain variables 'row' and 'col'", call. = FALSE)

  nms2 <- setdiff(nms, c("row", "col"))
  if (any(!grepl("^code|^name", nms2)))
    stop("Other than 'row' and 'col', variable names of a custom grid ",
      "must begin with 'code' or 'name'", call. = FALSE)

  idx <- which(sapply(d, is.factor))
  for (ii in idx)
    d[[ii]] <- as.character(d[[ii]])

  if (length(which(grepl("^code", nms2))) == 0)
    stop("A custom grid must have at least one column beginning with 'code'", call. = FALSE)
  if (length(which(grepl("^name", nms2))) == 0)
    stop("A custom grid must have at least one column beginning with 'name'", call. = FALSE)

  d$row <- as.integer(d$row)
  d$col <- as.integer(d$col)

  if (anyNA(d, recursive = TRUE))
    stop("A custom grid cannot have any missing values", call. = FALSE)

  if (min(d$row) < 1)
    stop("A custom grid must have positive integer-valued 'row' values", call. = FALSE)

  if (min(d$col) < 1)
    stop("A custom grid must have positive integer-valued 'col' values", call. = FALSE)

  if (any(duplicated(d[, c("row", "col")])))
    stop("A custom grid must have unique row/column locations for each entry", call. = FALSE)

  d
}

#' Get a list of valid grid names
#' @export
get_grid_names <- function() {
  message("Note: More grids are available by name as listed here: ",
    "https://raw.githubusercontent.com/hafen/grid-designer/master/grid_list.json")
  .valid_grids
}

get_grid <- function(grid) {
  if (is.character(grid)) {
    if (grid %in% .valid_grids) {
      grd <- get(grid)
    } else {
      message("grid '", grid, "' not found in package, checking online...")
      url <- sprintf("https://raw.githubusercontent.com/hafen/grid-designer/master/grids/%s.csv",
        grid)

      tmp <- suppressWarnings(try(
        utils::read.csv(url, stringsAsFactors = FALSE, nrows = 1),
        silent = TRUE))
      if (inherits(tmp, "try-error"))
        stop("grid '", grid, "' not recognized...")
      # all columns other than "row" and "col" will be strings (names and codes)
      cls <- ifelse(names(tmp) %in% c("row", "col"), "integer", "character")
      # use read.csv simply because it means one less dependency...
      grd <- utils::read.csv(url, colClasses = cls,
          stringsAsFactors = FALSE,
          na.strings = NULL) # grid cannot have NAs
    }
  } else if (inherits(grid, "data.frame")) {
    grd <- check_grid(grid)
    if (!inherits(grid, "geofacet_grid"))
      message_nice("Note: You provided a user-specified grid. ",
        "If this is a generally-useful grid, please consider submitting it ",
        "to become a part of the geofacet package. You can do this easily by ",
        "calling:\ngrid_submit(__grid_df_name__)")
  } else {
    stop("grid not recognized...")
  }
  grd
}

#' @importFrom utils read.csv
get_full_geo_grid <- function(grid) {

  grd <- get_grid(grid)

  nr <- max(grd$row)
  nc <- max(grd$col)
  gd <- expand.grid(col = seq_len(nc), row = seq_len(nr))

  grd <- merge(grd, gd, all.y = TRUE)
  grd <- grd[order(grd$row, grd$col), ]

  grd$col2 <- as.vector(t(matrix(grd$col, nrow = nr)))
  grd$row2 <- as.vector(t(matrix(grd$row, nrow = nr)))
  grd$panel <- paste0("panel-", grd$col2, "-", grd$row2)
  grd$strip <- paste0("strip-t-", grd$col, "-", grd$row)

  grd
}

get_full_geo_data <- function(d, grd, facet_col, label_col = NULL, other_data) {
  # check to make sure facet_col data matches that of grd
  ul <- unique(d[[facet_col]])
  set_nms <- c("row", "col", "row2", "col2", "panel", "strip")
  nms <- setdiff(names(grd), set_nms)
  uldifs <- lapply(nms, function(x) setdiff(ul, grd[[x]]))
  nn <- unlist(lapply(uldifs, length))
  match_idx <- which.min(nn)
  uldif <- uldifs[[match_idx]]
  grd$label <- grd[[nms[match_idx]]]
  if (is.null(label_col))
    label_col <- nms[match_idx]

  if (length(uldif) == length(ul)) {
    stop("The values of the specified facet_geo column '", facet_col,
      "' do not match any column of the specified grid.", call. = FALSE)
  } else if (length(uldif) > 0) {
    message_nice("Some values in the specified facet_geo column '", facet_col,
      "' do not match the '", nms[match_idx],
      "' column of the specified grid and will be removed: ",
      paste(uldif, collapse = ", "))
    d <- d[!d[[facet_col]] %in% uldif, ]
  }

  conv_idx <- match(d[[facet_col]], grd$label)
  d$facet_col <- grd[[label_col]][conv_idx]

  # create unique dummy levels (incrementing whitespace) for empty panels
  tmp <- grd[[label_col]]
  na_idx <- which(is.na(tmp))
  tmp[na_idx] <- sapply(seq_along(na_idx), function(a) paste0(rep(" ", a), collapse = ""))

  for (ii in seq_along(other_data)) {
    if (!inherits(other_data[[ii]], "waiver") && facet_col %in% names(other_data[[ii]])) {
      conv_idx <- match(other_data[[ii]][[facet_col]], grd$label)
      other_data[[ii]]$facet_col <- grd[[label_col]][conv_idx]
      other_data[[ii]]$facet_col <- factor(other_data[[ii]]$facet_col, levels = tmp)
    }
  }

  d$facet_col <- factor(d$facet_col, levels = tmp)

  # need to update grd to have the right column
  list(dat = d, grd = grd, other_data = other_data)
}