#' Show patches
#'
#' @description Show patches
#'
#' @param landscape *Raster object
#' @param class How to show the labeled patches: "global" (single map), "all" (every class as facet), or a vector with the specific classes one wants to show (every selected class as facet).
#' @param directions The number of directions in which patches should be
#' connected: 4 (rook's case) or 8 (queen's case).
#' @param labels Logical flag indicating whether to print or not to print patch labels.
#' @param nrow,ncol Number of rows and columns for the facet.
#'
#' @details The functions plots the landscape with the patches labeled with the
#' corresponding patch id.
#'
#' @return ggplot
#'
#' @examples
#' landscape <- terra::rast(landscapemetrics::landscape)
#'
#' show_patches(landscape)
#' show_patches(landscape, class = c(1, 2))
#' show_patches(landscape, class = 3, labels = FALSE)
#'
#' @export
show_patches <- function(landscape, class = "global", directions = 8,
labels = FALSE, nrow = NULL, ncol = NULL) {
landscape <- landscape_as_list(landscape)
result <- lapply(X = landscape,
FUN = show_patches_internal,
class = class,
directions = directions,
labels = labels,
nrow = nrow,
ncol = ncol)
names(result) <- paste0("layer_", 1:length(result))
return(result)
}
show_patches_internal <- function(landscape, class, directions, labels, nrow, ncol) {
if (any(!(class %in% c("all", "global")))) {
if (!any(class %in% unique(terra::values(landscape, mat = FALSE)))) {
stop("'class' must at least contain one value of a class contained in the landscape.", call. = FALSE)
}
}
if (length(class) > 1 & any(class %in% c("all", "global"))) {
warning("'global' and 'all' can't be combined with any other class-argument.", call. = FALSE)
}
landscape_labeled <- get_patches(landscape, directions = directions)[[1]]
if (any(class == "global")) {
patches_tibble <- terra::as.data.frame(sum(terra::rast(landscape_labeled),
na.rm = TRUE), xy = TRUE)
names(patches_tibble) <- c("x", "y", "value")
patches_tibble$value <- replace(patches_tibble$value, patches_tibble$value == 0, NA)
if (labels) {
patches_tibble$labels <- patches_tibble$value
}
if (!labels) {
patches_tibble$labels <- NA
}
patches_tibble$class <- "global"
}
if (any(class != "global")) {
patches_tibble <- lapply(X = seq_along(landscape_labeled), FUN = function(i){
names(landscape_labeled[[i]]) <- "value"
x <- terra::as.data.frame(landscape_labeled[[i]], xy = TRUE)
x$class <- names(landscape_labeled[i])
return(x)}
)
patches_tibble <- do.call(rbind, patches_tibble)
if (any(!(class %in% c("all", "global")))) {
class_index <- which(patches_tibble$class %in% paste0("class_", class))
patches_tibble <- patches_tibble[class_index, ]
}
if (labels) {
patches_tibble$labels <- patches_tibble$value
}
if (!labels) {
patches_tibble$labels <- NA
}
}
# harmonize column order
patches_tibble <- patches_tibble[, c("x", "y", "class", "value", "labels")]
# sample to only show one value here
id_temp <- sapply(split(patches_tibble, patches_tibble$labels), function(x) {
as.numeric(rownames(x[sample(nrow(x), 1), ]))
})
# replace all not sampled to NA
patches_tibble[!as.numeric(rownames(patches_tibble)) %in% id_temp, 5] <- NA
plot <- ggplot2::ggplot(patches_tibble, ggplot2::aes(x, y)) +
ggplot2::coord_fixed() +
ggplot2::geom_raster(ggplot2::aes(fill = factor(value))) +
ggplot2::geom_text(ggplot2::aes(label = labels), color = "white", na.rm = TRUE) +
ggplot2::scale_fill_viridis_d(option = "F", na.value = "grey85") +
ggplot2::facet_wrap(~class, nrow = nrow, ncol = ncol) +
ggplot2::scale_x_continuous(expand = c(0, 0)) +
ggplot2::scale_y_continuous(expand = c(0, 0)) +
ggplot2::guides(fill = "none") +
ggplot2::labs(titel = NULL, x = NULL, y = NULL) +
ggplot2::theme(
axis.title = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.text = ggplot2::element_blank(),
panel.grid = ggplot2::element_blank(),
axis.line = ggplot2::element_blank(),
strip.background = ggplot2::element_rect(fill = "grey80"),
strip.text = ggplot2::element_text(hjust = 0),
plot.margin = ggplot2::unit(c(0, 0, 0, 0), "lines"))
return(plot)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.