tests/testthat/helper-testthat.R

In landscapemetrics: Landscape Metrics for Categorical Map Patterns

#### 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)
}