diff --git a/DESCRIPTION b/DESCRIPTION index 3ebf18287..5445e86ab 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: landscapemetrics Title: Landscape Metrics for Categorical Map Patterns -Version: 2.0.0 +Version: 2.1.0 Authors@R: c(person("Maximilian H.K.", "Hesselbarth", role = c("aut", "cre"), email = "mhk.hesselbarth@gmail.com", diff --git a/NAMESPACE b/NAMESPACE index 0aaacbc7c..65b036d38 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,11 +15,17 @@ export(construct_buffer) export(data_info) export(extract_lsm) export(get_adjacencies) +export(get_area_patches) export(get_boundaries) export(get_centroids) export(get_circumscribingcircle) +export(get_class_patches) +export(get_complexity) +export(get_enn_patch) export(get_nearestneighbour) export(get_patches) +export(get_perimeter_patch) +export(get_points) export(get_unique_values) export(landscape_as_list) export(list_lsm) @@ -160,6 +166,7 @@ export(matrix_to_raster) export(options_landscapemetrics) export(pad_raster) export(points_as_mat) +export(prepare_extras) export(proj_info) export(raster_to_points) export(rcpp_get_nearest_neighbor) diff --git a/NEWS.md b/NEWS.md index 684c5efde..b74ac25d4 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,30 @@ +# landscapemetrics 2.1.0 +* Improvements + * Many performance improvements. Most visible are in + `calculate_lsm` (all metrics: more than 5 times faster with 70% less memory + allocation for `augusta_nlcd`; larger increases were found for smaller data) + and `window_lsm` (a single metric: more than 6 times faster for `augusta_nlcd`; + larger increases were found for smaller data) + * Some performance improvements are related to the new "extras" mechanism, in which several objects + are precalculated in `calculate_lsm` + * Creates an internal `extras_df` object that lists which extras are needed by + each metric + * Replaces the use of `tibble::tibble()` with `tibble::new_tibble(list())` in most functions. + This change is partially responsible for improvements of the `window_lsm` speed + * Replaces `raster_to_points` with `get_points` in several places. + The `get_points` function is based on the column and row numbers multiplied by + the resolution, not actual coordinates. + * Replaces `table` with (faster) `tabulate` in `lsm_p_core` +* New functions + * Adds a few internal helper functions and documents them, including `prepare_extras`, + `get_area_patches`, `get_class_patches`, `get_complexity`, `get_enn_patch`, + `get_points`, and `get_perimeter_patch` +* Bugfixes + * Fixes `window_lsm` behaviour for situations with NAs values and non-square windows +* Various + * Fixes several typos and improves documentation in many places + * Uses object references in most rcpp functions + # landscapemetrics 2.0.0 * Improvements * `terra` and `sf` instead of `raster` and `sp` as underlying frameworks @@ -8,10 +35,10 @@ * Bugfixes * There was a bug introduced previously in the calculation of SHEI * `extract_lsm` returned an no-needed warning message - * Minor bug in shape index fixed + * The shape index now follows exactly the definition of the FRAGSTATS manual * Minor bug in clumpy index fixed * Various - * Updated FRAGSTATS reference (thanks to Oto Kaláb @kalab-oto) + * Updated FRAGSTATS reference (thanks to Oto Kaláb @kalab-oto) * Update FRAGSTATS tests # landscapemetrics 1.5.6 diff --git a/R/calculate_lsm.R b/R/calculate_lsm.R index baa572119..3fc16161d 100644 --- a/R/calculate_lsm.R +++ b/R/calculate_lsm.R @@ -151,6 +151,7 @@ calculate_lsm_internal <- function(landscape, call. = FALSE) } } + landscape <- terra::as.int(landscape) # get name of metrics metrics <- list_lsm(level = level, metric = metric, name = name, @@ -162,18 +163,14 @@ calculate_lsm_internal <- function(landscape, # how many metrics need to be calculated? number_metrics <- length(metrics_calc) - # get coordinates of cells - points <- raster_to_points(landscape)[, 2:4] - - # resolution of original raster + # prepare extras resolution <- terra::res(landscape) - - # convert to matrix landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape, directions, neighbourhood, + ordered, base, resolution) result <- do.call(rbind, lapply(seq_along(metrics_calc), FUN = function(current_metric) { - - # print progess using the non-internal name + # print progress using the non-internal name if (progress) { cat("\r> Progress metrics: ", current_metric, "/", number_metrics) } @@ -185,25 +182,31 @@ calculate_lsm_internal <- function(landscape, arguments <- names(formals(foo)) # run function - tryCatch(do.call(what = foo, + #start_time = Sys.time() + resultint <- tryCatch(do.call(what = foo, args = mget(arguments, envir = parent.env(environment()))), error = function(e){ message("") stop(e)}) + + #end_time = Sys.time() + #resultint$time <- as.numeric(difftime(end_time, start_time, units = "secs")) + resultint }) ) if (full_name == TRUE) { col_ordering <- c("level", "class", "id", "metric", "value", - "name", "type", "function_name") + "name", "type", "function_name"#,"time" + ) result <- merge(x = result, y = lsm_abbreviations_names, by = c("level", "metric"), all.x = TRUE, sort = FALSE, suffixes = c("", "")) - result <- tibble::as_tibble(result[,col_ordering]) + result <- tibble::as_tibble(result[, col_ordering]) } if (progress) { diff --git a/R/construct_buffer.R b/R/construct_buffer.R index d2a44f149..97be7b3a9 100644 --- a/R/construct_buffer.R +++ b/R/construct_buffer.R @@ -2,15 +2,15 @@ #' #' @description Internal function to construct plot area around coordinates #' -#' @param coords SpatialPoints or 2-column matrix with coordinates of sample points +#' @param coords SpatVector, sf object or 2-column matrix with coordinates of sample points #' @param shape String specifying plot shape. Either "circle" or "square" #' @param size Size of sample plot. Equals the radius for circles or the -#' side-length for squares in mapunits -#' @param return_vec If true, vector objects are returned. +#' side-length for squares in map units +#' @param return_vec If TRUE, vector objects are returned. #' @param verbose Print warning messages. #' #' @return -#' matrix or sf objecct +#' matrix or SpatVector object #' #' @examples #' coords <- matrix(c(10, 5, 25, 15, 5, 25), ncol = 2, byrow = TRUE) diff --git a/R/data.R b/R/data.R index 24e19a32e..38693fb63 100644 --- a/R/data.R +++ b/R/data.R @@ -26,7 +26,6 @@ #' @source http://maps.elie.ucl.ac.be/CCI/viewer/ "podlasie_ccilc" - #' Tibble of abbreviations coming from FRAGSTATS #' #' A single tibble for every abbreviation of every metric that is diff --git a/R/data_info.R b/R/data_info.R index 24fa11b42..2aad5380d 100644 --- a/R/data_info.R +++ b/R/data_info.R @@ -39,5 +39,5 @@ data_info <- function(landscape){ yes = "integer", no = "non-integer")) - tibble::tibble(class = class, n_classes = length(landscape_values)) + tibble::new_tibble(list(class = class, n_classes = length(landscape_values))) } diff --git a/R/get_boundaries.R b/R/get_boundaries.R index a241acd6f..e25c01cfa 100644 --- a/R/get_boundaries.R +++ b/R/get_boundaries.R @@ -17,7 +17,7 @@ #' cell or a cell with a different value than itself. Non-boundary cells only #' neighbour cells with the same value than themself. #' -#' @return List with RasterLayer or matrix +#' @return List with SpatRaster or matrix #' #' @examples #' landscape <- terra::rast(landscapemetrics::landscape) diff --git a/R/get_centroids.R b/R/get_centroids.R index cfe3fbc58..d500e50c2 100644 --- a/R/get_centroids.R +++ b/R/get_centroids.R @@ -51,7 +51,7 @@ get_centroids <- function(landscape, directions = 8, cell_center = FALSE, if (return_vec) { - result <- terra::vect(result, geom=c("x", "y"), crs = crs) + result <- terra::vect(result, geom = c("x", "y"), crs = crs) } return(result) @@ -73,14 +73,14 @@ get_centroids_calc <- function(landscape, directions, cell_center, verbose) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch"), class = as.integer(NA), id = as.integer(NA), y = as.double(NA), y = as.double(NA))) } - # get uniuqe class id + # get unique class id classes <- get_unique_values_int(landscape, verbose = verbose) centroid <- do.call(rbind, @@ -100,11 +100,11 @@ get_centroids_calc <- function(landscape, directions, cell_center, verbose) { # set ID from class ID to unique patch ID points[, 3] <- landscape_labeled[!is.na(landscape_labeled)] - # # conver to tibble + # # convert to tibble points <- stats::setNames(object = data.frame(points), nm = c("x", "y", "id")) - # calcuale the centroid of each patch (mean of all coords) + # calculate the centroid of each patch (mean of all coords) centroid_temp <- stats::aggregate(points[, c(1, 2)], by = list(id = points[, 3]), FUN = mean) @@ -159,9 +159,9 @@ get_centroids_calc <- function(landscape, directions, cell_center, verbose) { } } - tibble::tibble(level = "patch", + tibble::new_tibble(list(level = rep("patch", nrow(centroid)), class = as.integer(centroid$class), - id = as.integer(id), + id = as.integer(centroid$id), x = as.double(centroid$x), - y = as.double(centroid$y)) + y = as.double(centroid$y))) } diff --git a/R/get_circumscribingcircle.R b/R/get_circumscribingcircle.R index 41e8821ab..870644dab 100644 --- a/R/get_circumscribingcircle.R +++ b/R/get_circumscribingcircle.R @@ -100,12 +100,12 @@ get_circumscribingcircle_calc <- function(landscape, level, directions) { ) # resulting tibble - circle <- tibble::tibble(level = "patch", + circle <- tibble::new_tibble(list(level = rep("patch", nrow(circle)), class = as.integer(circle$class), id = as.integer(seq_len(nrow(circle))), value = circle$circle_diameter, center_x = circle$circle_center_x, - center_y = circle$circle_center_y) + center_y = circle$circle_center_y)) } # class level (no labeling) @@ -115,12 +115,12 @@ get_circumscribingcircle_calc <- function(landscape, level, directions) { circle_class <- rcpp_get_circle(landscape, resolution_xy = resolution[1]) # resulting tibble - circle <- tibble::tibble(level = "class", + circle <- tibble::new_tibble(list(level = rep("class", nrow(circle_class)), class = as.integer(circle_class$patch_id), - id = as.integer(NA), + id = rep(as.integer(NA), nrow(circle_class)), value = circle_class$circle_diameter, center_x = circle_class$circle_center_x, - center_y = circle_class$circle_center_y) + center_y = circle_class$circle_center_y)) } # shift the coordinates to the original coordinate system diff --git a/R/get_nearestneighbour.R b/R/get_nearestneighbour.R index a724ff958..191cd8c23 100644 --- a/R/get_nearestneighbour.R +++ b/R/get_nearestneighbour.R @@ -46,14 +46,16 @@ get_nearestneighbour <- function(landscape, return_id = FALSE) { } -get_nearestneighbour_calc <- function(landscape, return_id, +get_nearestneighbour_calc <- function(landscape, return_id, resolution, points = NULL) { + if (missing(resolution)) resolution <- terra::res(landscape) + # convert to matrix if (!inherits(x = landscape, what = "matrix")) { # get coordinates and values of all cells - points <- raster_to_points(landscape)[, 2:4] + points <- get_points(landscape, resolution = resolution) # convert to matrix landscape <- terra::as.matrix(landscape, wide = TRUE) @@ -79,12 +81,12 @@ get_nearestneighbour_calc <- function(landscape, return_id, num <- seq_along(ord) rank <- match(num, ord) - res <- rcpp_get_nearest_neighbor(terra::as.matrix(points, wide= TRUE)[ord, ]) + res <- rcpp_get_nearest_neighbor(as.matrix(points)[ord, ]) - min_dist <- tibble::tibble(cell = num, + min_dist <- tibble::new_tibble(list(cell = num, dist = res[rank, 1], id_focal = points[, 3], - id_neighbour = res[rank, 2]) + id_neighbour = res[rank, 2])) min_dist_aggr <- stats::setNames(stats::aggregate(x = min_dist$dist, by = list(min_dist$id_focal), diff --git a/R/get_patches.R b/R/get_patches.R index 18a429218..211977b98 100644 --- a/R/get_patches.R +++ b/R/get_patches.R @@ -31,7 +31,7 @@ #' algorithm based on immersion simulations. IEEE Transactions on Pattern #' Analysis and Machine Intelligence. 13 (6), 583-598 #' -#' @return List +#' @return List of SpatRaster #' #' @examples #' landscape <- terra::rast(landscapemetrics::landscape) diff --git a/R/get_unique_values.R b/R/get_unique_values.R index 76d970ef4..4610c9e90 100644 --- a/R/get_unique_values.R +++ b/R/get_unique_values.R @@ -56,7 +56,7 @@ get_unique_values <- function(x, simplify = FALSE, verbose = TRUE) { return(result) } -get_unique_values_int <- function(landscape, verbose) { +get_unique_values_int <- function(landscape, verbose = FALSE) { if (inherits(x = landscape, what = "SpatRaster")) { diff --git a/R/landscape_as_list.R b/R/landscape_as_list.R index a70f7248c..d31321cf2 100644 --- a/R/landscape_as_list.R +++ b/R/landscape_as_list.R @@ -21,7 +21,6 @@ landscape_as_list <- function(landscape) UseMethod("landscape_as_list") #' @name landscape_as_list #' @export landscape_as_list.SpatRaster <- function(landscape) { - landscape <- terra::as.list(landscape) return(landscape) diff --git a/R/landscapemetrics-package.R b/R/landscapemetrics-package.R index 0b2f80f5e..55df97dd2 100644 --- a/R/landscapemetrics-package.R +++ b/R/landscapemetrics-package.R @@ -15,4 +15,4 @@ #' @keywords internal "_PACKAGE" -globalVariables(c("label", "lsm_abbreviations_names", "metric_1", "metric_2", "value", "values", "x", "y")) +globalVariables(c(".data", "label", "lsm_abbreviations_names", "metric_1", "metric_2", "value", "values", "x", "y")) diff --git a/R/lsm_c_ai.R b/R/lsm_c_ai.R index 7d8a965d0..b6135edf3 100644 --- a/R/lsm_c_ai.R +++ b/R/lsm_c_ai.R @@ -54,20 +54,21 @@ lsm_c_ai <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_ai_calc <- function(landscape) { +lsm_c_ai_calc <- function(landscape, extras = NULL) { - # convert to raster to matrix - if (!inherits(x = landscape, what = "matrix")) { + if (is.null(extras)){ + metrics <- "lsm_c_ai" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "ai", - value = as.double(NA))) + value = as.double(NA)))) } # get coocurrence matrix of like_adjacencies @@ -75,7 +76,7 @@ lsm_c_ai_calc <- function(landscape) { directions = as.matrix(4)) / 2 # get number of cells each class - cells_class <- rcpp_get_composition_vector(landscape) + cells_class <- extras$composition_vector # calculate maximum adjacencies n <- trunc(sqrt(cells_class)) @@ -96,9 +97,9 @@ lsm_c_ai_calc <- function(landscape) { # max_adj can be zero if only one cell is present; set to NA ai[is.nan(ai)] <- NA - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", length(ai)), class = as.integer(names(like_adjacencies)), - id = as.integer(NA), - metric = "ai", - value = as.double(ai))) + id = rep(as.integer(NA), length(ai)), + metric = rep("ai", length(ai)), + value = as.double(ai)))) } diff --git a/R/lsm_c_area_cv.R b/R/lsm_c_area_cv.R index 5dc5e8df2..1fbac9b15 100644 --- a/R/lsm_c_area_cv.R +++ b/R/lsm_c_area_cv.R @@ -58,29 +58,30 @@ lsm_c_area_cv <- function(landscape, directions = 8) { } -lsm_c_area_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_area_cv_calc <- function(landscape, directions, resolution, extras = NULL){ # get area of patches area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "area_cv", - value = as.double(NA))) + value = as.double(NA)))) } # calculate cv area_cv <- stats::aggregate(area[, 5], by = area[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(area_cv)), class = as.integer(area_cv$class), - id = as.integer(NA), - metric = "area_cv", - value = as.double(area_cv$value))) + id = rep(as.integer(NA), nrow(area_cv)), + metric = rep("area_cv", nrow(area_cv)), + value = as.double(area_cv$value)))) } diff --git a/R/lsm_c_area_mn.R b/R/lsm_c_area_mn.R index b44c62927..bd659c5f9 100644 --- a/R/lsm_c_area_mn.R +++ b/R/lsm_c_area_mn.R @@ -59,28 +59,29 @@ lsm_c_area_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_area_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_area_mn_calc <- function(landscape, directions, resolution, extras = NULL){ # get area of patches area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "area_mn", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mean area_mean <- stats::aggregate(area[, 5], by = area[, 2], FUN = mean) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(area_mean)), class = as.integer(area_mean$class), - id = as.integer(NA), - metric = "area_mn", - value = as.double(area_mean$value))) + id = rep(as.integer(NA), nrow(area_mean)), + metric = rep("area_mn", nrow(area_mean)), + value = as.double(area_mean$value)))) } diff --git a/R/lsm_c_area_sd.R b/R/lsm_c_area_sd.R index 575814662..60377f3f4 100644 --- a/R/lsm_c_area_sd.R +++ b/R/lsm_c_area_sd.R @@ -59,28 +59,29 @@ lsm_c_area_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_area_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_area_sd_calc <- function(landscape, directions, resolution, extras = NULL){ # get area of patches area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "area_sd", - value = as.double(NA))) + value = as.double(NA)))) } # calculate sd area_sd <- stats::aggregate(area[, 5], by = area[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(area_sd)), class = as.integer(area_sd$class), - id = as.integer(NA), - metric = "area_sd", - value = as.double(area_sd$value))) + id = rep(as.integer(NA), nrow(area_sd)), + metric = rep("area_sd", nrow(area_sd)), + value = as.double(area_sd$value)))) } diff --git a/R/lsm_c_ca.R b/R/lsm_c_ca.R index da66b0ac7..1ab3d748d 100644 --- a/R/lsm_c_ca.R +++ b/R/lsm_c_ca.R @@ -58,28 +58,29 @@ lsm_c_ca <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_ca_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_ca_calc <- function(landscape, directions, resolution, extras = NULL) { # calculate core area for each patch core_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core_patch$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "ca", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for each class ca <- stats::aggregate(x = core_patch[, 5], by = core_patch[, 2], FUN = sum) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(ca)), class = as.integer(ca$class), - id = as.integer(NA), - metric = "ca", - value = as.double(ca$value))) + id = rep(as.integer(NA), nrow(ca)), + metric = rep("ca", nrow(ca)), + value = as.double(ca$value)))) } diff --git a/R/lsm_c_cai_cv.R b/R/lsm_c_cai_cv.R index 242574afd..9b3256618 100644 --- a/R/lsm_c_cai_cv.R +++ b/R/lsm_c_cai_cv.R @@ -68,29 +68,31 @@ lsm_c_cai_cv <- function(landscape, directions = 8, consider_boundary = FALSE, e tibble::add_column(result, layer, .before = TRUE) } -lsm_c_cai_cv_calc <- function(landscape, directions, consider_boundary, edge_depth){ +lsm_c_cai_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # calculate core area index for each patch cai <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, - edge_depth = edge_depth) + edge_depth = edge_depth, + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "cai_cv", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for classes cai_cv <- stats::aggregate(x = cai[, 5], by = cai[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(cai_cv)), class = as.integer(cai_cv$class), - id = as.integer(NA), - metric = "cai_cv", - value = as.double(cai_cv$value))) + id = rep(as.integer(NA), nrow(cai_cv)), + metric = rep("cai_cv", nrow(cai_cv)), + value = as.double(cai_cv$value)))) } diff --git a/R/lsm_c_cai_mn.R b/R/lsm_c_cai_mn.R index cd1afe5af..144d4e895 100644 --- a/R/lsm_c_cai_mn.R +++ b/R/lsm_c_cai_mn.R @@ -66,29 +66,31 @@ lsm_c_cai_mn <- function(landscape, directions = 8, consider_boundary = FALSE, e tibble::add_column(result, layer, .before = TRUE) } -lsm_c_cai_mn_calc <- function(landscape, directions, consider_boundary, edge_depth){ +lsm_c_cai_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # calculate core area index for each patch cai <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, - edge_depth = edge_depth) + edge_depth = edge_depth, + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "cai_mn", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for each class cai_mean <- stats::aggregate(x = cai[, 5], by = cai[, 2], FUN = mean) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(cai_mean)), class = as.integer(cai_mean$class), - id = as.integer(NA), - metric = "cai_mn", - value = as.double(cai_mean$value))) + id = rep(as.integer(NA), nrow(cai_mean)), + metric = rep("cai_mn", nrow(cai_mean)), + value = as.double(cai_mean$value)))) } diff --git a/R/lsm_c_cai_sd.R b/R/lsm_c_cai_sd.R index 05e2c4fbe..3346c8937 100644 --- a/R/lsm_c_cai_sd.R +++ b/R/lsm_c_cai_sd.R @@ -68,29 +68,31 @@ lsm_c_cai_sd <- function(landscape, directions = 8, consider_boundary = FALSE, e tibble::add_column(result, layer, .before = TRUE) } -lsm_c_cai_sd_calc <- function(landscape, directions, consider_boundary, edge_depth){ +lsm_c_cai_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # calculate core area index for each patch cai <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, - edge_depth = edge_depth) + edge_depth = edge_depth, + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "cai_sd", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for classes cai_sd <- stats::aggregate(x = cai[, 5], by = cai[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(cai_sd)), class = as.integer(cai_sd$class), - id = as.integer(NA), - metric = "cai_sd", - value = as.double(cai_sd$value))) + id = rep(as.integer(NA), nrow(cai_sd)), + metric = rep("cai_sd", nrow(cai_sd)), + value = as.double(cai_sd$value)))) } diff --git a/R/lsm_c_circle_cv.R b/R/lsm_c_circle_cv.R index 688901daf..076e54b78 100644 --- a/R/lsm_c_circle_cv.R +++ b/R/lsm_c_circle_cv.R @@ -68,30 +68,32 @@ lsm_c_circle_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_circle_cv_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_circle_cv_calc <- function(landscape, directions, resolution, extras = NULL) { # calculate circumscribing circle for each patch circle <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "circle_cv", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for classes circle_cv <- stats::aggregate(x = circle[, 5], by = circle[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(circle_cv$class), - id = as.integer(NA), - metric = "circle_cv", - value = as.double(circle_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(circle_cv)), + class = as.integer(circle_cv$class), + id = rep(as.integer(NA), nrow(circle_cv)), + metric = rep("circle_cv", nrow(circle_cv)), + value = as.double(circle_cv$value)))) } diff --git a/R/lsm_c_circle_mn.R b/R/lsm_c_circle_mn.R index 37f5faa82..01a57c30a 100644 --- a/R/lsm_c_circle_mn.R +++ b/R/lsm_c_circle_mn.R @@ -66,29 +66,31 @@ lsm_c_circle_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_circle_mn_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_circle_mn_calc <- function(landscape, directions, resolution, extras = NULL) { # calculate circumscribing circle for each patch circle <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "circle_mn", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for classes circle_mn <- stats::aggregate(x = circle[, 5], by = circle[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(circle_mn$class), - id = as.integer(NA), - metric = "circle_mn", - value = as.double(circle_mn$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(circle_mn)), + class = as.integer(circle_mn$class), + id = rep(as.integer(NA), nrow(circle_mn)), + metric = rep("circle_mn", nrow(circle_mn)), + value = as.double(circle_mn$value)))) } diff --git a/R/lsm_c_circle_sd.R b/R/lsm_c_circle_sd.R index 052377ee4..47e445915 100644 --- a/R/lsm_c_circle_sd.R +++ b/R/lsm_c_circle_sd.R @@ -66,29 +66,32 @@ lsm_c_circle_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_circle_sd_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_circle_sd_calc <- function(landscape, directions, resolution, extras = NULL) { # calculate circumscribing circle for each patch circle <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "circle_sd", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for classes circle_sd <- stats::aggregate(x = circle[, 5], by = circle[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(circle_sd$class), - id = as.integer(NA), - metric = "circle_sd", - value = as.double(circle_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(circle_sd)), + class = as.integer(circle_sd$class), + id = rep(as.integer(NA), nrow(circle_sd)), + metric = rep("circle_sd", nrow(circle_sd)), + value = as.double(circle_sd$value) + ))) } diff --git a/R/lsm_c_clumpy.R b/R/lsm_c_clumpy.R index 594afe941..7ccb9dc64 100644 --- a/R/lsm_c_clumpy.R +++ b/R/lsm_c_clumpy.R @@ -52,7 +52,7 @@ lsm_c_clumpy <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_clumpy_calc <- function(landscape, resolution = NULL){ +lsm_c_clumpy_calc <- function(landscape, resolution, extras = NULL){ # pad landscape to also include adjacencies at landscape boundary landscape_padded <- pad_raster_internal(landscape, @@ -62,11 +62,11 @@ lsm_c_clumpy_calc <- function(landscape, resolution = NULL){ # all values NA if (all(landscape_padded %in% c(NA, -999))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "clumpy", - value = as.double(NA))) + value = as.double(NA)))) } # get coocurrence @@ -113,9 +113,9 @@ lsm_c_clumpy_calc <- function(landscape, resolution = NULL){ }, FUN.VALUE = numeric(1)) - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", length(clumpy)), class = as.integer(names(g_i)), - id = as.integer(NA), - metric = "clumpy", - value = as.double(clumpy))) + id = rep(as.integer(NA), length(clumpy)), + metric = rep("clumpy", length(clumpy)), + value = as.double(clumpy)))) } diff --git a/R/lsm_c_cohesion.R b/R/lsm_c_cohesion.R index 8691926c7..8c06c9955 100644 --- a/R/lsm_c_cohesion.R +++ b/R/lsm_c_cohesion.R @@ -59,22 +59,24 @@ lsm_c_cohesion <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_cohesion_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_cohesion_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to raster to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_cohesion" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "cohesion", - value = as.double(NA))) + value = as.double(NA)))) } # get number of cells (only not NAs) @@ -83,15 +85,17 @@ lsm_c_cohesion_calc <- function(landscape, directions, resolution = NULL) { # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) - + resolution = resolution, + extras = extras) + # get number of cells for each patch -> area = n_cells * res / 10000 patch_area$ncells <- patch_area$value * 10000 / prod(resolution) # get perim of patch perim_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # calculate denominator of cohesion perim_patch$denominator <- perim_patch$value * sqrt(patch_area$ncells) @@ -107,9 +111,11 @@ lsm_c_cohesion_calc <- function(landscape, directions, resolution = NULL) { cohesion$value <- (1 - (cohesion$value / denominator$denominator)) * ((1 - (1 / sqrt(ncells_landscape))) ^ -1) * 100 - return(tibble::tibble(level = "class", - class = as.integer(cohesion$class), - id = as.integer(NA), - metric = "cohesion", - value = as.double(cohesion$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(cohesion)), + class = as.integer(cohesion$class), + id = rep(as.integer(NA), nrow(cohesion)), + metric = rep("cohesion", nrow(cohesion)), + value = as.double(cohesion$value) + ))) } diff --git a/R/lsm_c_contig_cv.R b/R/lsm_c_contig_cv.R index 969e9c17c..f210d731c 100644 --- a/R/lsm_c_contig_cv.R +++ b/R/lsm_c_contig_cv.R @@ -71,25 +71,27 @@ lsm_c_contig_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_contig_cv_calc <- function(landscape, directions) { +lsm_c_contig_cv_calc <- function(landscape, directions, extras = NULL) { - contig <- lsm_p_contig_calc(landscape, directions = directions) + contig <- lsm_p_contig_calc(landscape, directions = directions, extras = extras) # all values NA if (all(is.na(contig$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "contig_cv", - value = as.double(NA))) + value = as.double(NA)))) } contig_cv <- stats::aggregate(x = contig[, 5], by = contig[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(contig_cv$class), - id = as.integer(NA), - metric = "contig_cv", - value = as.double(contig_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(contig_cv)), + class = as.integer(contig_cv$class), + id = rep(as.integer(NA), nrow(contig_cv)), + metric = rep("contig_cv", nrow(contig_cv)), + value = as.double(contig_cv$value) + ))) } diff --git a/R/lsm_c_contig_mn.R b/R/lsm_c_contig_mn.R index 3fdfe4ea3..ac357cdf6 100644 --- a/R/lsm_c_contig_mn.R +++ b/R/lsm_c_contig_mn.R @@ -70,25 +70,27 @@ lsm_c_contig_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_contig_mn_calc <- function(landscape, directions) { +lsm_c_contig_mn_calc <- function(landscape, directions, extras = NULL) { - contig <- lsm_p_contig_calc(landscape, directions = directions) + contig <- lsm_p_contig_calc(landscape, directions = directions, extras = extras) # all values NA if (all(is.na(contig$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "contig_mn", - value = as.double(NA))) + value = as.double(NA)))) } contig_mn <- stats::aggregate(x = contig[, 5], by = contig[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(contig_mn$class), - id = as.integer(NA), - metric = "contig_mn", - value = as.double(contig_mn$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(contig_mn)), + class = as.integer(contig_mn$class), + id = rep(as.integer(NA), nrow(contig_mn)), + metric = rep("contig_mn", nrow(contig_mn)), + value = as.double(contig_mn$value) + ))) } diff --git a/R/lsm_c_contig_sd.R b/R/lsm_c_contig_sd.R index 10c866595..630f69499 100644 --- a/R/lsm_c_contig_sd.R +++ b/R/lsm_c_contig_sd.R @@ -71,25 +71,27 @@ lsm_c_contig_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_contig_sd_calc <- function(landscape, directions) { +lsm_c_contig_sd_calc <- function(landscape, directions, extras = NULL) { - contig <- lsm_p_contig_calc(landscape, directions = directions) + contig <- lsm_p_contig_calc(landscape, directions = directions, extras = extras) # all values NA if (all(is.na(contig$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "contig_sd", - value = as.double(NA))) + value = as.double(NA)))) } contig_sd <- stats::aggregate(x = contig[, 5], by = contig[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(contig_sd$class), - id = as.integer(NA), - metric = "contig_sd", - value = as.double(contig_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(contig_sd)), + class = as.integer(contig_sd$class), + id = rep(as.integer(NA), nrow(contig_sd)), + metric = rep("contig_sd", nrow(contig_sd)), + value = as.double(contig_sd$value) + ))) } diff --git a/R/lsm_c_core_cv.R b/R/lsm_c_core_cv.R index 9832698d6..3132b649e 100644 --- a/R/lsm_c_core_cv.R +++ b/R/lsm_c_core_cv.R @@ -63,31 +63,34 @@ lsm_c_core_cv <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_core_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL) { +lsm_c_core_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL) { # calculate core for each patch core <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "core_cv", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for class core_cv <- stats::aggregate(x = core[, 5], by = core[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(core_cv$class), - id = as.integer(NA), - metric = "core_cv", - value = as.double(core_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(core_cv)), + class = as.integer(core_cv$class), + id = rep(as.integer(NA), nrow(core_cv)), + metric = rep("core_cv", nrow(core_cv)), + value = as.double(core_cv$value) + ))) } diff --git a/R/lsm_c_core_mn.R b/R/lsm_c_core_mn.R index c16489839..7707ee6b5 100644 --- a/R/lsm_c_core_mn.R +++ b/R/lsm_c_core_mn.R @@ -62,30 +62,33 @@ lsm_c_core_mn <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_core_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_c_core_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "core_mn", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for class core_mean <- stats::aggregate(x = core[, 5], by = core[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(core_mean$class), - id = as.integer(NA), - metric = "core_mn", - value = as.double(core_mean$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(core_mean)), + class = as.integer(core_mean$class), + id = rep(as.integer(NA), nrow(core_mean)), + metric = rep("core_mn", nrow(core_mean)), + value = as.double(core_mean$value) + ))) } diff --git a/R/lsm_c_core_sd.R b/R/lsm_c_core_sd.R index a904f484e..ca360ca8d 100644 --- a/R/lsm_c_core_sd.R +++ b/R/lsm_c_core_sd.R @@ -64,30 +64,33 @@ lsm_c_core_sd <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_core_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_c_core_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "core_mn", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for class core_sd <- stats::aggregate(x = core[, 5], by = core[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(core_sd$class), - id = as.integer(NA), - metric = "core_sd", - value = as.double(core_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(core_sd)), + class = as.integer(core_sd$class), + id = rep(as.integer(NA), nrow(core_sd)), + metric = rep("core_sd", nrow(core_sd)), + value = as.double(core_sd$value) + ))) } diff --git a/R/lsm_c_cpland.R b/R/lsm_c_cpland.R index fa90f6c3e..f71849e7a 100644 --- a/R/lsm_c_cpland.R +++ b/R/lsm_c_cpland.R @@ -60,28 +60,31 @@ lsm_c_cpland <- function(landscape, directions = 8, consider_boundary = FALSE, e tibble::add_column(result, layer, .before = TRUE) } -lsm_c_cpland_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_c_cpland_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ - # conver to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_cpland" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "cpland", - value = as.double(NA))) + value = as.double(NA)))) } # calculate patch area area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # total landscape area area <- sum(area$value) @@ -90,8 +93,9 @@ lsm_c_cpland_calc <- function(landscape, directions, consider_boundary, edge_dep core_area <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, - edge_depth = edge_depth, - resolution = resolution) + edge_depth = edge_depth, + resolution = resolution, + extras = extras) # summarise core area for classes core_area <- stats::aggregate(x = core_area[, 5], by = core_area[, 2], FUN = sum) @@ -99,9 +103,9 @@ lsm_c_cpland_calc <- function(landscape, directions, consider_boundary, edge_dep # relative core area of each class core_area$value <- core_area$value / area * 100 - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(core_area)), class = as.integer(core_area$class), - id = as.integer(NA), - metric = "cpland", - value = as.double(core_area$value))) + id = rep(as.integer(NA), nrow(core_area)), + metric = rep("cpland", nrow(core_area)), + value = as.double(core_area$value)))) } diff --git a/R/lsm_c_dcad.R b/R/lsm_c_dcad.R index 1c1027f36..5b8c68704 100644 --- a/R/lsm_c_dcad.R +++ b/R/lsm_c_dcad.R @@ -64,24 +64,24 @@ lsm_c_dcad <- function(landscape, directions = 8, consider_boundary = FALSE, edg tibble::add_column(result, layer, .before = TRUE) } -lsm_c_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth, - resolution = NULL, points = NULL){ +lsm_c_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # get patch area area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area <- sum(area$value) # all values NA if (is.na(area)) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "dcad", - value = as.double(NA))) + value = as.double(NA)))) } # get number of core area @@ -89,7 +89,8 @@ lsm_c_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # summarise for classes ndca <- stats::aggregate(x = ndca[, 5], by = ndca[, 2], FUN = sum) @@ -97,9 +98,9 @@ lsm_c_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth # calculate relative value ndca$value <- ndca$value / area * 100 - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(ndca)), class = as.integer(ndca$class), - id = as.integer(NA), - metric = "dcad", - value = as.double(ndca$value))) + id = rep(as.integer(NA), nrow(ndca)), + metric = rep("dcad", nrow(ndca)), + value = as.double(ndca$value)))) } diff --git a/R/lsm_c_dcore_cv.R b/R/lsm_c_dcore_cv.R index b01492c98..7953d0fde 100644 --- a/R/lsm_c_dcore_cv.R +++ b/R/lsm_c_dcore_cv.R @@ -67,30 +67,32 @@ lsm_c_dcore_cv <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_dcore_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_c_dcore_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(dcore$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "dcore_cv", - value = as.double(NA))) + value = as.double(NA)))) } dcore_cv <- stats::aggregate(x = dcore[, 5], by = dcore[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(dcore_cv$class), - id = as.integer(NA), - metric = "dcore_cv", - value = as.double(dcore_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(dcore_cv)), + class = as.integer(dcore_cv$class), + id = rep(as.integer(NA), nrow(dcore_cv)), + metric = rep("dcore_cv", nrow(dcore_cv)), + value = as.double(dcore_cv$value) + ))) } diff --git a/R/lsm_c_dcore_mn.R b/R/lsm_c_dcore_mn.R index b806363f2..fb3fc2e9f 100644 --- a/R/lsm_c_dcore_mn.R +++ b/R/lsm_c_dcore_mn.R @@ -65,28 +65,30 @@ lsm_c_dcore_mn <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_dcore_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_c_dcore_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) if (all(is.na(dcore$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "dcore_mn", - value = as.double(NA))) + value = as.double(NA)))) } dcore_mn <- stats::aggregate(x = dcore[, 5], by = dcore[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(dcore_mn$class), - id = as.integer(NA), - metric = "dcore_mn", - value = as.double(dcore_mn$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(dcore_mn)), + class = as.integer(dcore_mn$class), + id = rep(as.integer(NA), nrow(dcore_mn)), + metric = rep("dcore_mn", nrow(dcore_mn)), + value = as.double(dcore_mn$value) + ))) } diff --git a/R/lsm_c_dcore_sd.R b/R/lsm_c_dcore_sd.R index ff5aefbf0..df02bdb18 100644 --- a/R/lsm_c_dcore_sd.R +++ b/R/lsm_c_dcore_sd.R @@ -68,28 +68,30 @@ lsm_c_dcore_sd <- function(landscape, directions = 8, consider_boundary = FALSE, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_dcore_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_c_dcore_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) if (all(is.na(dcore$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "dcore_sd", - value = as.double(NA))) + value = as.double(NA)))) } dcore_sd <- stats::aggregate(x = dcore[, 5], by = dcore[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(dcore_sd$class), - id = as.integer(NA), - metric = "dcore_sd", - value = as.double(dcore_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(dcore_sd)), + class = as.integer(dcore_sd$class), + id = rep(as.integer(NA), nrow(dcore_sd)), + metric = rep("dcore_sd", nrow(dcore_sd)), + value = as.double(dcore_sd$value) + ))) } diff --git a/R/lsm_c_division.R b/R/lsm_c_division.R index 35add0628..14b5de6ec 100644 --- a/R/lsm_c_division.R +++ b/R/lsm_c_division.R @@ -58,23 +58,24 @@ lsm_c_division <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_division_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_division_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # get total area total_area <- sum(patch_area$value) # all values NA if (is.na(total_area)) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "division", - value = as.double(NA))) + value = as.double(NA)))) } # calculate division for each patch @@ -86,9 +87,11 @@ lsm_c_division_calc <- function(landscape, directions, resolution = NULL) { division$value <- 1 - division$value - return(tibble::tibble(level = "class", - class = as.integer(division$class), - id = as.integer(NA), - metric = "division", - value = as.double(division$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(division)), + class = as.integer(division$class), + id = rep(as.integer(NA), nrow(division)), + metric = rep("division", nrow(division)), + value = as.double(division$value) + ))) } diff --git a/R/lsm_c_ed.R b/R/lsm_c_ed.R index 834d11d02..7e62b0107 100644 --- a/R/lsm_c_ed.R +++ b/R/lsm_c_ed.R @@ -63,28 +63,31 @@ lsm_c_ed <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_ed_calc <- function(landscape, count_boundary, directions, resolution = NULL) { +lsm_c_ed_calc <- function(landscape, count_boundary, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_ed" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "ed", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area <- sum(area$value) @@ -93,13 +96,14 @@ lsm_c_ed_calc <- function(landscape, count_boundary, directions, resolution = NU edge_class <- lsm_c_te_calc(landscape, count_boundary = count_boundary, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) edge_class$value <- edge_class$value / area - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", nrow(edge_class)), class = as.integer(edge_class$class), - id = as.integer(NA), - metric = "ed", - value = as.double(edge_class$value))) + id = rep(as.integer(NA), nrow(edge_class)), + metric = rep("ed", nrow(edge_class)), + value = as.double(edge_class$value)))) } diff --git a/R/lsm_c_enn_cv.R b/R/lsm_c_enn_cv.R index ceff77d19..af928d5cd 100644 --- a/R/lsm_c_enn_cv.R +++ b/R/lsm_c_enn_cv.R @@ -66,29 +66,30 @@ lsm_c_enn_cv <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_enn_cv_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_c_enn_cv_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all cells are NA if (all(is.na(enn$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "enn_cv", - value = as.double(NA))) + value = as.double(NA)))) } enn_cv <- stats::aggregate(x = enn[, 5], by = enn[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(enn_cv$class), - id = as.integer(NA), - metric = "enn_cv", - value = as.double(enn_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(enn_cv)), + class = as.integer(enn_cv$class), + id = rep(as.integer(NA), nrow(enn_cv)), + metric = rep("enn_cv", nrow(enn_cv)), + value = as.double(enn_cv$value) + ))) } diff --git a/R/lsm_c_enn_mn.R b/R/lsm_c_enn_mn.R index e56641241..f5ce2e18d 100644 --- a/R/lsm_c_enn_mn.R +++ b/R/lsm_c_enn_mn.R @@ -68,28 +68,29 @@ lsm_c_enn_mn <- function(landscape, directions = 8, verbose = TRUE) { } -lsm_c_enn_mn_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_c_enn_mn_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all cells are NA if (all(is.na(enn$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "enn_mn", - value = as.double(NA))) + value = as.double(NA)))) } enn_mn <- stats::aggregate(x = enn[, 5], by = enn[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(enn_mn$class), - id = as.integer(NA), - metric = "enn_mn", - value = as.double(enn_mn$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(enn_mn)), + class = as.integer(enn_mn$class), + id = rep(as.integer(NA), nrow(enn_mn)), + metric = rep("enn_mn", nrow(enn_mn)), + value = as.double(enn_mn$value) + ))) } diff --git a/R/lsm_c_enn_sd.R b/R/lsm_c_enn_sd.R index 94c38187d..7a8795905 100644 --- a/R/lsm_c_enn_sd.R +++ b/R/lsm_c_enn_sd.R @@ -68,28 +68,29 @@ lsm_c_enn_sd <- function(landscape, directions = 8, verbose = TRUE) { } -lsm_c_enn_sd_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_c_enn_sd_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all cells are NA if (all(is.na(enn$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "enn_sd", - value = as.double(NA))) + value = as.double(NA)))) } enn_sd <- stats::aggregate(x = enn[, 5], by = enn[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(enn_sd$class), - id = as.integer(NA), - metric = "enn_sd", - value = as.double(enn_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(enn_sd)), + class = as.integer(enn_sd$class), + id = rep(as.integer(NA), nrow(enn_sd)), + metric = rep("enn_sd", nrow(enn_sd)), + value = as.double(enn_sd$value) + ))) } diff --git a/R/lsm_c_frac_cv.R b/R/lsm_c_frac_cv.R index 3e4d5dd87..d7b665f5a 100644 --- a/R/lsm_c_frac_cv.R +++ b/R/lsm_c_frac_cv.R @@ -63,27 +63,30 @@ lsm_c_frac_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_frac_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_frac_cv_calc <- function(landscape, directions, resolution, extras = NULL){ frac <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(frac$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "frac_cv", - value = as.double(NA))) + value = as.double(NA)))) } frac_cv <- stats::aggregate(x = frac[, 5], by = frac[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(frac_cv$class), - id = as.integer(NA), - metric = "frac_cv", - value = as.double(frac_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(frac_cv)), + class = as.integer(frac_cv$class), + id = rep(as.integer(NA), nrow(frac_cv)), + metric = rep("frac_cv", nrow(frac_cv)), + value = as.double(frac_cv$value) + ))) } diff --git a/R/lsm_c_frac_mn.R b/R/lsm_c_frac_mn.R index 17bd5ec50..28bb550ca 100644 --- a/R/lsm_c_frac_mn.R +++ b/R/lsm_c_frac_mn.R @@ -61,26 +61,29 @@ lsm_c_frac_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_frac_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_frac_mn_calc <- function(landscape, directions, resolution, extras = NULL){ frac <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(frac$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "frac_mn", - value = as.double(NA))) + value = as.double(NA)))) } frac_mean <- stats::aggregate(x = frac[, 5], by = frac[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(frac_mean$class), - id = as.integer(NA), - metric = "frac_mn", - value = as.double(frac_mean$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(frac_mean)), + class = as.integer(frac_mean$class), + id = rep(as.integer(NA), nrow(frac_mean)), + metric = rep("frac_mn", nrow(frac_mean)), + value = as.double(frac_mean$value) + ))) } diff --git a/R/lsm_c_frac_sd.R b/R/lsm_c_frac_sd.R index e15b5eba6..0ea48d781 100644 --- a/R/lsm_c_frac_sd.R +++ b/R/lsm_c_frac_sd.R @@ -63,27 +63,30 @@ lsm_c_frac_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_frac_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_frac_sd_calc <- function(landscape, directions, resolution, extras = NULL){ frac <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(frac$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "frac_sd", - value = as.double(NA))) + value = as.double(NA)))) } frac_sd <- stats::aggregate(x = frac[, 5], by = frac[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(frac_sd$class), - id = as.integer(NA), - metric = "frac_sd", - value = as.double(frac_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(frac_sd)), + class = as.integer(frac_sd$class), + id = rep(as.integer(NA), nrow(frac_sd)), + metric = rep("frac_sd", nrow(frac_sd)), + value = as.double(frac_sd$value) + ))) } diff --git a/R/lsm_c_gyrate_cv.R b/R/lsm_c_gyrate_cv.R index 7874b4e06..a65829ef5 100644 --- a/R/lsm_c_gyrate_cv.R +++ b/R/lsm_c_gyrate_cv.R @@ -72,29 +72,31 @@ lsm_c_gyrate_cv <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_cv_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_c_gyrate_cv_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(gyrate$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_cv", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_cv <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(gyrate_cv$class), - id = as.integer(NA), - metric = "gyrate_cv", - value = as.double(gyrate_cv$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(gyrate_cv)), + class = as.integer(gyrate_cv$class), + id = rep(as.integer(NA), nrow(gyrate_cv)), + metric = rep("gyrate_cv", nrow(gyrate_cv)), + value = as.double(gyrate_cv$value) + ))) } diff --git a/R/lsm_c_gyrate_mn.R b/R/lsm_c_gyrate_mn.R index 274377a24..f2294edd7 100644 --- a/R/lsm_c_gyrate_mn.R +++ b/R/lsm_c_gyrate_mn.R @@ -71,29 +71,31 @@ lsm_c_gyrate_mn <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_mn_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_c_gyrate_mn_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(gyrate$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_cv", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_mn <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(gyrate_mn$class), - id = as.integer(NA), - metric = "gyrate_mn", - value = as.double(gyrate_mn$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(gyrate_mn)), + class = as.integer(gyrate_mn$class), + id = rep(as.integer(NA), nrow(gyrate_mn)), + metric = rep("gyrate_mn", nrow(gyrate_mn)), + value = as.double(gyrate_mn$value) + ))) } diff --git a/R/lsm_c_gyrate_sd.R b/R/lsm_c_gyrate_sd.R index ed31426c3..4ff1b76f9 100644 --- a/R/lsm_c_gyrate_sd.R +++ b/R/lsm_c_gyrate_sd.R @@ -71,29 +71,31 @@ lsm_c_gyrate_sd <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_sd_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_c_gyrate_sd_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(gyrate$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_sd", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_sd <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], FUN = stats::sd) - return(tibble::tibble(level = "class", - class = as.integer(gyrate_sd$class), - id = as.integer(NA), - metric = "gyrate_sd", - value = as.double(gyrate_sd$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(gyrate_sd)), + class = as.integer(gyrate_sd$class), + id = rep(as.integer(NA), nrow(gyrate_sd)), + metric = rep("gyrate_sd", nrow(gyrate_sd)), + value = as.double(gyrate_sd$value) + ))) } diff --git a/R/lsm_c_iji.R b/R/lsm_c_iji.R index 2fc45fd18..cb2d14c7d 100644 --- a/R/lsm_c_iji.R +++ b/R/lsm_c_iji.R @@ -58,7 +58,7 @@ lsm_c_iji <- function(landscape, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_iji_calc <- function(landscape, verbose) { +lsm_c_iji_calc <- function(landscape, verbose, extras = NULL) { # conver to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -67,15 +67,18 @@ lsm_c_iji_calc <- function(landscape, verbose) { # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "iji", - value = as.double(NA))) + value = as.double(NA)))) } - adjacencies <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + if (!is.null(extras)){ + adjacencies <- extras$neighbor_matrix + } else { + adjacencies <- rcpp_get_coocurrence_matrix(landscape, as.matrix(4)) + } classes <- rownames(adjacencies) @@ -85,11 +88,11 @@ lsm_c_iji_calc <- function(landscape, verbose) { warning("Number of classes must be >= 3, IJI = NA.", call. = FALSE) } - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = rep("class", length(classes)), class = as.integer(classes), - id = as.integer(NA), - metric = "iji", - value = as.double(NA))) + id = rep(as.integer(NA), length(classes)), + metric = rep("iji", length(classes)), + value = rep(as.double(NA), length(classes))))) } else { @@ -103,10 +106,12 @@ lsm_c_iji_calc <- function(landscape, verbose) { iji <- (class_sums / log(ncol(adjacencies) - 1)) * 100 - return(tibble::tibble(level = "class", - class = as.integer(classes), - id = as.integer(NA), - metric = "iji", - value = as.double(iji))) + return(tibble::new_tibble(list( + level = rep("class", length(iji)), + class = as.integer(classes), + id = rep(as.integer(NA), length(iji)), + metric = rep("iji", length(iji)), + value = as.double(iji) + ))) } } diff --git a/R/lsm_c_lpi.R b/R/lsm_c_lpi.R index 4f9275c51..83a131f86 100644 --- a/R/lsm_c_lpi.R +++ b/R/lsm_c_lpi.R @@ -55,20 +55,21 @@ lsm_c_lpi <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_lpi_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_lpi_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(patch_area$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "lpi", - value = as.double(NA))) + value = as.double(NA)))) } # summarise to total area @@ -80,9 +81,9 @@ lsm_c_lpi_calc <- function(landscape, directions, resolution = NULL) { # summarise for each class lpi <- stats::aggregate(x = patch_area[, 5], by = patch_area[, 2], FUN = max) - return(tibble::tibble(level = "class", - class = as.integer(lpi$class), - id = as.integer(NA), - metric = "lpi", - value = as.double(lpi$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(lpi)), + class = as.integer(lpi$class), + id = rep(as.integer(NA), nrow(lpi)), + metric = rep("lpi", nrow(lpi)), + value = as.double(lpi$value)))) } diff --git a/R/lsm_c_lsi.R b/R/lsm_c_lsi.R index 1da2d8e80..7144bf4b2 100644 --- a/R/lsm_c_lsi.R +++ b/R/lsm_c_lsi.R @@ -55,37 +55,35 @@ lsm_c_lsi <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_lsi_calc <- function(landscape) { +lsm_c_lsi_calc <- function(landscape, extras = NULL) { # convert to matrix if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) - landscape <- terra::as.matrix(landscape, wide = TRUE) } # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "nlsi", - value = as.double(NA))) + value = as.double(NA)))) } # cells at the boundary of the landscape need neighbours to calculate perim - landscape <- pad_raster_internal(landscape, pad_raster_value = NA, + landscape_pad <- pad_raster_internal(landscape, pad_raster_value = NA, pad_raster_cells = 1, global = FALSE) # which cells are NA (i.e. background) - target_na <- which(is.na(landscape)) + target_na <- which(is.na(landscape_pad)) # set all NA to -999 to get adjacencies between patches and all background - landscape[target_na] <- -999 + landscape_pad[target_na] <- -999 # get class edge in terms of cell surfaces - class_perim <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + class_perim <- rcpp_get_coocurrence_matrix(landscape_pad, as.matrix(4)) + class_area <- rcpp_get_composition_vector(landscape_pad)[-1] # set diagonal to NA because no edge diag(class_perim) <- NA @@ -93,9 +91,6 @@ lsm_c_lsi_calc <- function(landscape) { # calculate total edge class_perim <- apply(X = class_perim, MARGIN = 1, FUN = sum, na.rm = TRUE)[-1] - # number of cells class - class_area <- rcpp_get_composition_vector(landscape)[-1] - # n is the side of the largest integer square class_n <- trunc(sqrt(class_area)) @@ -116,9 +111,9 @@ lsm_c_lsi_calc <- function(landscape) { # calculate LSI lsi <- class_perim / class_perim_min - return(tibble::tibble(level = "class", - class = as.integer(names(lsi)), - id = as.integer(NA), - metric = "lsi", - value = as.double(lsi))) + return(tibble::new_tibble(list(level = rep("class", length(lsi)), + class = as.integer(names(lsi)), + id = rep(as.integer(NA), length(lsi)), + metric = rep("lsi", length(lsi)), + value = as.double(lsi)))) } diff --git a/R/lsm_c_mesh.R b/R/lsm_c_mesh.R index ec65609be..b9b49644f 100644 --- a/R/lsm_c_mesh.R +++ b/R/lsm_c_mesh.R @@ -60,23 +60,24 @@ lsm_c_mesh <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_mesh_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_mesh_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to landscape area in sqm total_area <- sum(patch_area$value) * 10000 # all values NA if (is.na(total_area)) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "mesh", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mesh for each patch @@ -88,9 +89,9 @@ lsm_c_mesh_calc <- function(landscape, directions, resolution = NULL) { # relative to total landscape area mesh$value <- (mesh$value / total_area) * (1 / 10000) - return(tibble::tibble(level = "class", - class = as.integer(mesh$class), - id = as.integer(NA), - metric = "mesh", - value = as.double(mesh$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(mesh)), + class = as.integer(mesh$class), + id = rep(as.integer(NA), nrow(mesh)), + metric = rep("mesh", nrow(mesh)), + value = as.double(mesh$value)))) } diff --git a/R/lsm_c_ndca.R b/R/lsm_c_ndca.R index 36c04db45..cf322bd90 100644 --- a/R/lsm_c_ndca.R +++ b/R/lsm_c_ndca.R @@ -65,31 +65,31 @@ lsm_c_ndca <- function(landscape, directions = 8, consider_boundary = FALSE, edg tibble::add_column(result, layer, .before = TRUE) } -lsm_c_ndca_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_c_ndca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # get number of core areas for each patch ndca <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(ndca$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "ndca", - value = as.double(NA))) + value = as.double(NA)))) } # summarise for each class ndca <- stats::aggregate(x = ndca[, 5], by = ndca[, 2], FUN = sum) - return(tibble::tibble(level = "class", - class = as.integer(ndca$class), - id = as.integer(NA), - metric = "ndca", - value = as.double(ndca$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(ndca)), + class = as.integer(ndca$class), + id = rep(as.integer(NA), nrow(ndca)), + metric = rep("ndca", nrow(ndca)), + value = as.double(ndca$value)))) } diff --git a/R/lsm_c_nlsi.R b/R/lsm_c_nlsi.R index 320cf4ea1..fb34643cb 100644 --- a/R/lsm_c_nlsi.R +++ b/R/lsm_c_nlsi.R @@ -59,37 +59,35 @@ lsm_c_nlsi <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_nlsi_calc <- function(landscape) { +lsm_c_nlsi_calc <- function(landscape, extras = NULL) { # convert to matrix if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) - landscape <- terra::as.matrix(landscape, wide = TRUE) } # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "nlsi", - value = as.double(NA))) + value = as.double(NA)))) } # cells at the boundary of the landscape need neighbours to calculate perim - landscape <- pad_raster_internal(landscape, pad_raster_value = NA, + landscape_pad <- pad_raster_internal(landscape, pad_raster_value = NA, pad_raster_cells = 1, global = FALSE) # which cells are NA (i.e. background) - target_na <- which(is.na(landscape)) + target_na <- which(is.na(landscape_pad)) # set all NA to -999 to get adjacencies between patches and all background - landscape[target_na] <- -999 + landscape_pad[target_na] <- -999 # get class edge in terms of cell surfaces - class_perim <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + class_perim <- rcpp_get_coocurrence_matrix(landscape_pad, as.matrix(4)) + class_area <- rcpp_get_composition_vector(landscape_pad)[-1] # set diagonal to NA because no edge diag(class_perim) <- NA @@ -97,9 +95,6 @@ lsm_c_nlsi_calc <- function(landscape) { # calculate total edge class_perim <- apply(X = class_perim, MARGIN = 1, FUN = sum, na.rm = TRUE)[-1] - # number of cells class - class_area <- rcpp_get_composition_vector(landscape)[-1] - # n is the side of the largest integer square class_n <- trunc(sqrt(class_area)) @@ -119,13 +114,13 @@ lsm_c_nlsi_calc <- function(landscape) { numerator <- class_perim - class_perim_min # calculate total area in terms of cells - total_area <- sum(rcpp_get_composition_vector(landscape)[-1]) + total_area <- sum(class_area) # get all cells on the boundary; need to remove padded cells - cells_boundary <- ((nrow(landscape) - 2) * 2) + ((ncol(landscape) - 2) * 2) + cells_boundary <- ((nrow(landscape_pad) - 2) * 2) + ((ncol(landscape_pad) - 2) * 2) # calculate proportion of classes - class_pi <- prop.table(rcpp_get_composition_vector(landscape)[-1]) + class_pi <- prop.table(class_area) class_perim_max <- ifelse(test = class_pi <= 0.5, yes = 4 * class_area, @@ -154,9 +149,9 @@ lsm_c_nlsi_calc <- function(landscape) { nlsi[!is.finite(nlsi)] <- NA } - return(tibble::tibble(level = "class", - class = as.integer(names(nlsi)), - id = as.integer(NA), - metric = "nlsi", - value = as.double(nlsi))) + return(tibble::new_tibble(list(level = rep("class", length(nlsi)), + class = as.integer(names(nlsi)), + id = rep(as.integer(NA), length(nlsi)), + metric = rep("nlsi", length(nlsi)), + value = as.double(nlsi)))) } diff --git a/R/lsm_c_np.R b/R/lsm_c_np.R index 5cfc42141..23f9d0d37 100644 --- a/R/lsm_c_np.R +++ b/R/lsm_c_np.R @@ -51,7 +51,7 @@ lsm_c_np <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_np_calc <- function(landscape, directions){ +lsm_c_np_calc <- function(landscape, directions, extras = NULL){ # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -60,33 +60,37 @@ lsm_c_np_calc <- function(landscape, directions){ # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "np", - value = as.double(NA))) + value = as.double(NA)))) } # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) + if (!is.null(extras)){ + classes <- extras$classes + class_patches <- extras$class_patches + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + class_patches <- get_class_patches(landscape, classes, directions) + } # get number of patches np_class <- lapply(X = classes, FUN = function(patches_class) { # connected labeling current class - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # max(patch_id) equals number of patches np <- max(landscape_labeled, na.rm = TRUE) - tibble::tibble( - level = "class", - class = as.integer(patches_class), - id = as.integer(NA), - metric = "np", - value = as.double(np)) + tibble::new_tibble(list( + level = rep("class", length(np)), + class = rep(as.integer(patches_class), length(patches_class)), + id = rep(as.integer(NA), length(np)), + metric = rep("np", length(np)), + value = as.double(np))) }) do.call(rbind, np_class) diff --git a/R/lsm_c_pafrac.R b/R/lsm_c_pafrac.R index d7342b6d5..529cf899e 100644 --- a/R/lsm_c_pafrac.R +++ b/R/lsm_c_pafrac.R @@ -64,39 +64,44 @@ lsm_c_pafrac <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL){ +lsm_c_pafrac_calc <- function(landscape, directions, verbose, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_pafrac" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "pafrac", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area in sqm area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) area_patch$value <- area_patch$value * 10000 # get patch perimeter perimeter_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # get number of patches np_class <- lsm_c_np_calc(landscape, - directions = directions) + directions = directions, + extras = extras) pafrac_class <- lapply(X = seq_len(nrow(np_class)), FUN = function(class_current) { @@ -122,12 +127,12 @@ lsm_c_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL) pafrac <- 2 / regression_model_class$coefficients[[2]] } - tibble::tibble( - level = "class", - class = as.integer(class_name), - id = as.integer(NA), - metric = "pafrac", - value = as.double(pafrac)) + tibble::new_tibble(list( + level = rep("class", length(pafrac)), + class = rep(as.integer(class_name), length(pafrac)), + id = rep(as.integer(NA), length(pafrac)), + metric = rep("pafrac", length(pafrac)), + value = as.double(pafrac))) }) do.call("rbind", pafrac_class) diff --git a/R/lsm_c_para_cv.R b/R/lsm_c_para_cv.R index 8100231ee..efca736ec 100644 --- a/R/lsm_c_para_cv.R +++ b/R/lsm_c_para_cv.R @@ -60,27 +60,28 @@ lsm_c_para_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_para_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_para_cv_calc <- function(landscape, directions, resolution, extras = NULL){ para <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(para$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "para_cv", - value = as.double(NA))) + value = as.double(NA)))) } para_cv <- stats::aggregate(x = para[, 5], by = para[, 2], FUN = function(x) stats::sd(x) / mean(x) * 100) - return(tibble::tibble(level = "class", - class = as.integer(para_cv$class), - id = as.integer(NA), - metric = "para_cv", - value = as.double(para_cv$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(para_cv)), + class = as.integer(para_cv$class), + id = rep(as.integer(NA), nrow(para_cv)), + metric = rep("para_cv", nrow(para_cv)), + value = as.double(para_cv$value)))) } diff --git a/R/lsm_c_para_mn.R b/R/lsm_c_para_mn.R index 8a0d10db6..e72d9811e 100644 --- a/R/lsm_c_para_mn.R +++ b/R/lsm_c_para_mn.R @@ -61,26 +61,27 @@ lsm_c_para_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_para_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_para_mn_calc <- function(landscape, directions, resolution, extras = NULL){ para <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(para$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "para_mn", - value = as.double(NA))) + value = as.double(NA)))) } para_mn <- stats::aggregate(x = para[, 5], by = para[, 2], FUN = mean) - return(tibble::tibble(level = "class", - class = as.integer(para_mn$class), - id = as.integer(NA), - metric = "para_mn", - value = as.double(para_mn$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(para_mn)), + class = as.integer(para_mn$class), + id = rep(as.integer(NA), nrow(para_mn)), + metric = rep("para_mn", nrow(para_mn)), + value = as.double(para_mn$value)))) } diff --git a/R/lsm_c_para_sd.R b/R/lsm_c_para_sd.R index 819104c31..b9a4afeb7 100644 --- a/R/lsm_c_para_sd.R +++ b/R/lsm_c_para_sd.R @@ -61,27 +61,28 @@ lsm_c_para_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_para_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_para_sd_calc <- function(landscape, directions, resolution, extras = NULL){ para <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(para$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "para_sd", - value = as.double(NA))) + value = as.double(NA)))) } para_sd <- stats::aggregate(x = para[, 5], by = para[, 2], FUN = stats::sd) - - return(tibble::tibble(level = "class", - class = as.integer(para_sd$class), - id = as.integer(NA), - metric = "para_sd", - value = as.double(para_sd$value))) + + return(tibble::new_tibble(list(level = rep("class", nrow(para_sd)), + class = as.integer(para_sd$class), + id = rep(as.integer(NA), nrow(para_sd)), + metric = rep("para_sd", nrow(para_sd)), + value = as.double(para_sd$value)))) } diff --git a/R/lsm_c_pd.R b/R/lsm_c_pd.R index 20a116f47..ff9e66e06 100644 --- a/R/lsm_c_pd.R +++ b/R/lsm_c_pd.R @@ -56,41 +56,44 @@ lsm_c_pd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_pd_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_pd_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_pd" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "pd", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area_patch <- sum(area_patch$value) # get number of patches - np_class <- lsm_c_np_calc(landscape, directions = directions) + np_class <- lsm_c_np_calc(landscape, directions = directions, extras = extras) # calculate relative patch density np_class$value <- (np_class$value / area_patch) * 100 - return(tibble::tibble(level = "class", - class = as.integer(np_class$class), - id = as.integer(NA), - metric = "pd", - value = as.double(np_class$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(np_class)), + class = as.integer(np_class$class), + id = rep(as.integer(NA), nrow(np_class)), + metric = rep("pd", nrow(np_class)), + value = as.double(np_class$value)))) } diff --git a/R/lsm_c_pladj.R b/R/lsm_c_pladj.R index 2c69376df..de98a48e0 100644 --- a/R/lsm_c_pladj.R +++ b/R/lsm_c_pladj.R @@ -57,25 +57,24 @@ lsm_c_pladj_calc <- function(landscape) { # all cells are NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "pladj", - value = as.double(NA))) + value = as.double(NA)))) } landscape_padded <- pad_raster_internal(landscape, pad_raster_value = -999, pad_raster_cells = 1, global = TRUE) - tb <- rcpp_get_coocurrence_matrix(landscape_padded, - directions = as.matrix(4)) + tb <- rcpp_get_coocurrence_matrix(landscape_padded, directions = as.matrix(4)) pladj <- diag(tb) / colSums(tb) * 100 names <- row.names(tb) - return(tibble::tibble(level = "class", - class = as.integer(names[-1]), - id = as.integer(NA), - metric = "pladj", - value = as.double(pladj[-1]))) + return(tibble::new_tibble(list(level = rep("class", length(names[-1])), + class = as.integer(names[-1]), + id = rep(as.integer(NA), length(names[-1])), + metric = rep("pladj", length(names[-1])), + value = as.double(pladj[-1])))) } diff --git a/R/lsm_c_pland.R b/R/lsm_c_pland.R index ad42267c4..a33d8df60 100644 --- a/R/lsm_c_pland.R +++ b/R/lsm_c_pland.R @@ -54,29 +54,39 @@ lsm_c_pland <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_pland_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_pland_calc <- function(landscape, directions, resolution, extras = NULL){ + + if (missing(resolution)) resolution <- terra::res(landscape) + + if (is.null(extras)){ + metrics <- "lsm_c_pland" + landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) + } pland <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(pland$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "pland", - value = as.double(NA))) + value = as.double(NA)))) } pland <- stats::aggregate(x = pland[, 5], by = pland[, 2], FUN = sum) pland$value <- pland$value / sum(pland$value) * 100 - return(tibble::tibble(level = "class", - class = as.integer(pland$class), - id = as.integer(NA), - metric = "pland", - value = as.double(pland$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(pland)), + class = as.integer(pland$class), + id = rep(as.integer(NA), nrow(pland)), + metric = rep("pland", nrow(pland)), + value = as.double(pland$value)))) } diff --git a/R/lsm_c_shape_cv.R b/R/lsm_c_shape_cv.R index 63333493f..de2e18153 100644 --- a/R/lsm_c_shape_cv.R +++ b/R/lsm_c_shape_cv.R @@ -60,20 +60,21 @@ lsm_c_shape_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_shape_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_shape_cv_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "shape_cv", - value = as.double(NA))) + value = as.double(NA)))) } # calculate cv @@ -81,9 +82,9 @@ lsm_c_shape_cv_calc <- function(landscape, directions, resolution = NULL){ FUN = function(x) stats::sd(x, na.rm = TRUE) / mean(x, na.rm = TRUE) * 100) - return(tibble::tibble(level = "class", - class = as.integer(shape_cv$class), - id = as.integer(NA), - metric = "shape_cv", - value = as.double(shape_cv$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(shape_cv)), + class = as.integer(shape_cv$class), + id = rep(as.integer(NA), nrow(shape_cv)), + metric = rep("shape_cv", nrow(shape_cv)), + value = as.double(shape_cv$value)))) } diff --git a/R/lsm_c_shape_mn.R b/R/lsm_c_shape_mn.R index b49226dfe..828ccf7ee 100644 --- a/R/lsm_c_shape_mn.R +++ b/R/lsm_c_shape_mn.R @@ -61,29 +61,30 @@ lsm_c_shape_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_shape_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_shape_mn_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "shape_mn", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mean shape_mn <- stats::aggregate(x = shape[, 5], by = shape[, 2], FUN = mean, na.rm = TRUE) - return(tibble::tibble(level = "class", - class = as.integer(shape_mn$class), - id = as.integer(NA), - metric = "shape_mn", - value = as.double(shape_mn$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(shape_mn)), + class = as.integer(shape_mn$class), + id = rep(as.integer(NA), nrow(shape_mn)), + metric = rep("shape_mn", nrow(shape_mn)), + value = as.double(shape_mn$value)))) } diff --git a/R/lsm_c_shape_sd.R b/R/lsm_c_shape_sd.R index 9b08cbbdd..f33683edc 100644 --- a/R/lsm_c_shape_sd.R +++ b/R/lsm_c_shape_sd.R @@ -61,20 +61,21 @@ lsm_c_shape_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_shape_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_c_shape_sd_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "shape_sd", - value = as.double(NA))) + value = as.double(NA)))) } # calculate sd @@ -82,9 +83,9 @@ lsm_c_shape_sd_calc <- function(landscape, directions, resolution = NULL){ FUN = stats::sd, na.rm = TRUE) - return(tibble::tibble(level = "class", - class = as.integer(shape_sd$class), - id = as.integer(NA), - metric = "shape_sd", - value = as.double(shape_sd$value))) + return(tibble::new_tibble(list(level = rep("class", nrow(shape_sd)), + class = as.integer(shape_sd$class), + id = rep(as.integer(NA), nrow(shape_sd)), + metric = rep("shape_sd", nrow(shape_sd)), + value = as.double(shape_sd$value)))) } diff --git a/R/lsm_c_split.R b/R/lsm_c_split.R index 7d0560167..5d2e2bd79 100644 --- a/R/lsm_c_split.R +++ b/R/lsm_c_split.R @@ -58,23 +58,24 @@ lsm_c_split <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_split_calc <- function(landscape, directions, resolution = NULL) { +lsm_c_split_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area_total <- sum(area_patch$value) # all values NA if (is.na(area_total)) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "split", - value = as.double(NA))) + value = as.double(NA)))) } # calculate split for each patch @@ -86,9 +87,11 @@ lsm_c_split_calc <- function(landscape, directions, resolution = NULL) { # calculate split split$value <- (area_total ^ 2) / split$value - return(tibble::tibble(level = "class", - class = as.integer(split$class), - id = as.integer(NA), - metric = "split", - value = as.double(split$value))) + return(tibble::new_tibble(list( + level = rep("class", nrow(split)), + class = as.integer(split$class), + id = rep(as.integer(NA), nrow(split)), + metric = rep("split", nrow(split)), + value = as.double(split$value) + ))) } diff --git a/R/lsm_c_tca.R b/R/lsm_c_tca.R index 5fab1989e..0bb5b9116 100644 --- a/R/lsm_c_tca.R +++ b/R/lsm_c_tca.R @@ -64,29 +64,33 @@ lsm_c_tca <- function(landscape, directions = 8, consider_boundary = FALSE, edge tibble::add_column(result, layer, .before = TRUE) } -lsm_c_tca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_c_tca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core_area <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all cells are NA if (all(is.na(core_area$value))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "tca", - value = as.double(NA))) + value = as.double(NA)))) } core_area <- stats::aggregate(x = core_area[, 5], by = core_area[, 2], FUN = sum) - return(tibble::tibble(level = "class", - class = as.integer(core_area$class), - id = as.integer(NA), - metric = "tca", - value = as.double(core_area$value))) + return(tibble::new_tibble(list( + level = rep("class", length(core_area$value)), + class = as.integer(core_area$class), + id = rep(as.integer(NA), length(core_area$value)), + metric = rep("tca", length(core_area$value)), + value = as.double(core_area$value) + )) + ) } diff --git a/R/lsm_c_te.R b/R/lsm_c_te.R index f39f71190..755e01e69 100644 --- a/R/lsm_c_te.R +++ b/R/lsm_c_te.R @@ -58,39 +58,40 @@ lsm_c_te <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_c_te_calc <- function(landscape, count_boundary, directions, resolution = NULL) { +lsm_c_te_calc <- function(landscape, count_boundary, directions, resolution, extras = NULL) { - # conver raster to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_c_te" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "class", + return(tibble::new_tibble(list(level = "class", class = as.integer(NA), id = as.integer(NA), metric = "te", - value = as.double(NA))) + value = as.double(NA)))) } - # get resolution in x-y directions + # get class id + classes <- extras$classes + class_patches <- extras$class_patches resolution_x <- resolution[[1]] resolution_y <- resolution[[2]] - # get class id - classes <- get_unique_values_int(landscape, verbose = FALSE) - if (length(classes) == 1 && !count_boundary) { - tibble::tibble( + tibble::new_tibble(list( level = "class", class = as.integer(classes), id = as.integer(NA), metric = "te", - value = as.double(0)) + value = as.double(0))) } else { @@ -109,9 +110,7 @@ lsm_c_te_calc <- function(landscape, count_boundary, directions, resolution = NU te_class <- lapply(X = classes, function(patches_class) { # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # set all non-class patches, but not NAs, to -999 edge_cells <- which(!is.na(landscape) & landscape != patches_class) @@ -163,12 +162,12 @@ lsm_c_te_calc <- function(landscape, count_boundary, directions, resolution = NU edge_ik <- edge_ik_left_right + edge_ik_top_bottom } - tibble::tibble( - level = "class", - class = as.integer(patches_class), - id = as.integer(NA), - metric = "te", - value = as.double(edge_ik)) + tibble::new_tibble(list( + level = rep("class", length(edge_ik)), + class = rep(as.integer(patches_class), length(edge_ik)), + id = rep(as.integer(NA), length(edge_ik)), + metric = rep("te", length(edge_ik)), + value = as.double(edge_ik))) }) do.call("rbind", te_class) diff --git a/R/lsm_l_ai.R b/R/lsm_l_ai.R index 2ad41b147..3010c4247 100644 --- a/R/lsm_l_ai.R +++ b/R/lsm_l_ai.R @@ -3,7 +3,9 @@ #' @description Aggregation index (Aggregation metric) #' #' @param landscape A categorical raster object: SpatRaster; Raster* Layer, Stack, Brick; stars or a list of SpatRasters -#' +#' @param directions The number of directions in which patches should be +#' connected: 4 (rook's case) or 8 (queen's case). +#' #' @details #' \deqn{AI = \Bigg[\sum\limits_{i=1}^m \Big( \frac{g_{ii}}{max-g_{ii}} \Big) P_{i} \Bigg](100) } #' @@ -41,10 +43,11 @@ #' to quantify spatial patterns of landscapes. Landscape ecology, 15(7), 591-601. #' #' @export -lsm_l_ai <- function(landscape) { +lsm_l_ai <- function(landscape, directions = 8) { landscape <- landscape_as_list(landscape) result <- lapply(X = landscape, + directions = directions, FUN = lsm_l_ai_calc) layer <- rep(seq_along(result), @@ -55,39 +58,42 @@ lsm_l_ai <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_ai_calc <- function(landscape, resolution = NULL) { +lsm_l_ai_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_ai" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "ai", - value = as.double(NA))) + value = as.double(NA)))) } # get aggregation index for each class - ai <- lsm_c_ai_calc(landscape) + ai <- lsm_c_ai_calc(landscape, extras = extras) # get proportional class area pland <- lsm_c_pland_calc(landscape, - directions = 8, - resolution = resolution) + directions = 8, + resolution = resolution, + extras = extras) # final AI index - result <- sum(ai$value * (pland$value / 100), na.rm = TRUE) + ai <- sum(ai$value * (pland$value / 100), na.rm = TRUE) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "ai", - value = as.double(result))) + return(tibble::new_tibble(list(level = rep("landscape", length(ai)), + class = rep(as.integer(NA), length(ai)), + id = rep(as.integer(NA), length(ai)), + metric = rep("ai", length(ai)), + value = as.double(ai)))) } diff --git a/R/lsm_l_area_cv.R b/R/lsm_l_area_cv.R index 82803068a..51bdfcec0 100644 --- a/R/lsm_l_area_cv.R +++ b/R/lsm_l_area_cv.R @@ -57,28 +57,29 @@ lsm_l_area_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_area_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_area_cv_calc <- function(landscape, directions, resolution, extras = NULL){ # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "area_cv", - value = as.double(NA))) + value = as.double(NA)))) } # calculate cv area_cv <- stats::sd(area_patch$value) / mean(area_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "area_cv", - value = as.double(area_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(area_cv)), + class = rep(as.integer(NA), length(area_cv)), + id = rep(as.integer(NA), length(area_cv)), + metric = rep("area_cv", length(area_cv)), + value = as.double(area_cv)))) } diff --git a/R/lsm_l_area_mn.R b/R/lsm_l_area_mn.R index ab9d48052..8a2d66685 100644 --- a/R/lsm_l_area_mn.R +++ b/R/lsm_l_area_mn.R @@ -59,30 +59,31 @@ lsm_l_area_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_area_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_area_mn_calc <- function(landscape, directions, resolution, extras = NULL){ # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "area_mn", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mean - area_mean <- mean(area_patch$value) + area_mn <- mean(area_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "area_mn", - value = as.double(area_mean))) + return(tibble::new_tibble(list(level = rep("landscape", length(area_mn)), + class = rep(as.integer(NA), length(area_mn)), + id = rep(as.integer(NA), length(area_mn)), + metric = rep("area_mn", length(area_mn)), + value = as.double(area_mn)))) } diff --git a/R/lsm_l_area_sd.R b/R/lsm_l_area_sd.R index 2961e8b72..3ace5011a 100644 --- a/R/lsm_l_area_sd.R +++ b/R/lsm_l_area_sd.R @@ -58,30 +58,31 @@ lsm_l_area_sd <- function(landscape, directions = 8) { } # Not working yet! -lsm_l_area_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_area_sd_calc <- function(landscape, directions, resolution, extras = NULL){ # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(area_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "area_sd", - value = as.double(NA))) + value = as.double(NA)))) } # calculate sd area_sd <- stats::sd(area_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "area_sd", - value = as.double(area_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(area_sd)), + class = rep(as.integer(NA), length(area_sd)), + id = rep(as.integer(NA), length(area_sd)), + metric = rep("area_sd", length(area_sd)), + value = as.double(area_sd)))) } diff --git a/R/lsm_l_cai_cv.R b/R/lsm_l_cai_cv.R index 1f3e61f9c..92125ba98 100644 --- a/R/lsm_l_cai_cv.R +++ b/R/lsm_l_cai_cv.R @@ -71,28 +71,29 @@ lsm_l_cai_cv <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_cai_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_cai_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ cai_patch <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "cai_cv", - value = as.double(NA))) + value = as.double(NA)))) } cai_cv <- stats::sd(cai_patch$value) / mean(cai_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "cai_cv", - value = as.double(cai_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(cai_cv)), + class = rep(as.integer(NA), length(cai_cv)), + id = rep(as.integer(NA), length(cai_cv)), + metric = rep("cai_cv", length(cai_cv)), + value = as.double(cai_cv)))) } diff --git a/R/lsm_l_cai_mn.R b/R/lsm_l_cai_mn.R index 35d758e1a..496b53276 100644 --- a/R/lsm_l_cai_mn.R +++ b/R/lsm_l_cai_mn.R @@ -69,29 +69,29 @@ lsm_l_cai_mn <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_cai_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_cai_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ cai_patch <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "cai_mn", - value = as.double(NA))) + value = as.double(NA)))) } + cai_mn <- mean(cai_patch$value) - cai_mean <- mean(cai_patch$value) - - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "cai_mn", - value = as.double(cai_mean))) + return(tibble::new_tibble(list(level = rep("landscape", length(cai_mn)), + class = rep(as.integer(NA), length(cai_mn)), + id = rep(as.integer(NA), length(cai_mn)), + metric = rep("cai_mn", length(cai_mn)), + value = as.double(cai_mn)))) } diff --git a/R/lsm_l_cai_sd.R b/R/lsm_l_cai_sd.R index 71bd8ebc6..f638fd2aa 100644 --- a/R/lsm_l_cai_sd.R +++ b/R/lsm_l_cai_sd.R @@ -71,29 +71,29 @@ lsm_l_cai_sd <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_cai_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_cai_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ cai_patch <- lsm_p_cai_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(cai_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "cai_sd", - value = as.double(NA))) + value = as.double(NA)))) } - cai_sd <- stats::sd(cai_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "cai_sd", - value = as.double(cai_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(cai_sd)), + class = rep(as.integer(NA), length(cai_sd)), + id = rep(as.integer(NA), length(cai_sd)), + metric = rep("cai_sd", length(cai_sd)), + value = as.double(cai_sd)))) } diff --git a/R/lsm_l_circle_cv.R b/R/lsm_l_circle_cv.R index de56e1bca..f18766862 100644 --- a/R/lsm_l_circle_cv.R +++ b/R/lsm_l_circle_cv.R @@ -66,27 +66,28 @@ lsm_l_circle_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_circle_cv_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_circle_cv_calc <- function(landscape, directions, resolution, extras = NULL) { circle_patch <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "circle_cv", - value = as.double(NA))) + value = as.double(NA)))) } circle_cv <- stats::sd(circle_patch$value) / mean(circle_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "circle_cv", - value = as.double(circle_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(circle_cv)), + class = rep(as.integer(NA), length(circle_cv)), + id = rep(as.integer(NA), length(circle_cv)), + metric = rep("circle_cv", length(circle_cv)), + value = as.double(circle_cv)))) } diff --git a/R/lsm_l_circle_mn.R b/R/lsm_l_circle_mn.R index adebacaa4..82389d69e 100644 --- a/R/lsm_l_circle_mn.R +++ b/R/lsm_l_circle_mn.R @@ -65,26 +65,27 @@ lsm_l_circle_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_circle_mn_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_circle_mn_calc <- function(landscape, directions, resolution, extras = NULL) { circle_patch <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "circle_mn", - value = as.double(NA))) + value = as.double(NA)))) } circle_mn <- mean(circle_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "circle_mn", - value = as.double(circle_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(circle_mn)), + class = rep(as.integer(NA), length(circle_mn)), + id = rep(as.integer(NA), length(circle_mn)), + metric = rep("circle_mn", length(circle_mn)), + value = as.double(circle_mn)))) } diff --git a/R/lsm_l_circle_sd.R b/R/lsm_l_circle_sd.R index 4d8b929bf..bb15a9272 100644 --- a/R/lsm_l_circle_sd.R +++ b/R/lsm_l_circle_sd.R @@ -67,27 +67,28 @@ lsm_l_circle_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_circle_sd_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_circle_sd_calc <- function(landscape, directions, resolution, extras = NULL) { circle_patch <- lsm_p_circle_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(circle_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "circle_cv", - value = as.double(NA))) + value = as.double(NA)))) } circle_sd <- stats::sd(circle_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "circle_sd", - value = as.double(circle_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(circle_sd)), + class = rep(as.integer(NA), length(circle_sd)), + id = rep(as.integer(NA), length(circle_sd)), + metric = rep("circle_sd", length(circle_sd)), + value = as.double(circle_sd)))) } diff --git a/R/lsm_l_cohesion.R b/R/lsm_l_cohesion.R index 21c6bfa5e..617bfda4a 100644 --- a/R/lsm_l_cohesion.R +++ b/R/lsm_l_cohesion.R @@ -54,22 +54,25 @@ lsm_l_cohesion <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_cohesion_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_cohesion_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to raster to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_cohesion" + resolution <- terra::res(landscape) landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "cohesion", - value = as.double(NA))) + value = as.double(NA)))) } # get number of cells @@ -78,14 +81,16 @@ lsm_l_cohesion_calc <- function(landscape, directions, resolution = NULL) { # get number of cells in each patch: area = n_cells * res / 10000 ncells_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) ncells_patch$value <- ncells_patch$value * 10000 / prod(resolution) # get perim for each patch perim_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # denominator for cohesion (perim / n_cells) for landscape denominator <- sum(perim_patch$value * sqrt(ncells_patch$value)) @@ -94,9 +99,9 @@ lsm_l_cohesion_calc <- function(landscape, directions, resolution = NULL) { cohesion <- (1 - (sum(perim_patch$value) / denominator)) * ((1 - (1 / sqrt(ncells_landscape))) ^ -1) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "cohesion", - value = as.double(cohesion))) + return(tibble::new_tibble(list(level = rep("landscape", length(cohesion)), + class = rep(as.integer(NA), length(cohesion)), + id = rep(as.integer(NA), length(cohesion)), + metric = rep("cohesion", length(cohesion)), + value = as.double(cohesion)))) } diff --git a/R/lsm_l_condent.R b/R/lsm_l_condent.R index 82a50311d..e461bb5f6 100644 --- a/R/lsm_l_condent.R +++ b/R/lsm_l_condent.R @@ -57,7 +57,7 @@ lsm_l_condent <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_condent_calc <- function(landscape, neighbourhood, ordered, base){ +lsm_l_condent_calc <- function(landscape, neighbourhood, ordered, base, extras = NULL){ # convert to raster to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -66,29 +66,27 @@ lsm_l_condent_calc <- function(landscape, neighbourhood, ordered, base){ # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "condent", - value = as.double(NA))) + value = as.double(NA)))) } - com <- rcpp_get_coocurrence_matrix(landscape, - directions = as.matrix(neighbourhood)) - com_c <- colSums(com) - - coh <- rcpp_get_coocurrence_vector(landscape, - directions = as.matrix(neighbourhood), - ordered = ordered) - - comp <- rcpp_get_entropy(com_c, base) - cplx <- rcpp_get_entropy(coh, base) + if (!is.null(extras)){ + comp <- extras$comp + cplx <- extras$cplx + } else { + com <- rcpp_get_coocurrence_matrix(landscape, directions = as.matrix(neighbourhood)) + comp <- rcpp_get_entropy(colSums(com), base) + cplx <- get_complexity(landscape, neighbourhood, ordered, base) + } conf <- cplx - comp - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "condent", - value = as.double(conf))) + return(tibble::new_tibble(list(level = rep("landscape", length(conf)), + class = rep(as.integer(NA), length(conf)), + id = rep(as.integer(NA), length(conf)), + metric = rep("condent", length(conf)), + value = as.double(conf)))) } diff --git a/R/lsm_l_contag.R b/R/lsm_l_contag.R index 9a929dbd0..3d556de58 100644 --- a/R/lsm_l_contag.R +++ b/R/lsm_l_contag.R @@ -59,7 +59,7 @@ lsm_l_contag <- function(landscape, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_contag_calc <- function(landscape, verbose) { +lsm_l_contag_calc <- function(landscape, verbose, extras = NULL) { # convert to raster to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -68,14 +68,18 @@ lsm_l_contag_calc <- function(landscape, verbose) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "contag", - value = as.double(NA))) + value = as.double(NA)))) } - t <- length(get_unique_values_int(landscape, verbose = FALSE)) + if (!is.null(extras)){ + t <- length(extras$classes) + } else { + t <- length(get_unique_values_int(landscape, verbose = FALSE)) + } if (t < 2) { if (verbose) { @@ -83,15 +87,18 @@ lsm_l_contag_calc <- function(landscape, verbose) { call. = FALSE) } - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "contag", - value = as.double(NA))) + value = as.double(NA)))) } else { - adjacencies <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + if (!is.null(extras)){ + adjacencies <- extras$neighbor_matrix + } else { + adjacencies <- rcpp_get_coocurrence_matrix(landscape, as.matrix(4)) + } esum <- sum(adjacencies / sum(adjacencies) * log(adjacencies / sum(adjacencies)), na.rm = TRUE) @@ -100,10 +107,10 @@ lsm_l_contag_calc <- function(landscape, verbose) { contag <- (1 + esum / emax) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "contag", - value = as.double(contag))) + return(tibble::new_tibble(list(level = rep("landscape", length(contag)), + class = rep(as.integer(NA), length(contag)), + id = rep(as.integer(NA), length(contag)), + metric = rep("contag", length(contag)), + value = as.double(contag)))) } } diff --git a/R/lsm_l_contig_cv.R b/R/lsm_l_contig_cv.R index 0921049a4..13f3762a8 100644 --- a/R/lsm_l_contig_cv.R +++ b/R/lsm_l_contig_cv.R @@ -71,25 +71,26 @@ lsm_l_contig_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_contig_cv_calc <- function(landscape, directions) { +lsm_l_contig_cv_calc <- function(landscape, directions, extras = NULL) { contig_patch <- lsm_p_contig_calc(landscape, - directions = directions) + directions = directions, + extras = extras) # all values NA if (all(is.na(contig_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "contig_cv", - value = as.double(NA))) + value = as.double(NA)))) } contig_cv <- stats::sd(contig_patch$value) / mean(contig_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "contig_cv", - value = as.double(contig_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(contig_cv)), + class = rep(as.integer(NA), length(contig_cv)), + id = rep(as.integer(NA), length(contig_cv)), + metric = rep("contig_cv", length(contig_cv)), + value = as.double(contig_cv)))) } diff --git a/R/lsm_l_contig_mn.R b/R/lsm_l_contig_mn.R index b87858977..ca162871b 100644 --- a/R/lsm_l_contig_mn.R +++ b/R/lsm_l_contig_mn.R @@ -70,25 +70,26 @@ lsm_l_contig_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_contig_mn_calc <- function(landscape, directions) { +lsm_l_contig_mn_calc <- function(landscape, directions, extras = NULL) { contig_patch <- lsm_p_contig_calc(landscape, - directions = directions) + directions = directions, + extras = extras) # all values NA if (all(is.na(contig_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "contig_mn", - value = as.double(NA))) + value = as.double(NA)))) } contig_mn <- mean(contig_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "contig_mn", - value = as.double(contig_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(contig_mn)), + class = rep(as.integer(NA), length(contig_mn)), + id = rep(as.integer(NA), length(contig_mn)), + metric = rep("contig_mn", length(contig_mn)), + value = as.double(contig_mn)))) } diff --git a/R/lsm_l_contig_sd.R b/R/lsm_l_contig_sd.R index d04c6dd56..4ce09de76 100644 --- a/R/lsm_l_contig_sd.R +++ b/R/lsm_l_contig_sd.R @@ -71,25 +71,26 @@ lsm_l_contig_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_contig_sd_calc <- function(landscape, directions) { +lsm_l_contig_sd_calc <- function(landscape, directions, extras = NULL) { contig_patch <- lsm_p_contig_calc(landscape, - directions = directions) + directions = directions, + extras = extras) # all values NA if (all(is.na(contig_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "contig_sd", - value = as.double(NA))) + value = as.double(NA)))) } contig_sd <- stats::sd(contig_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "contig_sd", - value = as.double(contig_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(contig_sd)), + class = rep(as.integer(NA), length(contig_sd)), + id = rep(as.integer(NA), length(contig_sd)), + metric = rep("contig_sd", length(contig_sd)), + value = as.double(contig_sd)))) } diff --git a/R/lsm_l_core_cv.R b/R/lsm_l_core_cv.R index e68704992..f4b4f0e73 100644 --- a/R/lsm_l_core_cv.R +++ b/R/lsm_l_core_cv.R @@ -68,28 +68,29 @@ lsm_l_core_cv <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_core_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_core_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core_patch <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "core_cv", - value = as.double(NA))) + value = as.double(NA)))) } core_cv <- stats::sd(core_patch$value) / mean(core_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "core_cv", - value = as.double(core_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(core_cv)), + class = rep(as.integer(NA), length(core_cv)), + id = rep(as.integer(NA), length(core_cv)), + metric = rep("core_cv", length(core_cv)), + value = as.double(core_cv)))) } diff --git a/R/lsm_l_core_mn.R b/R/lsm_l_core_mn.R index 4a3d02a35..e7597e9e0 100644 --- a/R/lsm_l_core_mn.R +++ b/R/lsm_l_core_mn.R @@ -67,28 +67,29 @@ lsm_l_core_mn <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_core_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_core_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core_patch <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "core_mn", - value = as.double(NA))) + value = as.double(NA)))) } core_mn <- mean(core_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "core_mn", - value = as.double(core_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(core_mn)), + class = rep(as.integer(NA), length(core_mn)), + id = rep(as.integer(NA), length(core_mn)), + metric = rep("core_mn", length(core_mn)), + value = as.double(core_mn)))) } diff --git a/R/lsm_l_core_sd.R b/R/lsm_l_core_sd.R index 669ca668c..20eb6d7ed 100644 --- a/R/lsm_l_core_sd.R +++ b/R/lsm_l_core_sd.R @@ -68,28 +68,29 @@ lsm_l_core_sd <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_core_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_l_core_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ core_patch <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(core_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "core_sd", - value = as.double(NA))) + value = as.double(NA)))) } core_sd <- stats::sd(core_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "core_sd", - value = as.double(core_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(core_sd)), + class = rep(as.integer(NA), length(core_sd)), + id = rep(as.integer(NA), length(core_sd)), + metric = rep("core_sd", length(core_sd)), + value = as.double(core_sd)))) } diff --git a/R/lsm_l_dcad.R b/R/lsm_l_dcad.R index 9b3995982..a00475964 100644 --- a/R/lsm_l_dcad.R +++ b/R/lsm_l_dcad.R @@ -67,24 +67,24 @@ lsm_l_dcad <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth, - resolution = NULL, points = NULL){ +lsm_l_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area total_area <- sum(patch_area$value) # all values NA if (is.na(total_area)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "dcad", - value = as.double(NA))) + value = as.double(NA)))) } # get core areas for each patch @@ -92,14 +92,15 @@ lsm_l_dcad_calc <- function(landscape, directions, consider_boundary, edge_depth directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # summarise for total landscape dcad <- sum(ncore_patch$value) / total_area * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "dcad", - value = as.double(dcad))) + return(tibble::new_tibble(list(level = rep("landscape", length(dcad)), + class = rep(as.integer(NA), length(dcad)), + id = rep(as.integer(NA), length(dcad)), + metric = rep("dcad", length(dcad)), + value = as.double(dcad)))) } diff --git a/R/lsm_l_dcore_cv.R b/R/lsm_l_dcore_cv.R index 3ba4c0c66..c5d5646cd 100644 --- a/R/lsm_l_dcore_cv.R +++ b/R/lsm_l_dcore_cv.R @@ -70,29 +70,29 @@ lsm_l_dcore_cv <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_dcore_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_l_dcore_cv_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore_patch <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(dcore_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "dcore_cv", - value = as.double(NA))) + value = as.double(NA)))) } dcore_cv <- stats::sd(dcore_patch$value) / mean(dcore_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "dcore_cv", - value = as.double(dcore_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(dcore_cv)), + class = rep(as.integer(NA), length(dcore_cv)), + id = rep(as.integer(NA), length(dcore_cv)), + metric = rep("dcore_cv", length(dcore_cv)), + value = as.double(dcore_cv)))) } diff --git a/R/lsm_l_dcore_mn.R b/R/lsm_l_dcore_mn.R index 0c17831e3..c9dc636a8 100644 --- a/R/lsm_l_dcore_mn.R +++ b/R/lsm_l_dcore_mn.R @@ -68,29 +68,29 @@ lsm_l_dcore_mn <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_dcore_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_l_dcore_mn_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore_patch <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(dcore_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "dcore_mn", - value = as.double(NA))) + value = as.double(NA)))) } dcore_mn <- mean(dcore_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "dcore_mn", - value = as.double(dcore_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(dcore_mn)), + class = rep(as.integer(NA), length(dcore_mn)), + id = rep(as.integer(NA), length(dcore_mn)), + metric = rep("dcore_mn", length(dcore_mn)), + value = as.double(dcore_mn)))) } diff --git a/R/lsm_l_dcore_sd.R b/R/lsm_l_dcore_sd.R index 63fc0b496..fc0246dd5 100644 --- a/R/lsm_l_dcore_sd.R +++ b/R/lsm_l_dcore_sd.R @@ -70,29 +70,29 @@ lsm_l_dcore_sd <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_dcore_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_l_dcore_sd_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ dcore_patch <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(dcore_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "dcore_sd", - value = as.double(NA))) + value = as.double(NA)))) } dcore_sd <- stats::sd(dcore_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "dcore_sd", - value = as.double(dcore_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(dcore_sd)), + class = rep(as.integer(NA), length(dcore_sd)), + id = rep(as.integer(NA), length(dcore_sd)), + metric = rep("dcore_sd", length(dcore_sd)), + value = as.double(dcore_sd)))) } diff --git a/R/lsm_l_division.R b/R/lsm_l_division.R index d3e4c7d00..d16d2983d 100644 --- a/R/lsm_l_division.R +++ b/R/lsm_l_division.R @@ -58,23 +58,24 @@ lsm_l_division <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_division_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_division_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area_total <- sum(area_patch$value) # all values NA if (is.na(area_total)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "division", - value = as.double(NA))) + value = as.double(NA)))) } # divison for each patch @@ -83,9 +84,9 @@ lsm_l_division_calc <- function(landscape, directions, resolution = NULL) { # summarise for whole landscape division <- 1 - sum(area_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "division", - value = as.double(division))) + return(tibble::new_tibble(list(level = rep("landscape", length(division)), + class = rep(as.integer(NA), length(division)), + id = rep(as.integer(NA), length(division)), + metric = rep("division", length(division)), + value = as.double(division)))) } diff --git a/R/lsm_l_ed.R b/R/lsm_l_ed.R index d34fa8960..7e84d06bc 100644 --- a/R/lsm_l_ed.R +++ b/R/lsm_l_ed.R @@ -62,28 +62,31 @@ lsm_l_ed <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_ed_calc <- function(landscape, count_boundary, directions, resolution = NULL) { +lsm_l_ed_calc <- function(landscape, count_boundary, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_ed" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, neighbourhood = 4, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "ed", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area_total <- sum(area_patch$value) @@ -91,14 +94,15 @@ lsm_l_ed_calc <- function(landscape, count_boundary, directions, resolution = NU # get total edge edge_landscape <- lsm_l_te_calc(landscape, count_boundary = count_boundary, - resolution = resolution) + resolution = resolution, + extras = extras) # relative edge density ed <- edge_landscape$value / area_total - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "ed", - value = as.double(ed))) + return(tibble::new_tibble(list(level = rep("landscape", length(ed)), + class = rep(as.integer(NA), length(ed)), + id = rep(as.integer(NA), length(ed)), + metric = rep("ed", length(ed)), + value = as.double(ed)))) } diff --git a/R/lsm_l_enn_cv.R b/R/lsm_l_enn_cv.R index 4c7c39f77..fd30335f3 100644 --- a/R/lsm_l_enn_cv.R +++ b/R/lsm_l_enn_cv.R @@ -66,27 +66,26 @@ lsm_l_enn_cv <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_enn_cv_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_l_enn_cv_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn_patch <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all values NA if (all(is.na(enn_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "enn_cv", - value = as.double(NA))) + value = as.double(NA)))) } enn_cv <- stats::sd(enn_patch$value) / mean(enn_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "enn_cv", - value = as.double(enn_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(enn_cv)), + class = rep(as.integer(NA), length(enn_cv)), + id = rep(as.integer(NA), length(enn_cv)), + metric = rep("enn_cv", length(enn_cv)), + value = as.double(enn_cv)))) } diff --git a/R/lsm_l_enn_mn.R b/R/lsm_l_enn_mn.R index fd3fa5f51..40d746a67 100644 --- a/R/lsm_l_enn_mn.R +++ b/R/lsm_l_enn_mn.R @@ -67,27 +67,26 @@ lsm_l_enn_mn <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_enn_mn_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_l_enn_mn_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn_patch <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all values NA if (all(is.na(enn_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "enn_mn", - value = as.double(NA))) + value = as.double(NA)))) } enn_mn <- mean(enn_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "enn_mn", - value = as.double(enn_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(enn_mn)), + class = rep(as.integer(NA), length(enn_mn)), + id = rep(as.integer(NA), length(enn_mn)), + metric = rep("enn_mn", length(enn_mn)), + value = as.double(enn_mn)))) } diff --git a/R/lsm_l_enn_sd.R b/R/lsm_l_enn_sd.R index 409f8fd59..66a1b0308 100644 --- a/R/lsm_l_enn_sd.R +++ b/R/lsm_l_enn_sd.R @@ -67,27 +67,26 @@ lsm_l_enn_sd <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_enn_sd_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_l_enn_sd_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { enn_patch <- lsm_p_enn_calc(landscape, directions = directions, verbose = verbose, - points = points) + resolution = resolution, extras = extras) # all values NA if (all(is.na(enn_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "enn_sd", - value = as.double(NA))) + value = as.double(NA)))) } enn_sd <- stats::sd(enn_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "enn_sd", - value = as.double(enn_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(enn_sd)), + class = rep(as.integer(NA), length(enn_sd)), + id = rep(as.integer(NA), length(enn_sd)), + metric = rep("enn_sd", length(enn_sd)), + value = as.double(enn_sd)))) } diff --git a/R/lsm_l_ent.R b/R/lsm_l_ent.R index 1e0fee36e..7b4503085 100644 --- a/R/lsm_l_ent.R +++ b/R/lsm_l_ent.R @@ -50,7 +50,7 @@ lsm_l_ent <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_ent_calc <- function(landscape, neighbourhood, base){ +lsm_l_ent_calc <- function(landscape, neighbourhood, base, extras = NULL){ # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -59,22 +59,23 @@ lsm_l_ent_calc <- function(landscape, neighbourhood, base){ # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "ent", - value = as.double(NA))) + value = as.double(NA)))) } - com <- rcpp_get_coocurrence_matrix(landscape, - directions = as.matrix(neighbourhood)) - com_c <- colSums(com) - - comp <- rcpp_get_entropy(com_c, base) + if (!is.null(extras)){ + comp <- extras$comp + } else { + com <- rcpp_get_coocurrence_matrix(landscape, directions = as.matrix(neighbourhood)) + comp <- rcpp_get_entropy(colSums(com), base) + } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "ent", - value = as.double(comp))) + return(tibble::new_tibble(list(level = rep("landscape", length(comp)), + class = rep(as.integer(NA), length(comp)), + id = rep(as.integer(NA), length(comp)), + metric = rep("ent", length(comp)), + value = as.double(comp)))) } diff --git a/R/lsm_l_frac_cv.R b/R/lsm_l_frac_cv.R index 5f5804cc0..9d5e58b2a 100644 --- a/R/lsm_l_frac_cv.R +++ b/R/lsm_l_frac_cv.R @@ -63,26 +63,27 @@ lsm_l_frac_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_frac_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_frac_cv_calc <- function(landscape, directions, resolution, extras = NULL){ frac_patch <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(frac_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "frac_cv", - value = as.double(NA))) + value = as.double(NA)))) } frac_cv <- stats::sd(frac_patch$value) / mean(frac_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "frac_cv", - value = as.double(frac_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(frac_cv)), + class = rep(as.integer(NA), length(frac_cv)), + id = rep(as.integer(NA), length(frac_cv)), + metric = rep("frac_cv", length(frac_cv)), + value = as.double(frac_cv)))) } diff --git a/R/lsm_l_frac_mn.R b/R/lsm_l_frac_mn.R index 87ef21bfa..b7b00deff 100644 --- a/R/lsm_l_frac_mn.R +++ b/R/lsm_l_frac_mn.R @@ -63,26 +63,27 @@ lsm_l_frac_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_frac_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_frac_mn_calc <- function(landscape, directions, resolution, extras = NULL){ frac_patch <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(frac_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "frac_mn", - value = as.double(NA))) + value = as.double(NA)))) } frac_mn <- mean(frac_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "frac_mn", - value = as.double(frac_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(frac_mn)), + class = rep(as.integer(NA), length(frac_mn)), + id = rep(as.integer(NA), length(frac_mn)), + metric = rep("frac_mn", length(frac_mn)), + value = as.double(mean(frac_patch$value))))) } diff --git a/R/lsm_l_frac_sd.R b/R/lsm_l_frac_sd.R index 458fb35e6..56139fe17 100644 --- a/R/lsm_l_frac_sd.R +++ b/R/lsm_l_frac_sd.R @@ -63,26 +63,27 @@ lsm_l_frac_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_frac_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_frac_sd_calc <- function(landscape, directions, resolution, extras = NULL){ frac_patch <- lsm_p_frac_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(frac_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "frac_sd", - value = as.double(NA))) + value = as.double(NA)))) } frac_sd <- stats::sd(frac_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "frac_sd", - value = as.double(frac_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(frac_sd)), + class = rep(as.integer(NA), length(frac_sd)), + id = rep(as.integer(NA), length(frac_sd)), + metric = rep("frac_sd", length(frac_sd)), + value = as.double(frac_sd)))) } diff --git a/R/lsm_l_gyrate_cv.R b/R/lsm_l_gyrate_cv.R index 144694f70..170012e1b 100644 --- a/R/lsm_l_gyrate_cv.R +++ b/R/lsm_l_gyrate_cv.R @@ -72,29 +72,29 @@ lsm_l_gyrate_cv <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_cv_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_l_gyrate_cv_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(gyrate_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_cv", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_cv <- stats::sd(gyrate_patch$value) / mean(gyrate_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "gyrate_cv", - value = as.double(gyrate_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(gyrate_cv)), + class = rep(as.integer(NA), length(gyrate_cv)), + id = rep(as.integer(NA), length(gyrate_cv)), + metric = rep("gyrate_cv", length(gyrate_cv)), + value = as.double(gyrate_cv)))) } diff --git a/R/lsm_l_gyrate_mn.R b/R/lsm_l_gyrate_mn.R index 801999f8f..55880ad02 100644 --- a/R/lsm_l_gyrate_mn.R +++ b/R/lsm_l_gyrate_mn.R @@ -71,28 +71,28 @@ lsm_l_gyrate_mn <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_mn_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_l_gyrate_mn_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(gyrate_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_mn", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_mn <- mean(gyrate_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "gyrate_mn", - value = as.double(gyrate_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(gyrate_mn)), + class = rep(as.integer(NA), length(gyrate_mn)), + id = rep(as.integer(NA), length(gyrate_mn)), + metric = rep("gyrate_mn", length(gyrate_mn)), + value = as.double(gyrate_mn)))) } diff --git a/R/lsm_l_gyrate_sd.R b/R/lsm_l_gyrate_sd.R index 422623520..93132630e 100644 --- a/R/lsm_l_gyrate_sd.R +++ b/R/lsm_l_gyrate_sd.R @@ -71,29 +71,29 @@ lsm_l_gyrate_sd <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_sd_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_l_gyrate_sd_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, cell_center = cell_center, - points = points) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(gyrate_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "gyrate_sd", - value = as.double(NA))) + value = as.double(NA)))) } gyrate_sd <- stats::sd(gyrate_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "gyrate_sd", - value = as.double(gyrate_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(gyrate_sd)), + class = rep(as.integer(NA), length(gyrate_sd)), + id = rep(as.integer(NA), length(gyrate_sd)), + metric = rep("gyrate_sd", length(gyrate_sd)), + value = as.double(gyrate_sd)))) } diff --git a/R/lsm_l_iji.R b/R/lsm_l_iji.R index a7d1b8cdc..b1a7049eb 100644 --- a/R/lsm_l_iji.R +++ b/R/lsm_l_iji.R @@ -59,7 +59,7 @@ lsm_l_iji <- function(landscape, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_iji_calc <- function(landscape, verbose) { +lsm_l_iji_calc <- function(landscape, verbose, extras = NULL) { # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -68,15 +68,18 @@ lsm_l_iji_calc <- function(landscape, verbose) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "iji", - value = as.double(NA))) + value = as.double(NA)))) } - adjacencies <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + if (!is.null(extras)){ + adjacencies <- extras$neighbor_matrix + } else { + adjacencies <- rcpp_get_coocurrence_matrix(landscape, as.matrix(4)) + } if (ncol(adjacencies) < 3) { @@ -84,11 +87,11 @@ lsm_l_iji_calc <- function(landscape, verbose) { warning("Number of classes must be >= 3, IJI = NA.", call. = FALSE) } - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "iji", - value = as.double(NA))) + value = as.double(NA)))) } else { diag(adjacencies) <- 0 @@ -103,10 +106,10 @@ lsm_l_iji_calc <- function(landscape, verbose) { iji <- (landscape_sum / log(0.5 * (ncol(adjacencies) * (ncol(adjacencies) - 1)))) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "iji", - value = as.double(iji))) + return(tibble::new_tibble(list(level = rep("landscape", length(iji)), + class = rep(as.integer(NA), length(iji)), + id = rep(as.integer(NA), length(iji)), + metric = rep("iji", length(iji)), + value = as.double(iji)))) } } diff --git a/R/lsm_l_joinent.R b/R/lsm_l_joinent.R index 6d7d85276..3d3d8af0e 100644 --- a/R/lsm_l_joinent.R +++ b/R/lsm_l_joinent.R @@ -55,7 +55,7 @@ lsm_l_joinent <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_joinent_calc <- function(landscape, neighbourhood, ordered, base){ +lsm_l_joinent_calc <- function(landscape, neighbourhood, ordered, base, extras = NULL){ # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -64,22 +64,22 @@ lsm_l_joinent_calc <- function(landscape, neighbourhood, ordered, base){ # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "joinent", - value = as.double(NA))) + value = as.double(NA)))) } - coh <- rcpp_get_coocurrence_vector(landscape, - directions = as.matrix(neighbourhood), - ordered = ordered) - - cplx <- rcpp_get_entropy(coh, base) + if (!is.null(extras)){ + cplx <- extras$cplx + } else { + cplx <- get_complexity(landscape, neighbourhood, ordered, base) + } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "joinent", - value = as.double(cplx))) + return(tibble::new_tibble(list(level = rep("landscape", length(cplx)), + class = rep(as.integer(NA), length(cplx)), + id = rep(as.integer(NA), length(cplx)), + metric = rep("joinent", length(cplx)), + value = as.double(cplx)))) } diff --git a/R/lsm_l_lpi.R b/R/lsm_l_lpi.R index aff738f4f..0a92a50bd 100644 --- a/R/lsm_l_lpi.R +++ b/R/lsm_l_lpi.R @@ -55,31 +55,32 @@ lsm_l_lpi <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_lpi_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_lpi_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area total_area <- sum(patch_area$value) # all values NA if (is.na(total_area)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "lpi", - value = as.double(NA))) + value = as.double(NA)))) } # maximum value of patch_area / total_area lpi <- max(patch_area$value / total_area * 100) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "lpi", - value = as.double(lpi))) + return(tibble::new_tibble(list(level = rep("landscape", length(lpi)), + class = rep(as.integer(NA), length(lpi)), + id = rep(as.integer(NA), length(lpi)), + metric = rep("lpi", length(lpi)), + value = as.double(lpi)))) } diff --git a/R/lsm_l_lsi.R b/R/lsm_l_lsi.R index 19ae362cb..04dab16b6 100644 --- a/R/lsm_l_lsi.R +++ b/R/lsm_l_lsi.R @@ -55,43 +55,41 @@ lsm_l_lsi <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_lsi_calc <- function(landscape) { +lsm_l_lsi_calc <- function(landscape, extras = NULL) { # convert to matrix if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) - landscape <- terra::as.matrix(landscape, wide = TRUE) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "lsi", - value = as.double(NA))) + value = as.double(NA)))) } # cells at the boundary of the landscape need neighbours to calculate perim - landscape <- pad_raster_internal(landscape, pad_raster_value = NA, + landscape_pad <- pad_raster_internal(landscape, pad_raster_value = NA, pad_raster_cells = 1, global = FALSE) # which cells are NA (i.e. background) - target_na <- which(is.na(landscape)) + target_na <- which(is.na(landscape_pad)) # set all NA to -999 to get adjacencies between patches and all background - landscape[target_na] <- -999 + landscape_pad[target_na] <- -999 # get class edge in terms of cell surfaces - class_perim <- rcpp_get_coocurrence_matrix(landscape, - as.matrix(4)) + class_perim <- rcpp_get_coocurrence_matrix(landscape_pad, as.matrix(4)) + class_area <- rcpp_get_composition_vector(landscape_pad)[-1] # calculate total edge total_perim <- sum(class_perim[lower.tri(class_perim)]) # calculate total area - total_area <- sum(rcpp_get_composition_vector(landscape)[-1]) + total_area <- sum(class_area) # calculate N and M total_n <- trunc(sqrt(total_area)) @@ -114,9 +112,9 @@ lsm_l_lsi_calc <- function(landscape) { lsi <- total_perim / total_perim_min - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "lsi", - value = as.double(lsi))) + return(tibble::new_tibble(list(level = rep("landscape", length(lsi)), + class = rep(as.integer(NA), length(lsi)), + id = rep(as.integer(NA), length(lsi)), + metric = rep("lsi", length(lsi)), + value = as.double(lsi)))) } diff --git a/R/lsm_l_mesh.R b/R/lsm_l_mesh.R index 64b16e38b..369f9c966 100644 --- a/R/lsm_l_mesh.R +++ b/R/lsm_l_mesh.R @@ -60,31 +60,32 @@ lsm_l_mesh <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_mesh_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_mesh_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise to total area area_total <- sum(area_patch$value) # all values NA if (is.na(area_total)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "mesh", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mesh first take area ^ 2, than sum for whole landscape divided by landscape area total mesh <- sum(area_patch$value ^ 2) / area_total - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "mesh", - value = as.double(mesh))) + return(tibble::new_tibble(list(level = rep("landscape", length(mesh)), + class = rep(as.integer(NA), length(mesh)), + id = rep(as.integer(NA), length(mesh)), + metric = rep("mesh", length(mesh)), + value = as.double(mesh)))) } diff --git a/R/lsm_l_msidi.R b/R/lsm_l_msidi.R index 5cf964d9c..7290c8ab5 100644 --- a/R/lsm_l_msidi.R +++ b/R/lsm_l_msidi.R @@ -57,35 +57,38 @@ lsm_l_msidi <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_msidi_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_msidi_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_msidi" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "msidi", - value = as.double(NA))) + value = as.double(NA)))) } patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) msidi <- stats::aggregate(x = patch_area[, 5], by = patch_area[, 2], FUN = sum) msidi <- -log(sum((msidi$value / sum(msidi$value)) ^ 2)) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "msidi", - value = as.double(msidi))) + return(tibble::new_tibble(list(level = rep("landscape", length(msidi)), + class = rep(as.integer(NA), length(msidi)), + id = rep(as.integer(NA), length(msidi)), + metric = rep("msidi", length(msidi)), + value = as.double(msidi)))) } diff --git a/R/lsm_l_msiei.R b/R/lsm_l_msiei.R index d5c32b369..1f1889906 100644 --- a/R/lsm_l_msiei.R +++ b/R/lsm_l_msiei.R @@ -54,19 +54,20 @@ lsm_l_msiei <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_msiei_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_msiei_calc <- function(landscape, directions, resolution, extras = NULL) { patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(patch_area$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "msiei", - value = as.double(NA))) + value = as.double(NA)))) } msidi <- stats::aggregate(x = patch_area[, 5], by = patch_area[, 2], @@ -74,13 +75,18 @@ lsm_l_msiei_calc <- function(landscape, directions, resolution = NULL) { msidi <- -log(sum((msidi$value / sum(msidi$value)) ^ 2)) - pr <- length(get_unique_values_int(landscape, verbose = FALSE)) + if (!is.null(extras)){ + classes <- extras$classes + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + } + pr <- length(classes) msiei <- msidi / log(pr) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "msiei", - value = as.double(msiei))) + return(tibble::new_tibble(list(level = rep("landscape", length(msiei)), + class = rep(as.integer(NA), length(msiei)), + id = rep(as.integer(NA), length(msiei)), + metric = rep("msiei", length(msiei)), + value = as.double(msiei)))) } diff --git a/R/lsm_l_mutinf.R b/R/lsm_l_mutinf.R index b17aa1d87..eef30a8b8 100644 --- a/R/lsm_l_mutinf.R +++ b/R/lsm_l_mutinf.R @@ -56,7 +56,7 @@ lsm_l_mutinf <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_mutinf_calc <- function(landscape, neighbourhood, ordered, base){ +lsm_l_mutinf_calc <- function(landscape, neighbourhood, ordered, base, extras = NULL){ # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -65,29 +65,28 @@ lsm_l_mutinf_calc <- function(landscape, neighbourhood, ordered, base){ # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "mutinf", - value = as.double(NA))) + value = as.double(NA)))) } - com <- rcpp_get_coocurrence_matrix(landscape, - directions = as.matrix(neighbourhood)) - com_c <- colSums(com) - - coh <- rcpp_get_coocurrence_vector(landscape, - directions = as.matrix(neighbourhood), - ordered = ordered) + if (!is.null(extras)){ + comp <- extras$comp + cplx <- extras$cplx + } else { + com <- rcpp_get_coocurrence_matrix(landscape, directions = as.matrix(neighbourhood)) + comp <- rcpp_get_entropy(colSums(com), base) + cplx <- get_complexity(landscape, neighbourhood, ordered, base) + } - comp <- rcpp_get_entropy(com_c, base) - cplx <- rcpp_get_entropy(coh, base) conf <- cplx - comp aggr <- comp - conf - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "mutinf", - value = as.double(aggr))) + return(tibble::new_tibble(list(level = rep("landscape", length(aggr)), + class = rep(as.integer(NA), length(aggr)), + id = rep(as.integer(NA), length(aggr)), + metric = rep("mutinf", length(aggr)), + value = as.double(aggr)))) } diff --git a/R/lsm_l_ndca.R b/R/lsm_l_ndca.R index 738891982..7dc524126 100644 --- a/R/lsm_l_ndca.R +++ b/R/lsm_l_ndca.R @@ -67,29 +67,29 @@ lsm_l_ndca <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_ndca_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_l_ndca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ ncore_patch <- lsm_p_ncore_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - points = points) + resolution = resolution, + extras = extras) ndca <- sum(ncore_patch$value) # all values NA if (is.na(ndca)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "ndca", - value = as.double(NA))) + value = as.double(NA)))) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "ndca", - value = as.double(ndca))) + return(tibble::new_tibble(list(level = rep("landscape", length(ndca)), + class = rep(as.integer(NA), length(ndca)), + id = rep(as.integer(NA), length(ndca)), + metric = rep("ndca", length(ndca)), + value = as.double(ndca)))) } diff --git a/R/lsm_l_np.R b/R/lsm_l_np.R index bd51f011d..58a1c50d1 100644 --- a/R/lsm_l_np.R +++ b/R/lsm_l_np.R @@ -53,25 +53,26 @@ lsm_l_np <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_np_calc <- function(landscape, directions) { +lsm_l_np_calc <- function(landscape, directions, extras = NULL) { n_patches <- lsm_c_np_calc(landscape, - directions = directions) + directions = directions, + extras = extras) n_patches <- sum(n_patches$value) # all values NA if (is.na(n_patches)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "np", - value = as.double(NA))) + value = as.double(NA)))) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "np", - value = as.double(n_patches))) + return(tibble::new_tibble(list(level = rep("landscape", length(n_patches)), + class = rep(as.integer(NA), length(n_patches)), + id = rep(as.integer(NA), length(n_patches)), + metric = rep("np", length(n_patches)), + value = as.double(n_patches)))) } diff --git a/R/lsm_l_pafrac.R b/R/lsm_l_pafrac.R index f35356295..d8b4f2eb9 100644 --- a/R/lsm_l_pafrac.R +++ b/R/lsm_l_pafrac.R @@ -64,27 +64,30 @@ lsm_l_pafrac <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL){ +lsm_l_pafrac_calc <- function(landscape, directions, verbose, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) - landscape <-terra::as.matrix(landscape, wide = TRUE) + if (is.null(extras)){ + metrics <- "lsm_l_pafrac" + landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "pafrac", - value = as.double(NA))) + value = as.double(NA)))) } # get number of patches for each class number_patches <- lsm_c_np_calc(landscape, - directions = directions) + directions = directions, + extras = extras) # summarise for total landscape number_patches <- sum(number_patches$value) @@ -95,8 +98,7 @@ lsm_l_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL) pafrac <- NA if (verbose) { - warning("PAFRAC = NA for NP < 10", - call. = FALSE) + warning("PAFRAC = NA for NP < 10", call. = FALSE) } # calculate pafrac as regression between area and perimeter (beta) @@ -105,12 +107,14 @@ lsm_l_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL) # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # get patch perimeter perimeter_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) regression_model <- stats::lm(log(area_patch$value) ~ log(perimeter_patch$value)) @@ -118,9 +122,9 @@ lsm_l_pafrac_calc <- function(landscape, directions, verbose, resolution = NULL) pafrac <- 2 / regression_model$coefficients[[2]] } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "pafrac", - value = as.double(pafrac))) + return(tibble::new_tibble(list(level = rep("landscape", length(pafrac)), + class = rep(as.integer(NA), length(pafrac)), + id = rep(as.integer(NA), length(pafrac)), + metric = rep("pafrac", length(pafrac)), + value = as.double(pafrac)))) } diff --git a/R/lsm_l_para_cv.R b/R/lsm_l_para_cv.R index a41d17a5d..a26f1ad6b 100644 --- a/R/lsm_l_para_cv.R +++ b/R/lsm_l_para_cv.R @@ -60,26 +60,27 @@ lsm_l_para_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_para_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_para_cv_calc <- function(landscape, directions, resolution, extras = NULL){ para_patch <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(para_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "para_cv", - value = as.double(NA))) + value = as.double(NA)))) } para_cv <- stats::sd(para_patch$value) / mean(para_patch$value) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "para_cv", - value = as.double(para_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(para_cv)), + class = rep(as.integer(NA), length(para_cv)), + id = rep(as.integer(NA), length(para_cv)), + metric = rep("para_cv", length(para_cv)), + value = as.double(para_cv)))) } diff --git a/R/lsm_l_para_mn.R b/R/lsm_l_para_mn.R index c286c3327..f111329f5 100644 --- a/R/lsm_l_para_mn.R +++ b/R/lsm_l_para_mn.R @@ -61,26 +61,27 @@ lsm_l_para_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_para_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_para_mn_calc <- function(landscape, directions, resolution, extras = NULL){ para_patch <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(para_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "para_mn", - value = as.double(NA))) + value = as.double(NA)))) } para_mn <- mean(para_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "para_mn", - value = as.double(para_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(para_mn)), + class = rep(as.integer(NA), length(para_mn)), + id = rep(as.integer(NA), length(para_mn)), + metric = rep("para_mn", length(para_mn)), + value = as.double(para_mn)))) } diff --git a/R/lsm_l_para_sd.R b/R/lsm_l_para_sd.R index 46733d75a..e8fd56611 100644 --- a/R/lsm_l_para_sd.R +++ b/R/lsm_l_para_sd.R @@ -61,26 +61,27 @@ lsm_l_para_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_para_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_para_sd_calc <- function(landscape, directions, resolution, extras = NULL){ para_patch <- lsm_p_para_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(para_patch$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "para_sd", - value = as.double(NA))) + value = as.double(NA)))) } para_sd <- stats::sd(para_patch$value) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "para_sd", - value = as.double(para_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(para_sd)), + class = rep(as.integer(NA), length(para_sd)), + id = rep(as.integer(NA), length(para_sd)), + metric = rep("para_sd", length(para_sd)), + value = as.double(para_sd)))) } diff --git a/R/lsm_l_pd.R b/R/lsm_l_pd.R index 5ac566aba..ddab4cd42 100644 --- a/R/lsm_l_pd.R +++ b/R/lsm_l_pd.R @@ -56,34 +56,39 @@ lsm_l_pd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_pd_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_pd_calc <- function(landscape, directions, resolution, extras = NULL) { - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_pd" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "pd", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise for total landscape area_total <- sum(area_patch$value) # number of patches for each class number_patches <- lsm_c_np_calc(landscape, - directions = directions) + directions = directions, + extras = extras) # summarise for total landscape number_patches <- sum(number_patches$value) @@ -91,9 +96,9 @@ lsm_l_pd_calc <- function(landscape, directions, resolution = NULL) { # relative patch density patch_density <- number_patches / area_total * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "pd", - value = as.double(patch_density))) + return(tibble::new_tibble(list(level = rep("landscape", length(patch_density)), + class = rep(as.integer(NA), length(patch_density)), + id = rep(as.integer(NA), length(patch_density)), + metric = rep("pd", length(patch_density)), + value = as.double(patch_density)))) } diff --git a/R/lsm_l_pladj.R b/R/lsm_l_pladj.R index 3993b97f5..e425b267d 100644 --- a/R/lsm_l_pladj.R +++ b/R/lsm_l_pladj.R @@ -56,11 +56,11 @@ lsm_l_pladj_calc <- function(landscape) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "pladj", - value = as.double(NA))) + value = as.double(NA)))) } landscape_padded <- pad_raster_internal(landscape, @@ -68,17 +68,16 @@ lsm_l_pladj_calc <- function(landscape) { pad_raster_cells = 1, global = FALSE) - tb <- rcpp_get_coocurrence_matrix(landscape_padded, - directions = as.matrix(4)) + tb <- rcpp_get_coocurrence_matrix(landscape_padded, directions = as.matrix(4)) like_adjacencies <- sum(diag(tb)[-1]) total_adjacencies <- sum(tb[,-1]) pladj <- like_adjacencies / total_adjacencies * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "pladj", - value = as.double(pladj))) + return(tibble::new_tibble(list(level = rep("landscape", length(pladj)), + class = rep(as.integer(NA), length(pladj)), + id = rep(as.integer(NA), length(pladj)), + metric = rep("pladj", length(pladj)), + value = as.double(pladj)))) } diff --git a/R/lsm_l_pr.R b/R/lsm_l_pr.R index 1055e3f8d..4950e8165 100644 --- a/R/lsm_l_pr.R +++ b/R/lsm_l_pr.R @@ -46,22 +46,27 @@ lsm_l_pr <- function(landscape){ tibble::add_column(result, layer, .before = TRUE) } -lsm_l_pr_calc <- function(landscape){ +lsm_l_pr_calc <- function(landscape, extras = NULL){ - richness <- length(get_unique_values_int(landscape, verbose = FALSE)) + if (!is.null(extras)){ + classes <- extras$classes + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + } + richness <- length(classes) # all values NA if (richness == 0) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "pr", - value = as.double(NA))) + value = as.double(NA)))) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "pr", - value = as.double(richness))) + return(tibble::new_tibble(list(level = rep("landscape", length(richness)), + class = rep(as.integer(NA), length(richness)), + id = rep(as.integer(NA), length(richness)), + metric = rep("pr", length(richness)), + value = as.double(richness)))) } diff --git a/R/lsm_l_prd.R b/R/lsm_l_prd.R index f59016bf0..088bf0199 100644 --- a/R/lsm_l_prd.R +++ b/R/lsm_l_prd.R @@ -51,34 +51,35 @@ lsm_l_prd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_prd_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_prd_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise for total landscape area_total <- sum(area_patch$value) # all values NA if (is.na(area_total)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "prd", - value = as.double(NA))) + value = as.double(NA)))) } # get number of classes - pr_landscape <- lsm_l_pr_calc(landscape) + pr_landscape <- lsm_l_pr_calc(landscape, extras = extras) # relative number of classes prd <- pr_landscape$value / area_total * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "prd", - value = as.double(prd))) + return(tibble::new_tibble(list(level = rep("landscape", length(prd)), + class = rep(as.integer(NA), length(prd)), + id = rep(as.integer(NA), length(prd)), + metric = rep("prd", length(prd)), + value = as.double(prd)))) } diff --git a/R/lsm_l_relmutinf.R b/R/lsm_l_relmutinf.R index c5388ca3a..128d65d82 100644 --- a/R/lsm_l_relmutinf.R +++ b/R/lsm_l_relmutinf.R @@ -56,7 +56,7 @@ lsm_l_relmutinf <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_relmutinf_calc <- function(landscape, neighbourhood, ordered, base){ +lsm_l_relmutinf_calc <- function(landscape, neighbourhood, ordered, base, extras = NULL){ # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -65,30 +65,29 @@ lsm_l_relmutinf_calc <- function(landscape, neighbourhood, ordered, base){ # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "mutinf", - value = as.double(NA))) + value = as.double(NA)))) } - com <- rcpp_get_coocurrence_matrix(landscape, - directions = as.matrix(neighbourhood)) - com_c <- colSums(com) - - coh <- rcpp_get_coocurrence_vector(landscape, - directions = as.matrix(neighbourhood), - ordered = ordered) + if (!is.null(extras)){ + comp <- extras$comp + cplx <- extras$cplx + } else { + com <- rcpp_get_coocurrence_matrix(landscape, directions = as.matrix(neighbourhood)) + comp <- rcpp_get_entropy(colSums(com), base) + cplx <- get_complexity(landscape, neighbourhood, ordered, base) + } - comp <- rcpp_get_entropy(com_c, base) - cplx <- rcpp_get_entropy(coh, base) conf <- cplx - comp aggr <- comp - conf rel <- ifelse(aggr == 0, 1, aggr / comp) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "relmutinf", - value = as.double(rel))) + return(tibble::new_tibble(list(level = rep("landscape", length(rel)), + class = rep(as.integer(NA), length(rel)), + id = rep(as.integer(NA), length(rel)), + metric = rep("relmutinf", length(rel)), + value = as.double(rel)))) } diff --git a/R/lsm_l_rpr.R b/R/lsm_l_rpr.R index 5504cb394..114e641ae 100644 --- a/R/lsm_l_rpr.R +++ b/R/lsm_l_rpr.R @@ -55,7 +55,7 @@ lsm_l_rpr <- function(landscape, classes_max = NULL, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_rpr_calc <- function(landscape, classes_max, verbose) { +lsm_l_rpr_calc <- function(landscape, classes_max, verbose, extras = NULL) { if (is.null(classes_max)) { @@ -66,23 +66,23 @@ lsm_l_rpr_calc <- function(landscape, classes_max, verbose) { rpr <- NA } else { - pr <- lsm_l_pr_calc(landscape) + pr <- lsm_l_pr_calc(landscape, extras = extras) # all values NA if (all(is.na(pr$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "rpr", - value = as.double(NA))) + value = as.double(NA)))) } rpr <- pr$value / classes_max * 100 } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "rpr", - value = as.double(rpr))) + return(tibble::new_tibble(list(level = rep("landscape", length(rpr)), + class = rep(as.integer(NA), length(rpr)), + id = rep(as.integer(NA), length(rpr)), + metric = rep("rpr", length(rpr)), + value = as.double(rpr)))) } diff --git a/R/lsm_l_shape_cv.R b/R/lsm_l_shape_cv.R index d6ecc1f1c..578c6043e 100644 --- a/R/lsm_l_shape_cv.R +++ b/R/lsm_l_shape_cv.R @@ -60,28 +60,29 @@ lsm_l_shape_cv <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_shape_cv_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_shape_cv_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "shape_cv", - value = as.double(NA))) + value = as.double(NA)))) } # calculate cv shape_cv <- stats::sd(shape$value, na.rm = TRUE) / mean(shape$value, na.rm = TRUE) * 100 - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "shape_cv", - value = as.double(shape_cv))) + return(tibble::new_tibble(list(level = rep("landscape", length(shape_cv)), + class = rep(as.integer(NA), length(shape_cv)), + id = rep(as.integer(NA), length(shape_cv)), + metric = rep("shape_cv", length(shape_cv)), + value = as.double(shape_cv)))) } diff --git a/R/lsm_l_shape_mn.R b/R/lsm_l_shape_mn.R index 7c22c1252..e5fb96931 100644 --- a/R/lsm_l_shape_mn.R +++ b/R/lsm_l_shape_mn.R @@ -61,28 +61,29 @@ lsm_l_shape_mn <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_shape_mn_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_shape_mn_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "shape_mn", - value = as.double(NA))) + value = as.double(NA)))) } # calculate mean shape_mn <- mean(shape$value, na.rm = TRUE) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "shape_mn", - value = as.double(shape_mn))) + return(tibble::new_tibble(list(level = rep("landscape", length(shape_mn)), + class = rep(as.integer(NA), length(shape_mn)), + id = rep(as.integer(NA), length(shape_mn)), + metric = rep("shape_mn", length(shape_mn)), + value = as.double(shape_mn)))) } diff --git a/R/lsm_l_shape_sd.R b/R/lsm_l_shape_sd.R index 62d5f6264..340a48bac 100644 --- a/R/lsm_l_shape_sd.R +++ b/R/lsm_l_shape_sd.R @@ -61,28 +61,29 @@ lsm_l_shape_sd <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_shape_sd_calc <- function(landscape, directions, resolution = NULL){ +lsm_l_shape_sd_calc <- function(landscape, directions, resolution, extras = NULL){ # shape index for each patch shape <- lsm_p_shape_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(shape$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "shape_sd", - value = as.double(NA))) + value = as.double(NA)))) } # calculate sd shape_sd <- stats::sd(shape$value, na.rm = TRUE) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "shape_sd", - value = as.double(shape_sd))) + return(tibble::new_tibble(list(level = rep("landscape", length(shape_sd)), + class = rep(as.integer(NA), length(shape_sd)), + id = rep(as.integer(NA), length(shape_sd)), + metric = rep("shape_sd", length(shape_sd)), + value = as.double(shape_sd)))) } diff --git a/R/lsm_l_shdi.R b/R/lsm_l_shdi.R index c8322e1a6..4dd575231 100644 --- a/R/lsm_l_shdi.R +++ b/R/lsm_l_shdi.R @@ -52,29 +52,30 @@ lsm_l_shdi <- function(landscape) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_shdi_calc <- function(landscape, resolution = NULL) { +lsm_l_shdi_calc <- function(landscape, resolution, extras = NULL) { # get class proportions (direction doesn't matter) prop <- lsm_c_pland_calc(landscape, directions = 8, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(prop$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "shdi", - value = as.double(NA))) + value = as.double(NA)))) } prop <- prop$value / 100 shdi <- sum(-prop * log(prop, exp(1))) - return(tibble::tibble(level = 'landscape', - class = as.integer(NA), - id = as.integer(NA), - metric = "shdi", - value = as.double(shdi))) + return(tibble::new_tibble(list(level = rep("landscape", length(shdi)), + class = rep(as.integer(NA), length(shdi)), + id = rep(as.integer(NA), length(shdi)), + metric = rep("shdi", length(shdi)), + value = as.double(shdi)))) } diff --git a/R/lsm_l_shei.R b/R/lsm_l_shei.R index 217719f8b..aa481d143 100644 --- a/R/lsm_l_shei.R +++ b/R/lsm_l_shei.R @@ -54,20 +54,21 @@ lsm_l_shei <- function(landscape){ tibble::add_column(result, layer, .before = TRUE) } -lsm_l_shei_calc <- function(landscape, resolution = NULL){ +lsm_l_shei_calc <- function(landscape, resolution, extras = NULL){ # get class proportions (direction doesn't matter) prop <- lsm_c_pland_calc(landscape, directions = 8, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(prop$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "shei", - value = as.double(NA))) + value = as.double(NA)))) } prop <- prop$value / 100 @@ -78,9 +79,9 @@ lsm_l_shei_calc <- function(landscape, resolution = NULL){ shei <- -sum(prop * log(prop)) / log(length(prop)) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "shei", - value = as.double(shei))) + return(tibble::new_tibble(list(level = rep("landscape", length(shei)), + class = rep(as.integer(NA), length(shei)), + id = rep(as.integer(NA), length(shei)), + metric = rep("shei", length(shei)), + value = as.double(shei)))) } diff --git a/R/lsm_l_sidi.R b/R/lsm_l_sidi.R index 6bf2b70eb..fd06387b9 100644 --- a/R/lsm_l_sidi.R +++ b/R/lsm_l_sidi.R @@ -57,26 +57,27 @@ lsm_l_sidi <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_sidi_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_sidi_calc <- function(landscape, directions, resolution, extras = NULL) { sidi <- lsm_c_pland_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(sidi$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "sidi", - value = as.double(NA))) + value = as.double(NA)))) } sidi <- 1 - sum((sidi$value / 100) ^ 2) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "sidi", - value = as.double(sidi))) + return(tibble::new_tibble(list(level = rep("landscape", length(sidi)), + class = rep(as.integer(NA), length(sidi)), + id = rep(as.integer(NA), length(sidi)), + metric = rep("sidi", length(sidi)), + value = as.double(sidi)))) } diff --git a/R/lsm_l_siei.R b/R/lsm_l_siei.R index d6429bdb2..36598d362 100644 --- a/R/lsm_l_siei.R +++ b/R/lsm_l_siei.R @@ -57,28 +57,29 @@ lsm_l_siei <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_siei_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_siei_calc <- function(landscape, directions, resolution, extras = NULL) { sidi <- lsm_l_sidi_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # all values NA if (all(is.na(sidi$value))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "siei", - value = as.double(NA))) + value = as.double(NA)))) } - pr <- lsm_l_pr_calc(landscape) + pr <- lsm_l_pr_calc(landscape, extras = extras) siei <- sidi$value / (1 - (1 / pr$value)) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "siei", - value = as.double(siei))) + return(tibble::new_tibble(list(level = rep("landscape", length(siei)), + class = rep(as.integer(NA), length(siei)), + id = rep(as.integer(NA), length(siei)), + metric = rep("siei", length(siei)), + value = as.double(siei)))) } diff --git a/R/lsm_l_split.R b/R/lsm_l_split.R index 57e1a8bd9..e0ba38a44 100644 --- a/R/lsm_l_split.R +++ b/R/lsm_l_split.R @@ -58,31 +58,32 @@ lsm_l_split <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_split_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_split_calc <- function(landscape, directions, resolution, extras = NULL) { # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # summarise for total landscape area_total <- sum(area_patch$value) # all values NA if (is.na(area_total)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "split", - value = as.double(NA))) + value = as.double(NA)))) } # total area squared divided by sum of area squared for each patch split <- (area_total ^ 2) / sum(area_patch$value ^ 2) - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "split", - value = as.double(split))) + return(tibble::new_tibble(list(level = rep("landscape", length(split)), + class = rep(as.integer(NA), length(split)), + id = rep(as.integer(NA), length(split)), + metric = rep("split", length(split)), + value = as.double(split)))) } diff --git a/R/lsm_l_ta.R b/R/lsm_l_ta.R index 2619a0ff4..d5ebb8e9f 100644 --- a/R/lsm_l_ta.R +++ b/R/lsm_l_ta.R @@ -53,26 +53,27 @@ lsm_l_ta <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_ta_calc <- function(landscape, directions, resolution = NULL) { +lsm_l_ta_calc <- function(landscape, directions, resolution, extras = NULL) { patch_area <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) total_area <- sum(patch_area$value) # all values NA if (is.na(total_area)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "ta", - value = as.double(NA))) + value = as.double(NA)))) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "ta", - value = as.double(total_area))) + return(tibble::new_tibble(list(level = rep("landscape", length(total_area)), + class = rep(as.integer(NA), length(total_area)), + id = rep(as.integer(NA), length(total_area)), + metric = rep("ta", length(total_area)), + value = as.double(total_area)))) } diff --git a/R/lsm_l_tca.R b/R/lsm_l_tca.R index c95a24270..57cec8c86 100644 --- a/R/lsm_l_tca.R +++ b/R/lsm_l_tca.R @@ -66,28 +66,29 @@ lsm_l_tca <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_l_tca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL) { +lsm_l_tca_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL) { core_area_patch <- lsm_p_core_calc(landscape, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) total_core_area <- sum(core_area_patch$value) # all values NA if (is.na(total_core_area)) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "tca", - value = as.double(NA))) + value = as.double(NA)))) } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "tca", - value = as.double(total_core_area))) + return(tibble::new_tibble(list(level = rep("landscape", length(total_core_area)), + class = rep(as.integer(NA), length(total_core_area)), + id = rep(as.integer(NA), length(total_core_area)), + metric = rep("tca", length(total_core_area)), + value = as.double(total_core_area)))) } diff --git a/R/lsm_l_te.R b/R/lsm_l_te.R index cdc1632e0..470916229 100644 --- a/R/lsm_l_te.R +++ b/R/lsm_l_te.R @@ -54,22 +54,24 @@ lsm_l_te <- function(landscape, count_boundary = FALSE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_te_calc <- function(landscape, count_boundary, resolution = NULL){ +lsm_l_te_calc <- function(landscape, count_boundary, resolution, extras = NULL){ - # conver raster to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_l_te" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + neighbourhood = 4, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "landscape", + return(tibble::new_tibble(list(level = "landscape", class = as.integer(NA), id = as.integer(NA), metric = "te", - value = as.double(NA))) + value = as.double(NA)))) } # get resolution in x-y directions @@ -88,13 +90,17 @@ lsm_l_te_calc <- function(landscape, count_boundary, resolution = NULL){ # set NA to background value landscape[is.na(landscape)] <- background_value + + neighbor_matrix <- rcpp_get_coocurrence_matrix(landscape, directions = as.matrix(4)) + + } else { + + neighbor_matrix <- extras$neighbor_matrix + } if (resolution_x == resolution_y) { - neighbor_matrix <- rcpp_get_coocurrence_matrix(landscape, - directions = as.matrix(4)) - edge_total <- sum(neighbor_matrix[lower.tri(neighbor_matrix)]) * resolution_x } else { @@ -124,9 +130,9 @@ lsm_l_te_calc <- function(landscape, count_boundary, resolution = NULL){ edge_total <- edge_left_right + edge_top_bottom } - return(tibble::tibble(level = "landscape", - class = as.integer(NA), - id = as.integer(NA), - metric = "te", - value = as.double(edge_total))) + return(tibble::new_tibble(list(level = rep("landscape", length(edge_total)), + class = rep(as.integer(NA), length(edge_total)), + id = rep(as.integer(NA), length(edge_total)), + metric = rep("te", length(edge_total)), + value = as.double(edge_total)))) } diff --git a/R/lsm_p_area.R b/R/lsm_p_area.R index 08da9f162..f0cca8e29 100644 --- a/R/lsm_p_area.R +++ b/R/lsm_p_area.R @@ -61,54 +61,50 @@ lsm_p_area <- function(landscape, directions = 8) { } -lsm_p_area_calc <- function(landscape, directions, resolution = NULL){ +lsm_p_area_calc <- function(landscape, directions, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_p_area" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "area", - value = as.double(NA))) + value = as.double(NA)))) } - # factor to convert cell to area - factor_ha <- prod(resolution) / 10000 - # get unique class id - classes <- get_unique_values_int(landscape, verbose = FALSE) + classes <- extras$classes + class_patches <- extras$class_patches + area_patches <- extras$area_patches area_patch <- do.call(rbind, lapply(classes, function(patches_class){ # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # multiply number of cells within each patch with hectar factor - area_patch_ij <- rcpp_get_composition_vector(x = landscape_labeled) * factor_ha + area_patch_ij <- area_patches[[as.character(patches_class)]] - tibble::tibble( - class = as.integer(patches_class), - value = area_patch_ij) + tibble::new_tibble(list( + class = rep(as.integer(patches_class), length(area_patch_ij)), + value = area_patch_ij)) }) ) - - return(tibble::tibble( - level = "patch", + return(tibble::new_tibble(list( + level = rep("patch", nrow(area_patch)), class = as.integer(area_patch$class), id = as.integer(seq_len(nrow(area_patch))), - metric = "area", + metric = rep("area", nrow(area_patch)), value = as.double(area_patch$value) - ) - ) + ))) } diff --git a/R/lsm_p_cai.R b/R/lsm_p_cai.R index 97fead9d2..d286fe417 100644 --- a/R/lsm_p_cai.R +++ b/R/lsm_p_cai.R @@ -73,29 +73,35 @@ lsm_p_cai <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_p_cai_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL){ +lsm_p_cai_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ + if (missing(resolution)) resolution <- terra::res(landscape) - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (!inherits(landscape, "matrix")){ + landscape <- terra::as.matrix(landscape, wide = TRUE) + } + if (is.null(extras)){ + metrics <- "lsm_p_cai" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "cai", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area_patch <- lsm_p_area_calc(landscape = landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # convert from ha to sqm area_patch$value <- area_patch$value @@ -105,16 +111,17 @@ lsm_p_cai_calc <- function(landscape, directions, consider_boundary, edge_depth, directions = directions, consider_boundary = consider_boundary, edge_depth = edge_depth, - resolution = resolution) + resolution = resolution, + extras = extras) # calculate CAI index cai_patch <- core_patch$value / area_patch$value * 100 - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(area_patch)), class = as.integer(area_patch$class), id = as.integer(area_patch$id), - metric = "cai", + metric = rep("cai", nrow(area_patch)), value = as.double(cai_patch) - ) + )) } diff --git a/R/lsm_p_circle.R b/R/lsm_p_circle.R index f3114d7e4..faa99e858 100644 --- a/R/lsm_p_circle.R +++ b/R/lsm_p_circle.R @@ -67,16 +67,15 @@ lsm_p_circle <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_circle_calc <- function(landscape, directions, resolution = NULL) { +lsm_p_circle_calc <- function(landscape, directions, resolution, extras = NULL) { - # conver to matrix - if (!inherits(x = landscape, what = "matrix")) { + if (missing(resolution)) resolution <- terra::res(landscape) - # get resolution - resolution <- terra::res(landscape) - - # convert to matrix + if (is.null(extras)){ + metrics <- "lsm_p_circle" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # check if resolution is identical @@ -88,49 +87,49 @@ lsm_p_circle_calc <- function(landscape, directions, resolution = NULL) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "circle", - value = as.double(NA))) + value = as.double(NA)))) } # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # convert area to m2 area_patch <- area_patch$value * 10000 # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) + classes <- extras$classes + class_patches <- extras$class_patches circle_patch <- do.call(rbind, lapply(classes, function(patches_class) { # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # get circle radius around patch circle <- rcpp_get_circle(landscape_labeled, resolution_xy = resolution[[1]]) - tibble::tibble(class = patches_class, - value = circle$circle_area) + tibble::new_tibble(list(class = rep(patches_class, nrow(circle)), + value = circle$circle_area)) }) ) # calculate circle metric circle_patch$value <- 1 - (area_patch / circle_patch$value) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(circle_patch)), class = as.integer(circle_patch$class), id = as.integer(seq_len(nrow(circle_patch))), - metric = "circle", + metric = rep("circle", nrow(circle_patch)), value = as.double(circle_patch$value) - ) + )) } diff --git a/R/lsm_p_contig.R b/R/lsm_p_contig.R index 2d8cfb7ba..25f5ed8ab 100644 --- a/R/lsm_p_contig.R +++ b/R/lsm_p_contig.R @@ -72,7 +72,7 @@ lsm_p_contig <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_contig_calc <- function(landscape, directions) { +lsm_p_contig_calc <- function(landscape, directions, extras = NULL) { # convert to matrix if (!inherits(x = landscape, what = "matrix")) { @@ -81,15 +81,21 @@ lsm_p_contig_calc <- function(landscape, directions) { # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "contig", - value = as.double(NA))) + value = as.double(NA)))) } # get unique values - classes <- get_unique_values_int(landscape, verbose = FALSE) + if (!is.null(extras)){ + classes <- extras$classes + class_patches <- extras$class_patches + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + class_patches <- get_class_patches(landscape, classes, directions) + } # diagonal neighbours diagonal_matrix <- matrix(c(1, NA, 1, @@ -105,9 +111,7 @@ lsm_p_contig_calc <- function(landscape, directions) { lapply(classes, function(patches_class) { # get connected patches - patch_mat <- get_patches_int(landscape, - directions = directions, - class = patches_class)[[1]] + patch_mat <- class_patches[[as.character(patches_class)]] # get number of cells for each patch n_cells <- rcpp_get_composition_vector(patch_mat) @@ -115,7 +119,6 @@ lsm_p_contig_calc <- function(landscape, directions) { # get number of patches n_patches <- length(n_cells) - # get diagonal neighbours of same patch diagonal_neighbours <- rcpp_get_coocurrence_matrix_diag(patch_mat, directions = as.matrix(diagonal_matrix)) @@ -130,20 +133,20 @@ lsm_p_contig_calc <- function(landscape, directions) { class <- patches_class - rm(patch_mat) - gc(verbose = FALSE) + #rm(patch_mat) + #gc(verbose = FALSE) - tibble::tibble(class = class, - value = contiguity) + tibble::new_tibble(list(class = rep(class, length(contiguity)), + value = contiguity)) }) ) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(contig_patch)), class = as.integer(contig_patch$class), id = as.integer(seq_len(nrow(contig_patch))), - metric = "contig", + metric = rep("contig", nrow(contig_patch)), value = as.double(contig_patch$value) - ) + )) } diff --git a/R/lsm_p_core.R b/R/lsm_p_core.R index 02ac7ea9a..2ffe48413 100644 --- a/R/lsm_p_core.R +++ b/R/lsm_p_core.R @@ -69,34 +69,34 @@ lsm_p_core <- function(landscape, directions = 8, tibble::add_column(result, layer, .before = TRUE) } -lsm_p_core_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution = NULL) { +lsm_p_core_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_p_core" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } - # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "core", - value = as.double(NA))) + value = as.double(NA)))) } - # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) + # get common variables + classes <- extras$classes + class_patches <- extras$class_patches core <- do.call(rbind, lapply(classes, function(patches_class) { # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # label all edge cells class_edge <- get_boundaries_calc(landscape_labeled, @@ -106,30 +106,30 @@ lsm_p_core_calc <- function(landscape, directions, consider_boundary, edge_depth patch_id = FALSE) # count number of edge cells in each patch (edge == 1) - cells_edge_patch <- table(landscape_labeled[class_edge == 1]) - - # all cells of the patch - cells_patch <- table(landscape_labeled) + cells_edge_patch <- tabulate(landscape_labeled[class_edge == 1]) # check if no cell is edge, i.e. only one patch is present - if (dim(cells_edge_patch) == 0) { + if (length(cells_edge_patch) == 0) { cells_edge_patch <- 0 } + # all cells of the patch + cells_patch <- tabulate(landscape_labeled) + # all cells minus edge cells equal core and convert to ha core_area <- (cells_patch - cells_edge_patch) * prod(resolution) / 10000 - tibble::tibble(class = patches_class, - value = core_area) + tibble::new_tibble(list(class = rep(patches_class, length(core_area)), + value = core_area)) }) ) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(core)), class = as.integer(core$class), id = as.integer(seq_len(nrow(core))), - metric = "core", + metric = rep("core", nrow(core)), value = as.double(core$value) - ) + )) } diff --git a/R/lsm_p_enn.R b/R/lsm_p_enn.R index 5a098b59c..c4f085c85 100644 --- a/R/lsm_p_enn.R +++ b/R/lsm_p_enn.R @@ -67,68 +67,37 @@ lsm_p_enn <- function(landscape, directions = 8, verbose = TRUE) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_enn_calc <- function(landscape, directions, verbose, - points = NULL) { +lsm_p_enn_calc <- function(landscape, directions, verbose, resolution, extras = NULL) { + + if (missing(resolution)) resolution <- terra::res(landscape) # convert to matrix if (!inherits(x = landscape, what = "matrix")) { - - # get coordinates and values of all cells - points <- raster_to_points(landscape)[, 2:4] - - # convert to matrix landscape <- terra::as.matrix(landscape, wide = TRUE) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "enn", - value = as.double(NA))) + value = as.double(NA)))) } # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) - - enn_patch <- do.call(rbind, - lapply(classes, function(patches_class) { - - # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] - - # get number of patches - np_class <- max(landscape_labeled, na.rm = TRUE) - - # ENN doesn't make sense if only one patch is present - if (np_class == 1) { - - enn <- tibble::tibble(class = patches_class, - dist = as.double(NA)) - - if (verbose) { - warning(paste0("Class ", patches_class, - ": ENN = NA for class with only 1 patch."), - call. = FALSE) - } - } else { - - enn <- get_nearestneighbour_calc(landscape = landscape_labeled, - return_id = FALSE, - points = points) - } - - tibble::tibble(class = patches_class, - value = enn$dist) - }) - ) + if (!is.null(extras)){ + enn_patch <- extras$enn_patch + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + class_patches <- get_class_patches(landscape, classes, directions) + points <- get_points(landscape, resolution) + enn_patch <- get_enn_patch(classes, class_patches, points, resolution) + } - tibble::tibble(level = "patch", + tibble::new_tibble(list(level = rep("patch", nrow(enn_patch)), class = as.integer(enn_patch$class), id = as.integer(seq_len(nrow(enn_patch))), - metric = "enn", - value = as.double(enn_patch$value)) + metric = rep("enn", nrow(enn_patch)), + value = as.double(enn_patch$value))) } diff --git a/R/lsm_p_frac.R b/R/lsm_p_frac.R index 737030410..3d843094e 100644 --- a/R/lsm_p_frac.R +++ b/R/lsm_p_frac.R @@ -64,33 +64,37 @@ lsm_p_frac <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_frac_calc <- function(landscape, directions, resolution = NULL){ +lsm_p_frac_calc <- function(landscape, directions, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + if (is.null(extras)){ + metrics <- "lsm_p_frac" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "frac", - value = as.double(NA))) + value = as.double(NA)))) } # get patch perimeter perimeter_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # get patch area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # calculate frac frac_patch <- 2 * log(0.25 * perimeter_patch$value) / log(area_patch$value * 10000) @@ -98,11 +102,11 @@ lsm_p_frac_calc <- function(landscape, directions, resolution = NULL){ # NaN for patches with only one cell (mathematical reasons) -> should be 1 frac_patch[is.na(frac_patch)] <- 1 - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(perimeter_patch)), class = as.integer(perimeter_patch$class), id = as.integer(perimeter_patch$id), - metric = "frac", + metric = rep("frac", nrow(perimeter_patch)), value = as.double(frac_patch) - ) + )) } diff --git a/R/lsm_p_gyrate.R b/R/lsm_p_gyrate.R index ed793599f..5750e6f50 100644 --- a/R/lsm_p_gyrate.R +++ b/R/lsm_p_gyrate.R @@ -68,61 +68,63 @@ lsm_p_gyrate <- function(landscape, directions = 8, tibble::add_column(result, layer, .before = TRUE) } -lsm_p_gyrate_calc <- function(landscape, directions, cell_center, - points = NULL) { +lsm_p_gyrate_calc <- function(landscape, directions, cell_center, resolution, extras = NULL) { - # conver to matrix - if (!inherits(x = landscape, what = "matrix")) { - - # get coordinates and values of all cells - points <- raster_to_points(landscape)[, 2:4] + if (missing(resolution)) resolution <- terra::res(landscape) - # convert to matrix + # convert to matrix + if (!inherits(x = landscape, what = "matrix")) { landscape <- terra::as.matrix(landscape, wide = TRUE) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "gyrate", - value = as.double(NA))) + value = as.double(NA)))) } - # get uniuqe class id - classes <- get_unique_values_int(landscape, verbose = FALSE) + # get unique class id + if (!is.null(extras)){ + classes <- extras$classes + class_patches <- extras$class_patches + points <- extras$points + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + class_patches <- get_class_patches(landscape, classes, directions) + points <- get_points(landscape, resolution) + } gyrate <- do.call(rbind, lapply(classes, function(patches_class) { # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # transpose to get same direction of ID landscape_labeled <- t(landscape_labeled) - # get coordinates of current class - points <- matrix(points[which(!is.na(landscape_labeled)), ], - ncol = 3) + # get (relative) coordinates of current class + points <- which(!is.na(landscape_labeled), arr.ind = TRUE) + points <- mapply(FUN = `*`, as.data.frame(points), resolution) # set ID from class ID to unique patch ID - points[, 3] <- landscape_labeled[!is.na(landscape_labeled)] + points <- cbind(points, landscape_labeled[!is.na(landscape_labeled)]) - # # conver to tibble + # # convert to tibble points <- stats::setNames(object = data.frame(points), nm = c("x", "y", "id")) - # calcuale the centroid of each patch (mean of all coords) + # calculate the centroid of each patch (mean of all coords) centroid <- stats::aggregate(points[, c(1, 2)], by = list(id = points[, 3]), FUN = mean) # create full data set with raster-points and patch centroids full_data <- merge(x = points, y = centroid, by = "id", - suffixes = c("","_centroid")) + suffixes = c("", "_centroid")) # calculate distance from each cell center to centroid full_data$dist <- sqrt((full_data$x - full_data$x_centroid) ^ 2 + @@ -135,7 +137,7 @@ lsm_p_gyrate_calc <- function(landscape, directions, cell_center, centroid <- do.call(rbind, by(data = full_data, INDICES = full_data[, 1], FUN = function(x) - x[x$dist == min(x$dist), ]))[, c(1, 2, 3)] + x[which(signif(x$dist) == min(signif(x$dist))), ]))[, c(1, 2, 3)] # create full data set with raster-points and patch centroids full_data <- merge(x = points, y = centroid, by = "id", @@ -157,10 +159,10 @@ lsm_p_gyrate_calc <- function(landscape, directions, cell_center, }) ) - tibble::tibble(level = "patch", + tibble::new_tibble(list(level = rep("patch", nrow(gyrate)), class = as.integer(gyrate$class), id = as.integer(seq_len(nrow(gyrate))), - metric = "gyrate", - value = as.double(gyrate$value)) + metric = rep("gyrate", nrow(gyrate)), + value = as.double(gyrate$value))) } diff --git a/R/lsm_p_ncore.R b/R/lsm_p_ncore.R index a05c7488e..93dc90f35 100644 --- a/R/lsm_p_ncore.R +++ b/R/lsm_p_ncore.R @@ -73,38 +73,40 @@ lsm_p_ncore <- function(landscape, tibble::add_column(result, layer, .before = TRUE) } -lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_depth, - points = NULL){ +lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_depth, resolution, extras = NULL){ - # conver to matrix - if (!inherits(x = landscape, what = "matrix")) { - - # get coordinates and values of all cells - points <- raster_to_points(landscape)[, 2:4] + if (missing(resolution)) resolution <- terra::res(landscape) - # convert to matrix + # convert to matrix + if (!inherits(x = landscape, what = "matrix")) { landscape <- terra::as.matrix(landscape, wide = TRUE) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "ncore", - value = as.double(NA))) + value = as.double(NA)))) } # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) + if (!is.null(extras)){ + classes <- extras$classes + class_patches <- extras$class_patches + points <- extras$points + } else { + classes <- get_unique_values_int(landscape, verbose = FALSE) + class_patches <- get_class_patches(landscape, classes, directions) + points <- get_points(landscape, resolution) + } core_class <- do.call(rbind, lapply(classes, function(patches_class) { # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] + landscape_labeled <- class_patches[[as.character(patches_class)]] # get unique patch id (must be 1 to number_patches) patches_id <- 1:max(landscape_labeled, na.rm = TRUE) @@ -144,14 +146,15 @@ lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_dept patch_core <- t(patch_core) landscape_labeled <- t(landscape_labeled) + not_na_patch_core <- !is.na(patch_core) # get coordinates of current class - points <- data.frame(x = points[which(!is.na(patch_core)), 1], - y = points[which(!is.na(patch_core)), 2], - z = points[which(!is.na(patch_core)), 3]) + points <- data.frame(x = points[which(not_na_patch_core), 1], + y = points[which(not_na_patch_core), 2], + z = points[which(not_na_patch_core), 3]) - points$core_id <- patch_core[!is.na(patch_core)] + points$core_id <- patch_core[not_na_patch_core] - points$patch_id <- landscape_labeled[!is.na(patch_core)] + points$patch_id <- landscape_labeled[not_na_patch_core] n_core_area <- table(unique(points[, c(4, 5)])[, 2]) # sth breaking here @@ -163,17 +166,17 @@ lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_dept result[as.numeric(names(n_core_area))] <- n_core_area } - tibble::tibble( - class = patches_class, - value = result) + tibble::new_tibble(list( + class = rep(patches_class, length(result)), + value = result)) }) ) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(core_class)), class = as.integer(core_class$class), id = as.integer(seq_len(nrow(core_class))), - metric = "ncore", + metric = rep("ncore", nrow(core_class)), value = as.double(core_class$value) - ) + )) } diff --git a/R/lsm_p_para.R b/R/lsm_p_para.R index 8d392b6db..9dbdea97f 100644 --- a/R/lsm_p_para.R +++ b/R/lsm_p_para.R @@ -61,41 +61,46 @@ lsm_p_para <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_para_calc <- function(landscape, directions, resolution = NULL){ +lsm_p_para_calc <- function(landscape, directions, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + + if (is.null(extras)){ + metrics <- "lsm_p_para" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "para", - value = as.double(NA))) + value = as.double(NA)))) } # get perim perimeter_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # get area area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + resolution = resolution, + extras = extras) # calculate ratio between area and perim para_patch <- perimeter_patch$value / (area_patch$value * 10000) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(perimeter_patch)), class = as.integer(perimeter_patch$class), id = as.integer(perimeter_patch$id), - metric = "para", + metric = rep("para", nrow(perimeter_patch)), value = as.double(para_patch) - ) + )) } diff --git a/R/lsm_p_perim.R b/R/lsm_p_perim.R index 6c6b7bcc5..7e8ced8c5 100644 --- a/R/lsm_p_perim.R +++ b/R/lsm_p_perim.R @@ -50,106 +50,33 @@ lsm_p_perim <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_perim_calc <- function(landscape, directions, resolution = NULL) { +lsm_p_perim_calc <- function(landscape, directions, resolution, extras = NULL) { - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) + if (missing(resolution)) resolution <- terra::res(landscape) + + if (is.null(extras)){ + metrics <- "lsm_p_perim" landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "perim", - value = as.double(NA))) + value = as.double(NA)))) } - # get dimensions of raster - resolution_x <- resolution[[1]] - resolution_y <- resolution[[2]] - - # get unique classes - classes <- get_unique_values_int(landscape, verbose = FALSE) - - # raster resolution not identical in x-y directions - if (!isTRUE(all.equal(resolution_x, resolution_y))) { - - top_bottom_matrix <- matrix(c(NA, NA, NA, - 1, 0, 1, - NA, NA, NA), 3, 3, byrow = TRUE) - - left_right_matrix <- matrix(c(NA, 1, NA, - NA, 0, NA, - NA, 1, NA), 3, 3, byrow = TRUE) - } - - perimeter_patch <- do.call(rbind, - lapply(classes, function(patches_class) { - - # get connected patches - landscape_labeled <- get_patches_int(landscape, - class = patches_class, - directions = directions)[[1]] - - # cells at the boundary of the landscape need neighbours to calculate perim - landscape_labeled <- pad_raster_internal(landscape_labeled, - pad_raster_value = NA, - pad_raster_cells = 1, - global = FALSE) - - # which cells are NA (i.e. background) - target_na <- which(is.na(landscape_labeled)) - - # set all NA to -999 to get adjacencies between patches and all background - landscape_labeled[target_na] <- -999 - - # x-y resolution is identical - if (isTRUE(all.equal(resolution_x, resolution_y))) { - - # get coocurrence matrix - neighbour_matrix <- rcpp_get_coocurrence_matrix_single(landscape_labeled, - directions = as.matrix(4), - single_class = -999) - - # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter - perimeter_patch_ij <- neighbour_matrix[2:nrow(neighbour_matrix), 1] * resolution_x - - # x-y resolution not identical, count adjacencies seperatly for x- and y-direction - } else { - - # get coocurrence matrix in x-direction - left_right_neighbours <- rcpp_get_coocurrence_matrix_single(landscape_labeled, - directions = as.matrix(left_right_matrix), - single_class = -999) - - # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter - perimeter_patch_ij_left_right <- left_right_neighbours[2:nrow(left_right_neighbours), 1] * resolution_x - - # get coocurrennce matrix in y-direction - top_bottom_neighbours <- rcpp_get_coocurrence_matrix_single(landscape_labeled, - directions = as.matrix(top_bottom_matrix), - single_class = -999) - - # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter - perimeter_patch_ij_top_bottom <- top_bottom_neighbours[2:nrow(top_bottom_neighbours), 1] * resolution_y - - # add perim of both directions for each patch - perimeter_patch_ij <- perimeter_patch_ij_top_bottom + perimeter_patch_ij_left_right - } - - tibble::tibble(class = patches_class, - value = perimeter_patch_ij) - }) - ) + perimeter_patch <- extras$perimeter_patch - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(perimeter_patch)), class = as.integer(perimeter_patch$class), id = as.integer(seq_len(nrow(perimeter_patch))), - metric = "perim", + metric = rep("perim", nrow(perimeter_patch)), value = as.double(perimeter_patch$value) - ) + )) } diff --git a/R/lsm_p_shape.R b/R/lsm_p_shape.R index 7529307a8..2cda72284 100644 --- a/R/lsm_p_shape.R +++ b/R/lsm_p_shape.R @@ -62,39 +62,46 @@ lsm_p_shape <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_shape_calc <- function(landscape, directions, resolution = NULL){ +lsm_p_shape_calc <- function(landscape, directions, resolution, extras = NULL){ - # convert to matrix - if (!inherits(x = landscape, what = "matrix")) { - resolution <- terra::res(landscape) - landscape <-terra::as.matrix(landscape, wide = TRUE) + if (missing(resolution)) resolution <- terra::res(landscape) + + if (is.null(extras)){ + metrics <- "lsm_p_shape" + landscape <- terra::as.matrix(landscape, wide = TRUE) + extras <- prepare_extras(metrics, landscape_mat = landscape, + directions = directions, resolution = resolution) } # all values NA if (all(is.na(landscape))) { - return(tibble::tibble(level = "patch", + return(tibble::new_tibble(list(level = "patch", class = as.integer(NA), id = as.integer(NA), metric = "shape", - value = as.double(NA))) + value = as.double(NA)))) } # get perimeter of patches - perimeter_patch <- lsm_p_perim_calc(landscape, directions = directions, - resolution = resolution) + perimeter_patch <- lsm_p_perim_calc(landscape, + directions = directions, + resolution = resolution, + extras = extras) # get area of patches - area_patch <- lsm_p_area_calc(landscape, directions = directions, - resolution = resolution) + area_patch <- lsm_p_area_calc(landscape, + directions = directions, + resolution = resolution, + extras = extras) # calculate shape index shape_patch <- (0.25 * perimeter_patch$value) / sqrt(area_patch$value * 10000) - tibble::tibble( - level = "patch", + tibble::new_tibble(list( + level = rep("patch", nrow(perimeter_patch)), class = as.integer(perimeter_patch$class), id = as.integer(perimeter_patch$id), metric = "shape", value = as.double(shape_patch) - ) + )) } diff --git a/R/matrix_to_raster.R b/R/matrix_to_raster.R index c7f812872..e09df9e49 100644 --- a/R/matrix_to_raster.R +++ b/R/matrix_to_raster.R @@ -40,7 +40,7 @@ matrix_to_raster <- function(matrix, if (!is.null(landscape)) { if (landscape_empty) { - out <- landscape + out <- landscape } else { out <- terra::rast(x = terra::ext(landscape), resolution = terra::res(landscape), diff --git a/R/prepare_extras.R b/R/prepare_extras.R new file mode 100644 index 000000000..6c17a162d --- /dev/null +++ b/R/prepare_extras.R @@ -0,0 +1,397 @@ +#' prepare_extras +#' +#' @description Prepare an extras object +#' +#' @param metrics A vector with metric abbreviations +#' @param landscape_mat A matrix object +#' @param directions The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case). +#' @param neighbourhood The number of directions in which cell adjacencies are considered as neighbours: 4 (rook's case) or 8 (queen's case). The default is 4. +#' @param ordered The type of pairs considered. Either ordered (TRUE) or unordered (FALSE). +#' The default is TRUE. +#' @param base The unit in which entropy is measured. The default is "log2", +#' which compute entropy in "bits". "log" and "log10" can be also used. +#' @param resolution A vector with two numbers (usually calculated using terra::res) +#' +#' @details +#' Wrapper around terra::xyFromCell and terra::getValues to get raster_to_points +#' function including NA values +#' +#' @return A list with zero or more of the following components: +#' \itemize{ +#' \item points: matrix with three columns: col, row, value +#' \item classes: vector with unique values +#' \item class_patches: list with matrices of patches for each class +#' \item area_patches: list with vectors of areas of patches for each class +#' \item composition_vector: vector with the number of cells for each class +#' \item neighbor_matrix: matrix with the number of cell pairs for each class +#' \item comp: entropy of the neighbor_matrix +#' \item cplx: complexity of the landscape +#' \item enn_patch: matrix with the euclidean nearest neighbour distance for each patch +#' } +#' +#' @seealso +#' \code{\link{get_points}}, +#' \code{\link{get_class_patches}}, +#' \code{\link{get_area_patches}}, +#' \code{\link{get_complexity}}, +#' \code{\link{get_enn_patch}} +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' prepare_extras("lsm_l_ent", landscape_mat, neighbourhood = 4, base = "log2") +#' +#' \dontrun{ +#' metrics = list_lsm()$function_name +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' prepare_extras(metrics, landscape_mat, directions = 8, neighbourhood = 4, +#' ordered = FALSE, base = "log2", resolution = terra::res(landscape)) +#' } +#' +#' @aliases prepare_extras +#' @rdname prepare_extras +#' +#' @keywords internal +#' +#' @export +prepare_extras <- function(metrics, landscape_mat, directions, neighbourhood, ordered, base, resolution){ + extras_df_sub <- extras_df[extras_df$metric %in% metrics, ] + extras_list <- unique(extras_df_sub$extras) + + extras <- list() + + if (any(c("enn_patch", "points") %in% extras_list)){ + extras$points <- get_points(landscape_mat, resolution) + } + if (any(c("area_patches", "enn_patch", "class_patches", "perimeter_patch", "classes") %in% extras_list)){ + extras$classes <- get_unique_values_int(landscape_mat, verbose = FALSE) + } + if (any(c("area_patches", "enn_patch", "perimeter_patch", "class_patches") %in% extras_list)){ + extras$class_patches <- get_class_patches(landscape_mat, extras$classes, directions) + } + if ("area_patches" %in% extras_list){ + extras$area_patches <- get_area_patches(extras$class_patches, extras$classes, resolution) + } + if ("composition_vector" %in% extras_list){ + extras$composition_vector <- rcpp_get_composition_vector(landscape_mat) + } + if (any(c("comp", "neighbor_matrix") %in% extras_list)){ + extras$neighbor_matrix <- rcpp_get_coocurrence_matrix(landscape_mat, directions = as.matrix(neighbourhood)) + } + if ("comp" %in% extras_list){ + extras$comp <- rcpp_get_entropy(colSums(extras$neighbor_matrix), base) + } + if ("cplx" %in% extras_list){ + extras$cplx <- get_complexity(landscape_mat, neighbourhood, ordered, base) + } + if ("enn_patch" %in% extras_list){ + extras$enn_patch <- get_enn_patch(extras$classes, extras$class_patches, extras$points) + } + if ("perimeter_patch" %in% extras_list){ + extras$perimeter_patch <- get_perimeter_patch(extras$classes, extras$class_patches, resolution) + } + return(extras) +} + +#' get_class_patches +#' +#' @description Get patches for each class +#' +#' @param landscape_mat A matrix object +#' @param classes A vector with unique values (output of get_unique_values_int) +#' @param directions The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case). +#' +#' @details +#' Calculate patches for each class +#' +#' @return list with matrices of patches for each class +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +#' class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +#' +#' @aliases get_class_patches +#' @rdname get_class_patches +#' +#' @keywords internal +#' +#' @export +get_class_patches <- function(landscape_mat, classes, directions){ + class_patches <- lapply(classes, function(patches_class){ + landscape_labeled <- get_patches_int(landscape_mat, + class = patches_class, + directions = directions)[[1]] + }) + names(class_patches) <- classes + return(class_patches) +} + +#' get_area_patches +#' +#' @description Get areas of patches for each class +#' +#' @param class_patches A list with matrices of patches for each class (output of get_class_patches) +#' @param classes A vector with unique values (output of get_unique_values_int) +#' @param resolution A vector with two numbers (usually calculated using terra::res) +#' +#' @details +#' Calculate areas of patches for each class +#' +#' @return list with vectors of areas of patches for each class +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +#' class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +#' area_patches <- get_area_patches(class_patches, classes, resolution = terra::res(landscape)) +#' +#' @aliases get_area_patches +#' @rdname get_area_patches +#' +#' @keywords internal +#' +#' @export +get_area_patches <- function(class_patches, classes, resolution){ + factor_ha <- prod(resolution) / 10000 + area_patches <- lapply(classes, function(patches_class){ + landscape_labeled <- class_patches[[as.character(patches_class)]] + area_patch_ij <- rcpp_get_composition_vector(x = landscape_labeled) * factor_ha + }) + names(area_patches) <- classes + return(area_patches) +} + +#' get_complexity +#' +#' @description Calculate complexity of the landscape +#' +#' @param landscape_mat A matrix object +#' @param neighbourhood The number of directions in which cell adjacencies are considered as neighbours: 4 (rook's case) or 8 (queen's case). The default is 4. +#' @param ordered The type of pairs considered. Either ordered (TRUE) or unordered (FALSE). +#' @param base The unit in which entropy is measured. The default is "log2", +#' +#' @details +#' Calculate complexity of the landscape: entropy of the co-occurrence matrix +#' +#' @return matrix +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' get_complexity(landscape_mat, neighbourhood = 4, ordered = TRUE, base = "log2") +#' +#' @aliases get_complexity +#' @rdname get_complexity +#' +#' @keywords internal +#' +#' @export +get_complexity <- function(landscape_mat, neighbourhood, ordered, base){ + coh <- rcpp_get_coocurrence_vector(landscape_mat, + directions = as.matrix(neighbourhood), + ordered = ordered) + cplx <- rcpp_get_entropy(coh, base) + return(cplx) +} + + +#' get_points +#' +#' @description Raster to col, row, value +#' +#' @param landscape_mat A matrix object +#' @param resolution A vector with two numbers (usually calculated using terra::res) +#' +#' @details +#' The col and row values are multiplied by the resolution to get the (internal) coordinates of the points. +#' +#' @return matrix with three columns: col, row, value +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' resolution <- terra::res(landscape) +#' get_points(landscape_mat, resolution) +#' +#' @aliases get_points +#' @rdname get_points +#' +#' @keywords internal +#' +#' @export +get_points <- function(landscape_mat, resolution){ + points <- expand.grid(col = seq_len(ncol(landscape_mat)), + row = seq_len(nrow(landscape_mat))) + points <- mapply(FUN = `*`, points, resolution) + points <- cbind(points, value = as.vector(landscape_mat)) + points +} + +#' get_enn_patch +#' +#' @description Euclidean Nearest-Neighbor Distance +#' +#' @param classes A vector with unique values (output of get_unique_values_int) +#' @param class_patches A list with matrices of patches for each class (output of get_class_patches) +#' @param points A matrix with three columns: col, row, value (output of get_points) +#' @param resolution A vector with two numbers (usually calculated using terra::res) +#' @param verbose A logical indicating whether to print warnings +#' +#' @details +#' Calculate Euclidean Nearest-Neighbor Distance for each patch in each class +#' +#' @return tibble with two columns: class, value +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +#' class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +#' points <- get_points(landscape_mat, terra::res(landscape)) +#' enns <- get_enn_patch(classes, class_patches, points, terra::res(landscape)) +#' enns +#' +#' @aliases get_enn_patch +#' @rdname get_enn_patch +#' +#' @keywords internal +#' +#' @export +get_enn_patch <- function(classes, class_patches, points, resolution, verbose = FALSE){ + enn_patch <- do.call(rbind, lapply(classes, function(patches_class) { + + # get connected patches + landscape_labeled <- class_patches[[as.character(patches_class)]] + + # get number of patches + np_class <- max(landscape_labeled, na.rm = TRUE) + + # ENN doesn't make sense if only one patch is present + if (np_class == 1) { + + enn <- tibble::new_tibble(list(class = patches_class, + dist = as.double(NA))) + + if (verbose) { + warning(paste0("Class ", patches_class, + ": ENN = NA for class with only 1 patch."), + call. = FALSE) + } + } else { + + enn <- get_nearestneighbour_calc(landscape = landscape_labeled, + return_id = FALSE, + resolution = resolution, + points = points) + } + + tibble::new_tibble(list(class = rep(patches_class, nrow(enn)), + value = enn$dist)) + }) + ) +} + +#' get_perimeter_patch +#' +#' @description Perimeter of each patch in each class +#' +#' @param classes A vector with unique values (output of get_unique_values_int) +#' @param class_patches A list with matrices of patches for each class (output of get_class_patches) +#' @param resolution A vector with two numbers (usually calculated using terra::res) +#' +#' @details +#' Calculate perimeter of each patch in each class +#' +#' @return A tibble with two columns: class, value +#' +#' @examples +#' landscape <- terra::rast(landscapemetrics::landscape) +#' landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +#' classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +#' class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +#' pp <- get_perimeter_patch(classes, class_patches, terra::res(landscape)) +#' pp +#' +#' @aliases get_perimeter_patch +#' @rdname get_perimeter_patch +#' +#' @keywords internal +#' +#' @export +get_perimeter_patch <- function(classes, class_patches, resolution) { + resolution_x <- resolution[[1]] + resolution_y <- resolution[[2]] + + # raster resolution not identical in x-y directions + if (!isTRUE(all.equal(resolution_x, resolution_y))) { + + top_bottom_matrix <- matrix(c(NA, NA, NA, + 1, 0, 1, + NA, NA, NA), 3, 3, byrow = TRUE) + + left_right_matrix <- matrix(c(NA, 1, NA, + NA, 0, NA, + NA, 1, NA), 3, 3, byrow = TRUE) + } + + perimeter_patch <- do.call(rbind, + lapply(classes, function(patches_class) { + + # get connected patches + landscape_labeled <- class_patches[[as.character(patches_class)]] + + # cells at the boundary of the landscape need neighbours to calculate perim + landscape_labeled <- pad_raster_internal(landscape_labeled, + pad_raster_value = NA, + pad_raster_cells = 1, + global = FALSE) + + # which cells are NA (i.e. background) + target_na <- which(is.na(landscape_labeled)) + + # set all NA to -999 to get adjacencies between patches and all background + landscape_labeled[target_na] <- -999 + + # x-y resolution is identical + if (isTRUE(all.equal(resolution_x, resolution_y))) { + + # get coocurrence matrix + neighbour_matrix <- rcpp_get_coocurrence_matrix_single(landscape_labeled, + directions = as.matrix(4), + single_class = -999) + + # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter + perimeter_patch_ij <- neighbour_matrix[2:nrow(neighbour_matrix), 1] * resolution_x + + # x-y resolution not identical, count adjacencies separately for x- and y-direction + } else { + + # get coocurrence matrix in x-direction + left_right_neighbours <- rcpp_get_coocurrence_matrix_single(landscape_labeled, + directions = as.matrix(left_right_matrix), + single_class = -999) + + # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter + perimeter_patch_ij_left_right <- left_right_neighbours[2:nrow(left_right_neighbours), 1] * resolution_x + + # get coocurrennce matrix in y-direction + top_bottom_neighbours <- rcpp_get_coocurrence_matrix_single(landscape_labeled, + directions = as.matrix(top_bottom_matrix), + single_class = -999) + + # get adjacencies between patches and background cells (-999 always first row of matrix) and convert to perimeter + perimeter_patch_ij_top_bottom <- top_bottom_neighbours[2:nrow(top_bottom_neighbours), 1] * resolution_y + + # add perim of both directions for each patch + perimeter_patch_ij <- perimeter_patch_ij_top_bottom + perimeter_patch_ij_left_right + } + + tibble::new_tibble(list(class = rep(patches_class, length(perimeter_patch_ij)), + value = perimeter_patch_ij)) + }) + ) +} diff --git a/R/proj_info.R b/R/proj_info.R index 7cf41778c..35d56bf48 100644 --- a/R/proj_info.R +++ b/R/proj_info.R @@ -35,7 +35,7 @@ proj_info <- function(landscape) { # long-lat projection if (terra::is.lonlat(landscape)) { - tibble::tibble(crs = "geographic", units = "degrees") + tibble::new_tibble(list(crs = "geographic", units = "degrees")) # projected projection } else { @@ -44,11 +44,11 @@ proj_info <- function(landscape) { proj_units <- strsplit(sub(".*units=", "", landscape_proj), " ", fixed = TRUE)[[1]][[1]] - tibble::tibble(crs = "projected", units = proj_units) + tibble::new_tibble(list(crs = "projected", units = proj_units)) } # no projection present } else { - tibble::tibble(crs = NA, units = NA) + tibble::new_tibble(list(crs = NA, units = NA)) } } diff --git a/R/raster_to_points.R b/R/raster_to_points.R index 656cd5d2e..2b7e95a26 100644 --- a/R/raster_to_points.R +++ b/R/raster_to_points.R @@ -27,8 +27,7 @@ raster_to_points <- function(landscape, return_NA = TRUE) { result <- lapply(X = seq_along(landscape), function(x) { - xyz <- raster_to_points_internal(landscape[[x]], - return_NA = return_NA) + xyz <- raster_to_points_internal(landscape[[x]], return_NA = return_NA) xyz <- cbind(layer = x, xyz) }) @@ -57,7 +56,5 @@ raster_to_points_internal <- function(landscape, return_NA) { colnames(xyz) <- c("x", "y", "z") - # xyz <- cbind(layer = 1, xyz) - return(xyz) } diff --git a/R/sample_lsm.R b/R/sample_lsm.R index 5f0f91d9b..6e8f692e2 100644 --- a/R/sample_lsm.R +++ b/R/sample_lsm.R @@ -170,10 +170,7 @@ sample_lsm_int <- function(landscape, y, plot_id, shape, size, } # crop sample plot - landscape_crop <- terra::crop(x = landscape, y = y[current_plot, ]) - - # mask sample plot - landscape_mask <- terra::mask(x = landscape_crop, mask = y[current_plot, ]) + landscape_mask <- terra::crop(x = landscape, y = y[current_plot, ], mask = TRUE) # calculate actual area of sample plot area <- lsm_l_ta_calc(landscape_mask, directions = 8) diff --git a/R/show_cores.R b/R/show_cores.R index 56571f40e..b2dad1b55 100644 --- a/R/show_cores.R +++ b/R/show_cores.R @@ -141,7 +141,7 @@ show_cores_internal <- function(landscape, directions, class, labels, nrow, ncol plot <- ggplot2::ggplot(boundary_labeled_stack, ggplot2::aes(x, y)) + ggplot2::geom_raster(ggplot2::aes(fill = factor(values))) + - ggplot2::geom_text(ggplot2::aes_string(x = "x", y = "y", label = "core_label"), + ggplot2::geom_text(ggplot2::aes(x = .data[["x"]], y = .data[["y"]], label = .data[["core_label"]]), colour = "white", na.rm = TRUE) + ggplot2::facet_wrap(~ class, nrow = nrow, ncol = ncol) + ggplot2::scale_fill_manual(values = c("grey60", "#E17C05"), na.value = "grey85") + diff --git a/R/show_correlation.R b/R/show_correlation.R index 624b11749..dfbfbb30f 100644 --- a/R/show_correlation.R +++ b/R/show_correlation.R @@ -22,7 +22,7 @@ #' show_correlation(data = metrics, method = "pearson") #' #' \dontrun{ -#' metrics <- calculate_lsm(landscape, what = c("patch", "class"))#' +#' metrics <- calculate_lsm(landscape, what = c("patch", "class")) #' correlations <- calculate_correlation(metrics) #' show_correlation(data = correlations, method = "pearson") #' } diff --git a/R/show_lsm.R b/R/show_lsm.R index 859a2e089..5adbd1436 100644 --- a/R/show_lsm.R +++ b/R/show_lsm.R @@ -51,7 +51,6 @@ show_lsm <- function(landscape, what, class = "global", directions = 8, names(result) <- paste0("layer_", 1:length(result)) return(result) - } show_lsm_internal <- function(landscape, what, class, diff --git a/R/show_patches.R b/R/show_patches.R index 38022de27..7dea1e7b3 100644 --- a/R/show_patches.R +++ b/R/show_patches.R @@ -60,8 +60,7 @@ show_patches_internal <- function(landscape, class, directions, labels, nrow, nc if (any(class == "global")) { patches_tibble <- terra::as.data.frame(sum(terra::rast(landscape_labeled), - na.rm = TRUE), - xy = TRUE) + na.rm = TRUE), xy = TRUE) names(patches_tibble) <- c("x", "y", "value") @@ -108,22 +107,6 @@ show_patches_internal <- function(landscape, class, directions, labels, nrow, nc ggplot2::geom_raster(ggplot2::aes(fill = factor(value))) + ggplot2::geom_text(ggplot2::aes(label = labels), colour = "white", na.rm = TRUE) + - # ggplot2::scale_fill_gradientn( - # colours = c( - # "#5F4690", - # "#1D6996", - # "#38A6A5", - # "#0F8554", - # "#73AF48", - # "#EDAD08", - # "#E17C05", - # "#CC503E", - # "#94346E", - # "#6F4070", - # "#994E95" - # ), - # na.value = "grey85" - # ) + 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)) + diff --git a/R/spatialize_lsm.R b/R/spatialize_lsm.R index 024dfc809..c7377409b 100644 --- a/R/spatialize_lsm.R +++ b/R/spatialize_lsm.R @@ -30,7 +30,8 @@ #' #' @examples #' landscape <- terra::rast(landscapemetrics::landscape) -#' spatialize_lsm(landscape, what = "lsm_p_area") +#' p_area_raster <- spatialize_lsm(landscape, what = "lsm_p_area") +#' terra::plot(p_area_raster[[1]][[1]]) #' #' @aliases spatialize_lsm #' diff --git a/R/sysdata.rda b/R/sysdata.rda index 2398eae4b..b2a89db81 100644 Binary files a/R/sysdata.rda and b/R/sysdata.rda differ diff --git a/R/window_lsm.R b/R/window_lsm.R index 51523cc7e..a1529f880 100644 --- a/R/window_lsm.R +++ b/R/window_lsm.R @@ -20,6 +20,8 @@ #' the value of its neighbourhood and thereby allows to show gradients and variability in the landscape (Hagen-Zanker 2016). #' To be type stable, the actual result is always a nested list (first level for \code{RasterStack} layers, second level #' for selected landscape metrics). +#' +#' Note, that in situations when the moving window does not contain any patches, the result is NA. #' #' @seealso #' \code{\link{list_lsm}} \cr @@ -88,7 +90,7 @@ window_lsm <- function(landscape, if (progress) {cat("\n")} - names(result) <- paste0("layer_", 1:length(result)) + names(result) <- paste0("layer_", seq_along(result)) return(result) } @@ -127,18 +129,45 @@ window_lsm_int <- function(landscape, call. = FALSE) } - # get coordinates of cells - points <- raster_to_points(landscape)[, 2:4] - - # resolution of original raster resolution <- terra::res(landscape) + arguments_values <- list(directions = 8, + count_boundary = FALSE, + consider_boundary = FALSE, + edge_depth = 1, + classes_max = NULL, + neighbourhood = 4, + ordered = TRUE, + base = "log2", + resolution = resolution, + verbose = TRUE) + + input_arguments <- list(...) + arguments_values[names(input_arguments)] <- input_arguments + # create object for warning messages warning_messages <- character(0) result <- withCallingHandlers(expr = {lapply(seq_along(metrics_list), function(current_metric) { - # print progess using the non-internal name + what <- metrics_list[[current_metric]] + + # get internal calculation function + what <- paste0(what, "_calc") + + # match function name + foo <- get(what, mode = "function") + + # get argument + arguments <- names(formals(foo))[-1] + + # which arguments are needed + arguments_values <- arguments_values[names(arguments_values) %in% arguments] + + # sort alphabetically to match later with provided + arguments_values <- arguments_values[order(names(arguments_values))] + + # print progress using the non-internal name if (progress) { cat("\r> Progress metrics: ", current_metric, "/", number_metrics) @@ -146,12 +175,10 @@ window_lsm_int <- function(landscape, terra::focal(x = landscape, w = dim(window), fun = function(x) { - calculate_lsm_focal(landscape = x, + calculate_lsm_focal(landscape_values = x, raster_window = window, - resolution = resolution, - points = points, - what = metrics_list[[current_metric]], - ...)}, fillvalue = NA) + foo = foo, + arguments_values = arguments_values)}, fillvalue = NA) })}, warning = function(cond) { @@ -170,67 +197,25 @@ window_lsm_int <- function(landscape, warning_messages <- unique(warning_messages) # print warnings - lapply(warning_messages, function(x){ warning(x, call. = FALSE)}) + lapply(warning_messages, function(x){warning(x, call. = FALSE)}) } return(result) } -calculate_lsm_focal <- function(landscape, +calculate_lsm_focal <- function(landscape_values, raster_window, - resolution, - points, - what, - ...) { + foo, + arguments_values) { # convert focal window to matrix - raster_window[!is.na(raster_window)] <- landscape - - # get internal calculation function - what <- paste0(what, "_calc") - - # match function name - foo <- get(what, mode = "function") - - # get argument - arguments <- names(formals(foo))[-1] - - arguments_values <- list(resolution = resolution, - points = points, - directions = 8, - count_boundary = FALSE, - consider_boundary = FALSE, - edge_depth = 1, - classes_max = NULL, - neighbourhood = 4, - ordered = TRUE, - base = "log2", - verbose = TRUE) - - # which arguments are needed - arguments_values <- arguments_values[names(arguments_values) %in% arguments] - - # sort alphabetically to match later with provided - arguments_values <- arguments_values[order(names(arguments_values))] - - # get provided arguments - arguments_provided <- substitute(...()) - - # sort alphabetically to match later with defaults - if (!is.null(arguments_provided)) { - - arguments_provided <- arguments_provided[order(names(arguments_provided))] - - # exchange arguments - arguments_values[names(arguments_values) %in% names(arguments_provided)] <- arguments_provided - } + raster_window[!is.na(raster_window)] <- landscape_values[!is.na(raster_window)] # landscape argument arguments_values$landscape <- raster_window # run function - result <- do.call(what = foo, - args = arguments_values) + result <- do.call(what = foo, args = arguments_values) return(result$value) } diff --git a/README.Rmd b/README.Rmd index a9df4cefd..a27b79459 100644 --- a/README.Rmd +++ b/README.Rmd @@ -28,7 +28,7 @@ README last updated: `r Sys.Date()` -> Starting from v2.0.0, **landscapemetrics** does not support the `raster` or `sp` packages. They are replaced by `terra` and `sf`, respectively. More information about the `terra` package can be found here: . +> Starting from v2.0.0, **landscapemetrics** uses `terra` and `sf` internally. More information about the `terra` package can be found here: . ## Overview diff --git a/README.md b/README.md index e016b2497..63578b6b7 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ -README last updated: 2023-05-23 +README last updated: 2023-10-04 | CI | Development | CRAN | License | |--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------|---------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------------------------------|-----------------------------------------------------------------------------------------------------------------| @@ -13,9 +13,8 @@ README last updated: 2023-05-23 -> Starting from v2.0.0, **landscapemetrics** does not support the -> `raster` or `sp` packages. They are replaced by `terra` and `sf`, -> respectively. More information about the `terra` package can be found +> Starting from v2.0.0, **landscapemetrics** uses `terra` and `sf` +> internally. More information about the `terra` package can be found > here: . ## Overview diff --git a/codemeta.json b/codemeta.json index d97879064..fd5849672 100644 --- a/codemeta.json +++ b/codemeta.json @@ -7,13 +7,13 @@ "codeRepository": "https://r-spatialecology.github.io/landscapemetrics/", "issueTracker": "https://github.com/r-spatialecology/landscapemetrics/issues", "license": "https://spdx.org/licenses/GPL-3.0", - "version": "2.0.0", + "version": "2.1.0", "programmingLanguage": { "@type": "ComputerLanguage", "name": "R", "url": "https://r-project.org" }, - "runtimePlatform": "R version 4.3.1 (2023-06-16)", + "runtimePlatform": "R version 4.3.2 (2023-10-31)", "provider": { "@id": "https://cran.r-project.org", "@type": "Organization", @@ -303,7 +303,7 @@ }, "SystemRequirements": null }, - "fileSize": "1728.145KB", + "fileSize": "1728.419KB", "citation": [ { "@type": "ScholarlyArticle", diff --git a/cran-comments.md b/cran-comments.md index f4c3c20a7..1871f47ce 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,3 +1,6 @@ +# landscapemetrics 2.1.0 +Larger internal updates to several algorithms + # landscapemetrics 2.0.0 - resubmission This is a re-submission. The below error has now been fixed. diff --git a/data-raw/04_create_extras.R b/data-raw/04_create_extras.R new file mode 100644 index 000000000..55f672bba --- /dev/null +++ b/data-raw/04_create_extras.R @@ -0,0 +1,69 @@ +library(purrr) +library(stringr) +library(dplyr) +get_extras_per_file <- function(input_fun, lsm_dir, all_extras){ + my_files = paste0(lsm_dir, "R/", input_fun, ".R") + t1 = readLines(my_files) + new_df = data.frame(metric = input_fun, + extras = stringr::str_replace_all(all_extras, "extras\\\\\\$", "")) + new_df$used = unlist(lapply(paste0(all_extras, "$"), + \(x) any(stringr::str_detect(t1, x)))) + new_df = subset(new_df, used) + return(new_df) +} + +all_lsms <- landscapemetrics::list_lsm() + +# 1. check which functions are using extras directly +all_extras <- c("extras\\$points", "extras\\$classes", + "extras\\$class_patches", "extras\\$area_patches", "extras\\$neighbor_matrix", + "extras\\$composition_vector", "extras\\$comp", "extras\\$cplx", + "extras\\$enn_patch", "extras\\$perimeter_patch") +db_extras1 <- map_df(all_lsms$function_name, + get_extras_per_file, + lsm_dir = "~/Software/landscapemetrics/", + all_extras = all_extras) + +# 2. check which functions are using extras indirectly +get_int_functions <- function(function_name1){ + function_name2 = paste0(function_name1, "_calc") + int_functions2 = codetools::findGlobals(eval(parse(text = paste0("landscapemetrics:::", function_name2))), merge = FALSE)$functions + int_functions2 = stringr::str_replace_all(int_functions2, "\\_calc", "") + data.frame(mainmetric = function_name1, usedmetric = int_functions2) +} + +sel_intfuns_1degree <- map_df(all_lsms$function_name, get_int_functions) |> + filter(str_detect(usedmetric, "^lsm")) +sel_intfuns_2degree = map_df(unique(sel_intfuns_1degree$usedmetric), get_int_functions) |> + filter(str_detect(usedmetric, "^lsm")) +sel_intfuns_2degree = left_join(sel_intfuns_1degree, sel_intfuns_2degree, by = c("usedmetric" = "mainmetric"), + relationship = "many-to-many") |> + select(mainmetric, usedmetric = usedmetric.y) |> + filter(!is.na(usedmetric)) + +sel_intfuns <- rbind(sel_intfuns_1degree, sel_intfuns_2degree) + +# 3. join them +db_extras2 <- left_join(sel_intfuns, db_extras1, by = c("usedmetric" = "metric"), + relationship = "many-to-many") |> + filter(!is.na(used)) |> + select(metric = mainmetric, extras, used) + +extras_df <- rbind(db_extras1, db_extras2) |> select(-used) |> + distinct(metric, extras) |> + arrange(metric) + +# create new environment +my_new_env <- new.env(hash = FALSE) + +# load current internal data into this new environment +load("R/sysdata.rda", envir = my_new_env) + +# add or replace some objects +my_new_env$extras_df <- extras_df + +# save the environment as internal package data +save(list = names(my_new_env), + file = "R/sysdata.rda", + envir = my_new_env, + compress = "xz") diff --git a/man/construct_buffer.Rd b/man/construct_buffer.Rd index 603410635..542dbbbf4 100644 --- a/man/construct_buffer.Rd +++ b/man/construct_buffer.Rd @@ -7,19 +7,19 @@ construct_buffer(coords, shape, size, return_vec = TRUE, verbose = TRUE) } \arguments{ -\item{coords}{SpatialPoints or 2-column matrix with coordinates of sample points} +\item{coords}{SpatVector, sf object or 2-column matrix with coordinates of sample points} \item{shape}{String specifying plot shape. Either "circle" or "square"} \item{size}{Size of sample plot. Equals the radius for circles or the -side-length for squares in mapunits} +side-length for squares in map units} -\item{return_vec}{If true, vector objects are returned.} +\item{return_vec}{If TRUE, vector objects are returned.} \item{verbose}{Print warning messages.} } \value{ -matrix or sf objecct +matrix or SpatVector object } \description{ Internal function to construct plot area around coordinates diff --git a/man/figures/README-unnamed-chunk-2-1.png b/man/figures/README-unnamed-chunk-2-1.png index 1fa51caa0..029d299f6 100644 Binary files a/man/figures/README-unnamed-chunk-2-1.png and b/man/figures/README-unnamed-chunk-2-1.png differ diff --git a/man/get_area_patches.Rd b/man/get_area_patches.Rd new file mode 100644 index 000000000..1cf77ca09 --- /dev/null +++ b/man/get_area_patches.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_area_patches} +\alias{get_area_patches} +\title{get_area_patches} +\usage{ +get_area_patches(class_patches, classes, resolution) +} +\arguments{ +\item{class_patches}{A list with matrices of patches for each class (output of get_class_patches)} + +\item{classes}{A vector with unique values (output of get_unique_values_int)} + +\item{resolution}{A vector with two numbers (usually calculated using terra::res)} +} +\value{ +list with vectors of areas of patches for each class +} +\description{ +Get areas of patches for each class +} +\details{ +Calculate areas of patches for each class +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +area_patches <- get_area_patches(class_patches, classes, resolution = terra::res(landscape)) + +} +\keyword{internal} diff --git a/man/get_boundaries.Rd b/man/get_boundaries.Rd index af4fe67f1..8a8c129fd 100644 --- a/man/get_boundaries.Rd +++ b/man/get_boundaries.Rd @@ -29,7 +29,7 @@ edge to be considered as core cell.} \item{return_raster}{If false, matrix is returned.} } \value{ -List with RasterLayer or matrix +List with SpatRaster or matrix } \description{ Get boundary cells of patches diff --git a/man/get_class_patches.Rd b/man/get_class_patches.Rd new file mode 100644 index 000000000..f4e5cecd4 --- /dev/null +++ b/man/get_class_patches.Rd @@ -0,0 +1,32 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_class_patches} +\alias{get_class_patches} +\title{get_class_patches} +\usage{ +get_class_patches(landscape_mat, classes, directions) +} +\arguments{ +\item{landscape_mat}{A matrix object} + +\item{classes}{A vector with unique values (output of get_unique_values_int)} + +\item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} +} +\value{ +list with matrices of patches for each class +} +\description{ +Get patches for each class +} +\details{ +Calculate patches for each class +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +class_patches <- get_class_patches(landscape_mat, classes, directions = 8) + +} +\keyword{internal} diff --git a/man/get_complexity.Rd b/man/get_complexity.Rd new file mode 100644 index 000000000..1b049481a --- /dev/null +++ b/man/get_complexity.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_complexity} +\alias{get_complexity} +\title{get_complexity} +\usage{ +get_complexity(landscape_mat, neighbourhood, ordered, base) +} +\arguments{ +\item{landscape_mat}{A matrix object} + +\item{neighbourhood}{The number of directions in which cell adjacencies are considered as neighbours: 4 (rook's case) or 8 (queen's case). The default is 4.} + +\item{ordered}{The type of pairs considered. Either ordered (TRUE) or unordered (FALSE).} + +\item{base}{The unit in which entropy is measured. The default is "log2",} +} +\value{ +matrix +} +\description{ +Calculate complexity of the landscape +} +\details{ +Calculate complexity of the landscape: entropy of the co-occurrence matrix +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +get_complexity(landscape_mat, neighbourhood = 4, ordered = TRUE, base = "log2") + +} +\keyword{internal} diff --git a/man/get_enn_patch.Rd b/man/get_enn_patch.Rd new file mode 100644 index 000000000..15da93fdc --- /dev/null +++ b/man/get_enn_patch.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_enn_patch} +\alias{get_enn_patch} +\title{get_enn_patch} +\usage{ +get_enn_patch(classes, class_patches, points, resolution, verbose = FALSE) +} +\arguments{ +\item{classes}{A vector with unique values (output of get_unique_values_int)} + +\item{class_patches}{A list with matrices of patches for each class (output of get_class_patches)} + +\item{points}{A matrix with three columns: col, row, value (output of get_points)} + +\item{resolution}{A vector with two numbers (usually calculated using terra::res)} + +\item{verbose}{A logical indicating whether to print warnings} +} +\value{ +tibble with two columns: class, value +} +\description{ +Euclidean Nearest-Neighbor Distance +} +\details{ +Calculate Euclidean Nearest-Neighbor Distance for each patch in each class +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +points <- get_points(landscape_mat, terra::res(landscape)) +enns <- get_enn_patch(classes, class_patches, points, terra::res(landscape)) +enns + +} +\keyword{internal} diff --git a/man/get_patches.Rd b/man/get_patches.Rd index 09626c70d..653c23485 100644 --- a/man/get_patches.Rd +++ b/man/get_patches.Rd @@ -28,7 +28,7 @@ Can be set with a global option, e.g. \code{option(to_disk = TRUE)}. See Details \item{return_raster}{If false, matrix is returned} } \value{ -List +List of SpatRaster } \description{ Connected components labeling to derive patches in a landscape. diff --git a/man/get_perimeter_patch.Rd b/man/get_perimeter_patch.Rd new file mode 100644 index 000000000..324fc64df --- /dev/null +++ b/man/get_perimeter_patch.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_perimeter_patch} +\alias{get_perimeter_patch} +\title{get_perimeter_patch} +\usage{ +get_perimeter_patch(classes, class_patches, resolution) +} +\arguments{ +\item{classes}{A vector with unique values (output of get_unique_values_int)} + +\item{class_patches}{A list with matrices of patches for each class (output of get_class_patches)} + +\item{resolution}{A vector with two numbers (usually calculated using terra::res)} +} +\value{ +A tibble with two columns: class, value +} +\description{ +Perimeter of each patch in each class +} +\details{ +Calculate perimeter of each patch in each class +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +classes <- landscapemetrics:::get_unique_values_int(landscape_mat) +class_patches <- get_class_patches(landscape_mat, classes, directions = 8) +pp <- get_perimeter_patch(classes, class_patches, terra::res(landscape)) +pp + +} +\keyword{internal} diff --git a/man/get_points.Rd b/man/get_points.Rd new file mode 100644 index 000000000..eeee6d411 --- /dev/null +++ b/man/get_points.Rd @@ -0,0 +1,30 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{get_points} +\alias{get_points} +\title{get_points} +\usage{ +get_points(landscape_mat, resolution) +} +\arguments{ +\item{landscape_mat}{A matrix object} + +\item{resolution}{A vector with two numbers (usually calculated using terra::res)} +} +\value{ +matrix with three columns: col, row, value +} +\description{ +Raster to col, row, value +} +\details{ +The col and row values are multiplied by the resolution to get the (internal) coordinates of the points. +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +resolution <- terra::res(landscape) +get_points(landscape_mat, resolution) + +} +\keyword{internal} diff --git a/man/lsm_l_ai.Rd b/man/lsm_l_ai.Rd index 0f8931263..7928fe3fb 100644 --- a/man/lsm_l_ai.Rd +++ b/man/lsm_l_ai.Rd @@ -4,10 +4,13 @@ \alias{lsm_l_ai} \title{AI (landscape level)} \usage{ -lsm_l_ai(landscape) +lsm_l_ai(landscape, directions = 8) } \arguments{ \item{landscape}{A categorical raster object: SpatRaster; Raster* Layer, Stack, Brick; stars or a list of SpatRasters} + +\item{directions}{The number of directions in which patches should be +connected: 4 (rook's case) or 8 (queen's case).} } \value{ tibble diff --git a/man/prepare_extras.Rd b/man/prepare_extras.Rd new file mode 100644 index 000000000..b4bcaf526 --- /dev/null +++ b/man/prepare_extras.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/prepare_extras.R +\name{prepare_extras} +\alias{prepare_extras} +\title{prepare_extras} +\usage{ +prepare_extras( + metrics, + landscape_mat, + directions, + neighbourhood, + ordered, + base, + resolution +) +} +\arguments{ +\item{metrics}{A vector with metric abbreviations} + +\item{landscape_mat}{A matrix object} + +\item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{neighbourhood}{The number of directions in which cell adjacencies are considered as neighbours: 4 (rook's case) or 8 (queen's case). The default is 4.} + +\item{ordered}{The type of pairs considered. Either ordered (TRUE) or unordered (FALSE). +The default is TRUE.} + +\item{base}{The unit in which entropy is measured. The default is "log2", +which compute entropy in "bits". "log" and "log10" can be also used.} + +\item{resolution}{A vector with two numbers (usually calculated using terra::res)} +} +\value{ +A list with zero or more of the following components: +\itemize{ +\item points: matrix with three columns: col, row, value +\item classes: vector with unique values +\item class_patches: list with matrices of patches for each class +\item area_patches: list with vectors of areas of patches for each class +\item composition_vector: vector with the number of cells for each class +\item neighbor_matrix: matrix with the number of cell pairs for each class +\item comp: entropy of the neighbor_matrix +\item cplx: complexity of the landscape +\item enn_patch: matrix with the euclidean nearest neighbour distance for each patch +} +} +\description{ +Prepare an extras object +} +\details{ +Wrapper around terra::xyFromCell and terra::getValues to get raster_to_points +function including NA values +} +\examples{ +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +prepare_extras("lsm_l_ent", landscape_mat, neighbourhood = 4, base = "log2") + +\dontrun{ +metrics = list_lsm()$function_name +landscape <- terra::rast(landscapemetrics::landscape) +landscape_mat <- terra::as.matrix(landscape, wide = TRUE) +prepare_extras(metrics, landscape_mat, directions = 8, neighbourhood = 4, + ordered = FALSE, base = "log2", resolution = terra::res(landscape)) +} + +} +\seealso{ +\code{\link{get_points}}, +\code{\link{get_class_patches}}, +\code{\link{get_area_patches}}, +\code{\link{get_complexity}}, +\code{\link{get_enn_patch}} +} +\keyword{internal} diff --git a/man/show_correlation.Rd b/man/show_correlation.Rd index cf142e10d..fd2057742 100644 --- a/man/show_correlation.Rd +++ b/man/show_correlation.Rd @@ -44,7 +44,7 @@ metrics <- calculate_lsm(landscape, what = c("patch", "class")) show_correlation(data = metrics, method = "pearson") \dontrun{ -metrics <- calculate_lsm(landscape, what = c("patch", "class"))#' +metrics <- calculate_lsm(landscape, what = c("patch", "class")) correlations <- calculate_correlation(metrics) show_correlation(data = correlations, method = "pearson") } diff --git a/man/spatialize_lsm.Rd b/man/spatialize_lsm.Rd index ca3c2fa56..d88db1708 100644 --- a/man/spatialize_lsm.Rd +++ b/man/spatialize_lsm.Rd @@ -55,7 +55,8 @@ value of the patch it belongs to. Only patch level metrics are allowed. } \examples{ landscape <- terra::rast(landscapemetrics::landscape) -spatialize_lsm(landscape, what = "lsm_p_area") +p_area_raster <- spatialize_lsm(landscape, what = "lsm_p_area") +terra::plot(p_area_raster[[1]][[1]]) } \seealso{ diff --git a/man/window_lsm.Rd b/man/window_lsm.Rd index 7c08ecedc..18c1545b8 100644 --- a/man/window_lsm.Rd +++ b/man/window_lsm.Rd @@ -49,6 +49,8 @@ details, see \code{?terra::focal()}. The result will be a \code{RasterLayer} in the value of its neighbourhood and thereby allows to show gradients and variability in the landscape (Hagen-Zanker 2016). To be type stable, the actual result is always a nested list (first level for \code{RasterStack} layers, second level for selected landscape metrics). + +Note, that in situations when the moving window does not contain any patches, the result is NA. } \examples{ \dontrun{ diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 00c28f04d..bc806f624 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -23,59 +23,59 @@ BEGIN_RCPP END_RCPP } // rcpp_xy_from_matrix -IntegerMatrix rcpp_xy_from_matrix(arma::imat x, Rcpp::Nullable cell); +IntegerMatrix rcpp_xy_from_matrix(const arma::imat& x, Rcpp::Nullable cell); RcppExport SEXP _landscapemetrics_rcpp_xy_from_matrix(SEXP xSEXP, SEXP cellSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::imat >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::imat& >::type x(xSEXP); Rcpp::traits::input_parameter< Rcpp::Nullable >::type cell(cellSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_xy_from_matrix(x, cell)); return rcpp_result_gen; END_RCPP } // rcpp_cell_from_xy -IntegerVector rcpp_cell_from_xy(arma::imat x, IntegerMatrix y); +IntegerVector rcpp_cell_from_xy(const arma::imat& x, IntegerMatrix y); RcppExport SEXP _landscapemetrics_rcpp_cell_from_xy(SEXP xSEXP, SEXP ySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::imat >::type x(xSEXP); + Rcpp::traits::input_parameter< const arma::imat& >::type x(xSEXP); Rcpp::traits::input_parameter< IntegerMatrix >::type y(ySEXP); rcpp_result_gen = Rcpp::wrap(rcpp_cell_from_xy(x, y)); return rcpp_result_gen; END_RCPP } // rcpp_create_neighborhood -IntegerMatrix rcpp_create_neighborhood(arma::imat directions); +IntegerMatrix rcpp_create_neighborhood(const arma::imat& directions); RcppExport SEXP _landscapemetrics_rcpp_create_neighborhood(SEXP directionsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< arma::imat >::type directions(directionsSEXP); + Rcpp::traits::input_parameter< const arma::imat& >::type directions(directionsSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_create_neighborhood(directions)); return rcpp_result_gen; END_RCPP } // rcpp_get_boundaries -IntegerMatrix rcpp_get_boundaries(const IntegerMatrix xx, int directions); +IntegerMatrix rcpp_get_boundaries(const IntegerMatrix& xx, int directions); RcppExport SEXP _landscapemetrics_rcpp_get_boundaries(SEXP xxSEXP, SEXP directionsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type xx(xxSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type xx(xxSEXP); Rcpp::traits::input_parameter< int >::type directions(directionsSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_boundaries(xx, directions)); return rcpp_result_gen; END_RCPP } // rcpp_get_circle -DataFrame rcpp_get_circle(IntegerMatrix mat, const double resolution_xy); +DataFrame rcpp_get_circle(const IntegerMatrix& mat, const double resolution_xy); RcppExport SEXP _landscapemetrics_rcpp_get_circle(SEXP matSEXP, SEXP resolution_xySEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type mat(matSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type mat(matSEXP); Rcpp::traits::input_parameter< const double >::type resolution_xy(resolution_xySEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_circle(mat, resolution_xy)); return rcpp_result_gen; @@ -93,36 +93,36 @@ BEGIN_RCPP END_RCPP } // rcpp_get_coocurrence_matrix -IntegerMatrix rcpp_get_coocurrence_matrix(const IntegerMatrix x, const arma::imat directions); +IntegerMatrix rcpp_get_coocurrence_matrix(const IntegerMatrix& x, const arma::imat directions); RcppExport SEXP _landscapemetrics_rcpp_get_coocurrence_matrix(SEXP xSEXP, SEXP directionsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type x(xSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type x(xSEXP); Rcpp::traits::input_parameter< const arma::imat >::type directions(directionsSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_coocurrence_matrix(x, directions)); return rcpp_result_gen; END_RCPP } // rcpp_get_coocurrence_matrix_diag -IntegerVector rcpp_get_coocurrence_matrix_diag(const IntegerMatrix x, const arma::imat directions); +IntegerVector rcpp_get_coocurrence_matrix_diag(const IntegerMatrix& x, const arma::imat directions); RcppExport SEXP _landscapemetrics_rcpp_get_coocurrence_matrix_diag(SEXP xSEXP, SEXP directionsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type x(xSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type x(xSEXP); Rcpp::traits::input_parameter< const arma::imat >::type directions(directionsSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_coocurrence_matrix_diag(x, directions)); return rcpp_result_gen; END_RCPP } // rcpp_get_coocurrence_matrix_single -IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix x, const arma::imat directions, const int single_class); +IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix& x, const arma::imat directions, const int single_class); RcppExport SEXP _landscapemetrics_rcpp_get_coocurrence_matrix_single(SEXP xSEXP, SEXP directionsSEXP, SEXP single_classSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< const IntegerMatrix >::type x(xSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type x(xSEXP); Rcpp::traits::input_parameter< const arma::imat >::type directions(directionsSEXP); Rcpp::traits::input_parameter< const int >::type single_class(single_classSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_coocurrence_matrix_single(x, directions, single_class)); @@ -142,12 +142,12 @@ BEGIN_RCPP END_RCPP } // rcpp_get_coocurrence_vector -NumericVector rcpp_get_coocurrence_vector(IntegerMatrix x, arma::imat directions, bool ordered); +NumericVector rcpp_get_coocurrence_vector(const IntegerMatrix& x, arma::imat directions, bool ordered); RcppExport SEXP _landscapemetrics_rcpp_get_coocurrence_vector(SEXP xSEXP, SEXP directionsSEXP, SEXP orderedSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< IntegerMatrix >::type x(xSEXP); + Rcpp::traits::input_parameter< const IntegerMatrix& >::type x(xSEXP); Rcpp::traits::input_parameter< arma::imat >::type directions(directionsSEXP); Rcpp::traits::input_parameter< bool >::type ordered(orderedSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_coocurrence_vector(x, directions, ordered)); @@ -155,12 +155,12 @@ BEGIN_RCPP END_RCPP } // rcpp_get_entropy -double rcpp_get_entropy(NumericVector x, std::string base); +double rcpp_get_entropy(NumericVector& x, std::string base); RcppExport SEXP _landscapemetrics_rcpp_get_entropy(SEXP xSEXP, SEXP baseSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; Rcpp::RNGScope rcpp_rngScope_gen; - Rcpp::traits::input_parameter< NumericVector >::type x(xSEXP); + Rcpp::traits::input_parameter< NumericVector& >::type x(xSEXP); Rcpp::traits::input_parameter< std::string >::type base(baseSEXP); rcpp_result_gen = Rcpp::wrap(rcpp_get_entropy(x, base)); return rcpp_result_gen; diff --git a/src/rcpp_create_neighborhood.cpp b/src/rcpp_create_neighborhood.cpp index 355a087ac..6c3141ab8 100644 --- a/src/rcpp_create_neighborhood.cpp +++ b/src/rcpp_create_neighborhood.cpp @@ -12,7 +12,7 @@ using namespace Rcpp; //' If NULL, the coordinates will be calculated for the whole matrix //' @keywords internal // [[Rcpp::export]] -IntegerMatrix rcpp_xy_from_matrix(arma::imat x, Rcpp::Nullable cell = R_NilValue) { +IntegerMatrix rcpp_xy_from_matrix(const arma::imat &x, Rcpp::Nullable cell = R_NilValue) { // adapted from raster::xyFromCell() // get number of rows and columns int n_rows = x.n_rows; @@ -61,7 +61,7 @@ IntegerMatrix rcpp_xy_from_matrix(arma::imat x, Rcpp::Nullable using namespace Rcpp; -IntegerVector rcpp_get_coocurrence_matrix_diag(IntegerMatrix x, +IntegerVector rcpp_get_coocurrence_matrix_diag(const IntegerMatrix &x, const arma::imat directions); #endif // RCPP_GET_CONTIG_MEAN_H diff --git a/src/rcpp_get_coocurrence_matrix_single.cpp b/src/rcpp_get_coocurrence_matrix_single.cpp index 97d0b713c..aee5c708c 100644 --- a/src/rcpp_get_coocurrence_matrix_single.cpp +++ b/src/rcpp_get_coocurrence_matrix_single.cpp @@ -4,7 +4,7 @@ #include "rcpp_get_class_index_map.h" // [[Rcpp::export]] -IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix x, +IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix &x, const arma::imat directions, const int single_class) { const int na = NA_INTEGER; diff --git a/src/rcpp_get_coocurrence_matrix_single.h b/src/rcpp_get_coocurrence_matrix_single.h index f7fffba10..2a44b7c11 100644 --- a/src/rcpp_get_coocurrence_matrix_single.h +++ b/src/rcpp_get_coocurrence_matrix_single.h @@ -6,7 +6,7 @@ using namespace Rcpp; // [[Rcpp::depends(RcppArmadillo)]] // [[Rcpp::plugins(cpp11)]] -IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix x, +IntegerMatrix rcpp_get_coocurrence_matrix_single(const IntegerMatrix &x, const arma::imat directions, const int single_class); #endif // GET_COOCURRENCE_MATRIX_SINGLE_H diff --git a/src/rcpp_get_coocurrence_vector.cpp b/src/rcpp_get_coocurrence_vector.cpp index 96d486008..68631a3fb 100644 --- a/src/rcpp_get_coocurrence_vector.cpp +++ b/src/rcpp_get_coocurrence_vector.cpp @@ -12,7 +12,7 @@ int triangular_index(int r, int c) { } // [[Rcpp::export]] -NumericVector rcpp_get_coocurrence_vector(IntegerMatrix x, arma::imat directions, bool ordered = true) { +NumericVector rcpp_get_coocurrence_vector(const IntegerMatrix &x, arma::imat directions, bool ordered = true) { NumericVector result; // calculate a coocurrence matrix IntegerMatrix y = rcpp_get_coocurrence_matrix(x, directions); diff --git a/src/rcpp_get_coocurrence_vector.h b/src/rcpp_get_coocurrence_vector.h index 520b9ea94..b16389af5 100644 --- a/src/rcpp_get_coocurrence_vector.h +++ b/src/rcpp_get_coocurrence_vector.h @@ -8,6 +8,6 @@ using namespace Rcpp; int triangular_index(int r, int c); -NumericVector rcpp_get_coocurrence_vector(IntegerMatrix x, arma::imat directions, bool ordered = true); +NumericVector rcpp_get_coocurrence_vector(const IntegerMatrix &x, arma::imat directions, bool ordered = true); #endif // GET_COOCURRENCE_VECTOR_H diff --git a/src/rcpp_get_entropy.cpp b/src/rcpp_get_entropy.cpp index be315a598..0b53ab367 100644 --- a/src/rcpp_get_entropy.cpp +++ b/src/rcpp_get_entropy.cpp @@ -2,7 +2,7 @@ using namespace Rcpp; // [[Rcpp::export]] -double rcpp_get_entropy(NumericVector x, std::string base = "log2") { +double rcpp_get_entropy(NumericVector &x, std::string base = "log2") { x = x / sum(x); double result = 0.0; for(int i = 0; i < x.size(); i++){ diff --git a/src/rcpp_get_nearest_neighbor.cpp b/src/rcpp_get_nearest_neighbor.cpp index f5ad6a926..10db40ecf 100644 --- a/src/rcpp_get_nearest_neighbor.cpp +++ b/src/rcpp_get_nearest_neighbor.cpp @@ -10,7 +10,7 @@ inline double compute_d2(double x1, double y1, double x2, double y2) { } // [[Rcpp::export]] -NumericVector find_min(const NumericMatrix& points, int i, int m) { +NumericVector find_min(const NumericMatrix &points, int i, int m) { double x_i = points(i, 0), y_i = points(i, 1), id_i = points(i, 2); @@ -77,7 +77,7 @@ NumericVector find_min(const NumericMatrix& points, int i, int m) { //' @name rcpp_get_nearest_neighbor //' @export // [[Rcpp::export]] -NumericMatrix rcpp_get_nearest_neighbor(const NumericMatrix& points) { +NumericMatrix rcpp_get_nearest_neighbor(const NumericMatrix &points) { int nrows = points.nrow(); NumericMatrix distances(nrows, 2);