R/show_shareplot.R

In landscapetools: Landscape Utility Toolbox

#' show_shareplot
#'
#' Plot the landscape share in subsequential buffers around a/multiple point(s) of interest
#'
#' @param landscape Raster* object
#' @param points Point(s) represented by a two-column matrix or data.frame; SpatialPoints*; SpatialPolygons*; SpatialLines; Extent; a numeric vector representing cell numbers; or sf* POINT object
#' @param buffer_width Buffer widths in which landscape share is measured.
#' By default, it is a vector of buffer sizes, if `max_width = NULL`.
#' If a value if provided for `max_width`, a series of buffer sizes is created,
#' from `buffer_width` to `max_width`, with increases of `buffer_width`.
#' @param max_width Max distance to which buffer_width is summed up; the x axis in the plot
#' @param multibuffer_df `data.frame` with landscape share or a function from it already extracted, such as
#' through the [landscapetools::util_extract_multibuffer()] function. If given, the other arguments
#' (`landscape`, `points`, `buffer_width`, `max_width`) are ignored. Default is NULL.
#' @param return_df Logical value indicating if a tibble with the underlying data should be returned
#'
#' @return ggplot2 Object
#'
#' @examples
#' # Minimal runnable example with a pre-built multi-buffer data frame
#' df <- data.frame(
#'   id = "Point ID: 1",
#'   layer = factor(rep(1:3, each = 2)),
#'   freq = c(10, 15, 20, 25, 5, 10),
#'   buffer = rep(c(10, 20), 3)
#' )
#' show_shareplot(multibuffer_df = df)
#'
#' \donttest{
#' # use a smaller aggregated landscape for the longer-running examples below
#' small_landscape <- raster::aggregate(classified_landscape, fact = 5)
#'
#' # create single point
#' new_point <- matrix(c(75, 75), ncol = 2)
#'
#' # show landscape and point of interest
#' show_landscape(small_landscape, discrete = TRUE) +
#' ggplot2::geom_point(data = data.frame(x = new_point[, 1], y = new_point[, 2]),
#'                     ggplot2::aes(x = x, y = y),
#'                     col = "grey", size = 3)
#'
#' # show single point share
#' show_shareplot(small_landscape, new_point, 10, 30)
#'
#' # show multiple points share
#' new_points <- matrix(c(75, 110, 75, 30), ncol = 2)
#' show_shareplot(small_landscape, new_points, 10, 30)
#'
#' # irregular buffer widths
#' show_shareplot(small_landscape, new_points, c(10, 30))
#'
#' # get data frame with results back
#' result <- show_shareplot(small_landscape, new_points, 10, 30, return_df = TRUE)
#' result$share_df
#'
#' # use the output from util_extract_multibuffer
#' df <- util_extract_multibuffer(small_landscape, new_points, 10, 30)
#' show_shareplot(multibuffer_df = df)
#' }
#'
#' @aliases show_shareplot
#' @rdname show_shareplot
#'
#' @export
show_shareplot <- function(
  landscape,
  points,
  buffer_width,
  max_width = NULL,
  multibuffer_df = NULL,
  return_df = FALSE
) {
  UseMethod("show_shareplot")
}

#' @name show_shareplot
#' @export
show_shareplot <- function(
  landscape,
  points,
  buffer_width,
  max_width = NULL,
  multibuffer_df = NULL,
  return_df = FALSE
) {
  # extract data around points
  if (is.null(multibuffer_df)) {
    result <- util_extract_multibuffer(
      landscape,
      points,
      buffer_width = buffer_width,
      max_width = max_width,
      point_id_text = TRUE
    )
  } else {
    result <- multibuffer_df
    ### Here we need to check the type of variable. It the count of cells if given, we go on normally.
    ### If a function is calculated (through the use of `fun` argument) in the util_extract_multibuffer,
    ### though, maybe a linear plot should be used - it is not a landscape share anymore.
    ### Or should we create a new show_metric function for that?
  }

  # construct plot
  p1 <- ggplot2::ggplot(
    result,
    ggplot2::aes(buffer, freq, group = layer, fill = layer)
  ) +
    ggplot2::geom_area(position = "fill") +
    ggplot2::facet_wrap(~id) +
    # ggplot2::expand_limits() +
    ggplot2::scale_y_continuous(
      name = "Shared proportion of landcover classes (%)",
      expand = c(0.01, 0.01),
      labels = function(x) paste0(x * 100)
    ) +
    ggplot2::scale_x_continuous(expand = c(0.01, 0.01)) +
    ggplot2::xlab("Distance (km)") +
    ggplot2::scale_fill_viridis_d() +
    ggplot2::theme(
      legend.background = ggplot2::element_blank(),
      legend.text = ggplot2::element_text(size = 8),
      legend.title = ggplot2::element_text(size = 10),
      plot.margin = ggplot2::unit(c(0, 0, 0, 0), "lines"),
      strip.text = ggplot2::element_text(hjust = 0, size = 12, face = "plain"),
      strip.background = ggplot2::element_rect(fill = "grey80"),
      panel.spacing = grid::unit(2, "lines"),
      axis.text.x = ggplot2::element_text(
        size = 11.5,
        margin = ggplot2::margin(t = 0)
      ),
      axis.text.y = ggplot2::element_text(
        size = 11.5,
        margin = ggplot2::margin(r = 0)
      ),
      axis.title = ggplot2::element_text(size = 9),
      axis.title.x = ggplot2::element_text(
        hjust = switch(
          tolower(substr("rt", 1, 1)),
          b = 0,
          l = 0,
          m = 0.5,
          c = 0.5,
          r = 1,
          t = 1
        ),
        size = 12,
        face = "plain"
      ),
      axis.title.y = ggplot2::element_text(
        hjust = switch(
          tolower(substr("rt", 2, 2)),
          b = 0,
          l = 0,
          m = 0.5,
          c = 0.5,
          r = 1,
          t = 1
        ),
        size = 13,
        face = "plain"
      ),
      axis.title.y.right = ggplot2::element_text(
        hjust = switch(
          tolower(substr("rt", 2, 2)),
          b = 0,
          l = 0,
          m = 0.5,
          c = 0.5,
          r = 1,
          t = 1
        ),
        size = 12,
        angle = 90,
        face = "plain"
      )
    )

  if (isTRUE(return_df)) {
    return(list(share_plot = p1, share_df = result))
  } else {
    return(p1)
  }
}

# NOT IN USE ANYMORE
.share <- function(buffer, x, y) {
  df <- tibble::new_tibble(as.data.frame(raster::extract(
    x = x,
    y = y,
    buffer = buffer,
    df = TRUE
  )))
  df <- tibble::new_tibble(as.data.frame(table(df)))
  df$buffer <- buffer
  names(df) <- c("id", "layer", "freq", "buffer")
  df$id <- paste("Point ID:", df$id, sep = " ")
  df
}

# NOT IN USE ANYMORE
.extract_multibuffer <- function(x, y, buffer_width, max_width) {
  buffers <- seq(buffer_width, max_width, buffer_width)
  df <- do.call(rbind, lapply(buffers, .share, x, y))
}