#### Create landscapes ####
landscape <- terra::rast(landscapemetrics::landscape)
augusta_nlcd <- terra::rast(landscapemetrics::augusta_nlcd)
podlasie_ccilc <- terra::rast(landscapemetrics::podlasie_ccilc)
# landscape_ras <- raster::raster(landscape)
landscape_matrix <- terra::as.matrix(landscape, wide = TRUE)
landscape_stack <- c(landscape, landscape)
landscape_list <- list(landscape, landscape)
landscape_simple <- landscape
landscape_simple[terra::values(landscape_simple, mat = FALSE) == 2] <- 1
landscape_uniform <- landscape
terra::values(landscape_uniform) <- 1
landscape_diff_res <- terra::aggregate(landscape, fact = c(1,2))
landscape_NA <- landscape
terra::values(landscape_NA) <- NA
# augusta_nlcd_stars <- stars::st_as_stars(augusta_nlcd)
#### Create points ####
sample_points <- matrix(c(10, 5, 25, 15, 5, 25), ncol = 2, byrow = TRUE)
points_multi <- sf::st_multipoint(sample_points)
points_sf <- sf::st_sfc(points_multi, points_multi)
points_sfc <- sf::st_sf(geometry = sf::st_sfc(points_multi),
ID = 3)
points_terra <- terra::vect(sample_points)
# wrong plots
sample_points_wrong <- cbind(sample_points, 1)
# use polygons
poly_1 <- sf::st_polygon(list(cbind(c(2.5, 2.5, 17.5, 17.5, 2.5),
c(-2.5, 12.5, 12.5, -2.5, -2.5))), "p1")
poly_2 <- sf::st_polygon(list(cbind(c(7.5, 7.5, 23.5, 23.5, 7.5),
c(-7.5, 23.5, 23.5, -7.5, -7.5))), "p2")
sample_plots <- sf::st_sfc(poly_1, poly_2)
# sample_plots_sp <- as(sample_plots, "Spatial")
#### import and reshape FRAGSTATS v2.0 results ####
tol_cor <- 0.975
tol_rel <- 0.05
fragstats_patch <- landscapemetrics:::internal_data$fs_data$patch |>
tidyr::pivot_longer(cols = -c("LID", "PID", "TYPE"), names_to = "metric") |>
dplyr::mutate(TYPE = stringr::str_remove_all(TYPE, pattern = " "),
TYPE = as.integer(stringr::str_remove(TYPE, pattern = "cls_")),
metric = stringr::str_to_lower(metric))
fragstats_class <- landscapemetrics:::internal_data$fs_data$class |>
tidyr::pivot_longer(cols = -c("LID", "TYPE"), names_to = "metric") |>
dplyr::mutate(TYPE = stringr::str_remove_all(TYPE, pattern = " "),
TYPE = as.integer(stringr::str_remove(TYPE, pattern = "cls_")),
metric = stringr::str_to_lower(metric)) |>
dplyr::arrange(LID, TYPE)
fragstats_landscape <- landscapemetrics:::internal_data$fs_data$landscape |>
tidyr::pivot_longer(cols = -c("LID"), names_to = "metric") |>
dplyr::mutate(metric = stringr::str_to_lower(metric))
test_correlation <- function(obs, exp, tolerance) {
obs <- obs[!is.na(obs)]
exp <- exp[!is.na(exp)]
if (length(obs) != length(exp)) stop("Vectors have different length.")
cor_vals <- cor(sort(obs), sort(exp))
flag <- ifelse(test = cor_vals >= tolerance, yes = TRUE, no = FALSE)
if(!flag) warning(paste0("Correlation=", round(cor_vals, 4)))
return(flag)
}
test_relative <- function(obs, exp, tolerance){
# remove all NA values which could be present
obs <- obs[!is.na(obs)]
exp <- exp[!is.na(exp)]
if (length(obs) != length(exp)) stop("Vectors have different length.")
# calculate relative difference between elements
d <- abs((obs - exp) / exp)
# value will be NaN if divided by zero
d[obs == 0 & exp == 0] <- 0
# check if all values are below tolerance
flag <- all(d <= tolerance)
# throw warning if not
if(!flag) warning(paste0("Largest diff=", max(round(d * 100, 2)), "%"))
return(flag)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.