diff --git a/.travis.yml b/.travis.yml index 57d588c60..741a5a7ad 100644 --- a/.travis.yml +++ b/.travis.yml @@ -5,8 +5,8 @@ # DO NOT CHANGE THE CODE BELOW before_install: - sudo add-apt-repository ppa:ubuntugis/ubuntugis-unstable --yes - - sudo apt-get update -qq - - sudo apt-get install --yes libudunits2-dev libproj-dev libgeos-dev libgdal-dev libgsl0-dev bwidget + - sudo apt-get --yes --force-yes update -qq + - sudo apt-get install --yes libudunits2-dev libproj-dev libgeos-dev libgdal-dev libgsl0-dev bwidget - sudo add-apt-repository -y ppa:ubuntu-toolchain-r/test - sudo apt-get -qq update - sudo apt-get -qq install gcc @@ -34,7 +34,6 @@ after_script: R -q -e 'tic::after_script()' # Header language: r sudo: true -dist: trusty cache: packages warnings_are_errors: false @@ -47,8 +46,8 @@ env: notifications: email: recipients: - - maximilian.hesselbarth@uni-goettingen.de - on_success: always # default: change + - mhk.hesselbarth@gmail.com + on_success: change # default: change on_failure: always # default: always #services diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 580da5fdc..473bf64e5 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -23,6 +23,6 @@ Before making changes make sure to pull changes in from upstream by doing either * Push up to your account * Submit a pull request to home base at `r-spatialecology/landscapemetrics` -### Questions? Get in touch: [sciaini.marco@gmail.com](mailto:sciaini.marco@gmail.com) or [maximilian.hesselbarth@uni-goettingen.de](mailto:maximilian.hesselbarth@uni-goettingen.de) +### Questions? Get in touch: [sciaini.marco@gmail.com](mailto:sciaini.marco@gmail.com) or [mhk.hesselbarth@gmail.com](mailto:mhk.hesselbarth@gmail.com) ### Thanks for contributing! diff --git a/DESCRIPTION b/DESCRIPTION index 4b4162d33..b705b7750 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: landscapemetrics Title: Landscape Metrics for Categorical Map Patterns -Version: 1.4.4 +Version: 1.4.5 Authors@R: c(person("Maximillian H.K.", "Hesselbarth", role = c("aut", "cre"), email = "mhk.hesselbarth@gmail.com", @@ -77,6 +77,6 @@ ByteCompile: true Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.1.0 +RoxygenNote: 7.1.1.9000 SystemRequirements: C++11 VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index a18239ec9..6907c1d5b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,8 +32,12 @@ S3method(get_boundaries,RasterBrick) S3method(get_boundaries,RasterLayer) S3method(get_boundaries,RasterStack) S3method(get_boundaries,list) -S3method(get_boundaries,matrix) S3method(get_boundaries,stars) +S3method(get_centroids,RasterBrick) +S3method(get_centroids,RasterLayer) +S3method(get_centroids,RasterStack) +S3method(get_centroids,list) +S3method(get_centroids,stars) S3method(get_circumscribingcircle,RasterBrick) S3method(get_circumscribingcircle,RasterLayer) S3method(get_circumscribingcircle,RasterStack) @@ -43,7 +47,6 @@ S3method(get_nearestneighbour,RasterBrick) S3method(get_nearestneighbour,RasterLayer) S3method(get_nearestneighbour,RasterStack) S3method(get_nearestneighbour,list) -S3method(get_nearestneighbour,matrix) S3method(get_nearestneighbour,stars) S3method(get_patches,RasterBrick) S3method(get_patches,RasterLayer) @@ -783,6 +786,8 @@ export(data_info) export(extract_lsm) export(get_adjacencies) export(get_boundaries) +export(get_boundaries_calc) +export(get_centroids) export(get_circumscribingcircle) export(get_nearestneighbour) export(get_patches) diff --git a/NEWS.md b/NEWS.md index 8d1e0b773..ec4c73b1f 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,14 @@ +# landscapemetrics 1.4.5 +* Bugfixes + * Fix of patch id in `get_circumscribingcircle()` +* Improvements + * `lsm_p_gyrate` has an argument to force the cell centroid to be within patch + * `get_nearestneighbour()` can now return ID of neighbouring patch + * `get_boundaries()` allows now to specify edge depth + * `get_boundaries()` can return the patch id for edge cells +* New gunctions + * `get_centroid()` returns the coordinates of each patch centroid + # landscapemetrics 1.4.4 * Improvements * Set labels = FALSE as default for all plotting functions (messy for larger raster) diff --git a/R/RcppExports.R b/R/RcppExports.R index ca7e6aa1f..9224f5beb 100644 --- a/R/RcppExports.R +++ b/R/RcppExports.R @@ -76,6 +76,10 @@ rcpp_get_entropy <- function(x, base = "log2") { .Call('_landscapemetrics_rcpp_get_entropy', PACKAGE = 'landscapemetrics', x, base) } +find_min <- function(points, i, m) { + .Call('_landscapemetrics_find_min', PACKAGE = 'landscapemetrics', points, i, m) +} + #' @title First nearest neighbor distance #' #' @description Efficiently calculate the distance to the first nearest neighbor. diff --git a/R/calculate_lsm.R b/R/calculate_lsm.R index f17820db2..79673edba 100644 --- a/R/calculate_lsm.R +++ b/R/calculate_lsm.R @@ -5,18 +5,20 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param level Level of metrics. Either 'patch', 'class' or 'landscape' (or vector with combination). #' @param metric Abbreviation of metrics (e.g. 'area'). -#' @param name Full name of metrics (e.g. 'core area') +#' @param name Full name of metrics (e.g. 'core area'). #' @param type Type according to FRAGSTATS grouping (e.g. 'aggregation metrics'). #' @param what Selected level of metrics: either "patch", "class" or "landscape". #' It is also possible to specify functions as a vector of strings, e.g. `what = c("lsm_c_ca", "lsm_l_ta")`. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). -#' @param count_boundary Include landscape boundary in edge length +#' @param count_boundary Include landscape boundary in edge length. #' @param consider_boundary Logical if cells that only neighbour the landscape -#' boundary should be considered as core +#' boundary should be considered as core. #' @param edge_depth Distance (in cells) a cell has the be away from the patch -#' edge to be considered as core cell -#' @param classes_max Potential maximum number of present classes +#' edge to be considered as core cell. +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. +#' @param classes_max Potential maximum number of present classes. #' @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). @@ -69,6 +71,7 @@ calculate_lsm <- function(landscape, count_boundary, consider_boundary, edge_depth, + cell_center, classes_max, neighbourhood, ordered, @@ -89,6 +92,7 @@ calculate_lsm.RasterLayer <- function(landscape, count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -108,6 +112,7 @@ calculate_lsm.RasterLayer <- function(landscape, count_boundary = count_boundary, consider_boundary = consider_boundary, edge_depth = edge_depth, + cell_center = cell_center, classes_max = classes_max, neighbourhood = neighbourhood, ordered = ordered, @@ -138,6 +143,7 @@ calculate_lsm.RasterStack <- function(landscape, count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -165,6 +171,7 @@ calculate_lsm.RasterStack <- function(landscape, count_boundary = count_boundary, consider_boundary = consider_boundary, edge_depth = edge_depth, + cell_center = cell_center, classes_max = classes_max, neighbourhood = neighbourhood, ordered = ordered, @@ -198,6 +205,7 @@ calculate_lsm.RasterBrick <- function(landscape, count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -225,6 +233,7 @@ calculate_lsm.RasterBrick <- function(landscape, count_boundary = count_boundary, consider_boundary = consider_boundary, edge_depth = edge_depth, + cell_center = cell_center, classes_max = classes_max, neighbourhood = neighbourhood, ordered = ordered, @@ -258,6 +267,7 @@ calculate_lsm.stars <- function(landscape, count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -285,6 +295,7 @@ calculate_lsm.stars <- function(landscape, count_boundary = count_boundary, consider_boundary = consider_boundary, edge_depth = edge_depth, + cell_center = cell_center, classes_max = classes_max, neighbourhood = neighbourhood, ordered = ordered, @@ -319,6 +330,7 @@ calculate_lsm.list <- function(landscape, count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -344,6 +356,7 @@ calculate_lsm.list <- function(landscape, count_boundary = count_boundary, consider_boundary = consider_boundary, edge_depth = edge_depth, + cell_center = cell_center, classes_max = classes_max, neighbourhood = neighbourhood, ordered = ordered, @@ -375,6 +388,7 @@ calculate_lsm_internal <- function(landscape, count_boundary, consider_boundary, edge_depth, + cell_center, classes_max, neighbourhood, ordered, diff --git a/R/get_boundaries.R b/R/get_boundaries.R index ded80c408..367233fd3 100644 --- a/R/get_boundaries.R +++ b/R/get_boundaries.R @@ -3,11 +3,13 @@ #' @description Get boundary cells of patches #' #' @param landscape RasterLayer or matrix. -#' @param directions Rook's case (4 neighbours) or queen's case (8 neighbours) should be used as neighbourhood rule #' @param consider_boundary Logical if cells that only neighbour the landscape -#' boundary should be considered as edge -#' @param as_NA If true, non-boundary cells area labeld NA -#' @param return_raster If false, matrix is returned +#' boundary should be considered as edge. +#' @param edge_depth Distance (in cells) a cell has the be away from the patch +#' edge to be considered as core cell. +#' @param as_NA If true, non-boundary cells area labeld NA. +#' @param patch_id If true, boundary/edge cells are labeled with the original patch id. +#' @param return_raster If false, matrix is returned. #' #' @details #' All boundary/edge cells are labeled 1, all non-boundary cells 0. NA values are @@ -23,40 +25,34 @@ #' get_boundaries(class_1) #' get_boundaries(class_1, return_raster = FALSE) #' -#' class_1_matrix <- raster::as.matrix(class_1) -#' get_boundaries(class_1_matrix, return_raster = FALSE) -#' #' @aliases get_boundaries #' @rdname get_boundaries #' #' @export get_boundaries <- function(landscape, - directions, - as_NA, consider_boundary, + edge_depth, + as_NA, + patch_id, return_raster) UseMethod("get_boundaries") #' @name get_boundaries #' @export get_boundaries.RasterLayer <- function(landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE) { - # check if either directions are possible - if (directions != 4 && directions != 8) { - - stop("Please specify 'directions = 4' or 'directions = 8'.", call. = FALSE) - } - # get boundaries result <- lapply(raster::as.list(landscape), function(x) { - result_temp <- get_boundaries.matrix(raster::as.matrix(x), - directions = directions, - consider_boundary = consider_boundary, - as_NA = as_NA)[[1]] + result_temp <- get_boundaries_calc(raster::as.matrix(x), + consider_boundary = consider_boundary, + edge_depth = edge_depth, + as_NA = as_NA, + patch_id = patch_id) # convert back to raster if (return_raster) { @@ -74,24 +70,20 @@ get_boundaries.RasterLayer <- function(landscape, #' @name get_boundaries #' @export get_boundaries.RasterStack <- function(landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE) { - # check if either directions are possible - if (directions != 4 && directions != 8) { - - stop("Please specify 'directions = 4' or 'directions = 8'.", call. = FALSE) - } - # get boundaries result <- lapply(X = raster::as.list(landscape), function(x) { - result_temp <- get_boundaries.matrix(raster::as.matrix(x), - directions = directions, - consider_boundary = consider_boundary, - as_NA = as_NA)[[1]] + result_temp <- get_boundaries_calc(raster::as.matrix(x), + consider_boundary = consider_boundary, + edge_depth = edge_depth, + as_NA = as_NA, + patch_id = patch_id) # convert back to raster if (return_raster) { @@ -109,24 +101,20 @@ get_boundaries.RasterStack <- function(landscape, #' @name get_boundaries #' @export get_boundaries.RasterBrick <- function(landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE) { - # check if either directions are possible - if (directions != 4 && directions != 8) { - - stop("Please specify 'directions = 4' or 'directions = 8'.", call. = FALSE) - } - # get boundaries result <- lapply(X = raster::as.list(landscape), function(x) { - result_temp <- get_boundaries.matrix(raster::as.matrix(x), - directions = directions, - consider_boundary = consider_boundary, - as_NA = as_NA)[[1]] + result_temp <- get_boundaries_calc(raster::as.matrix(x), + consider_boundary = consider_boundary, + edge_depth = edge_depth, + as_NA = as_NA, + patch_id = patch_id) # convert back to raster if (return_raster) { @@ -144,27 +132,23 @@ get_boundaries.RasterBrick <- function(landscape, #' @name get_boundaries #' @export get_boundaries.stars <- function(landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE) { - # check if either directions are possible - if (directions != 4 && directions != 8) { - - stop("Please specify 'directions = 4' or 'directions = 8'.", call. = FALSE) - } - # convert as raster landscape <- methods::as(landscape, "Raster") # get boundaries result <- lapply(X = raster::as.list(landscape), function(x) { - result_temp <- get_boundaries.matrix(raster::as.matrix(x), - directions = directions, - consider_boundary = consider_boundary, - as_NA = as_NA)[[1]] + result_temp <- get_boundaries_calc(raster::as.matrix(x), + consider_boundary = consider_boundary, + edge_depth = edge_depth, + as_NA = as_NA, + patch_id = patch_id) # convert back to raster if (return_raster) { @@ -182,24 +166,20 @@ get_boundaries.stars <- function(landscape, #' @name get_boundaries #' @export get_boundaries.list <- function(landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE) { - # check if either directions are possible - if (directions != 4 && directions != 8) { - - stop("Please specify 'directions = 4' or 'directions = 8'.", call. = FALSE) - } - # get boundaries result <- lapply(X = landscape, function(x) { - result_temp <- get_boundaries.matrix(raster::as.matrix(x), - directions = directions, - consider_boundary = consider_boundary, - as_NA = as_NA)[[1]] + result_temp <- get_boundaries_calc(raster::as.matrix(x), + consider_boundary = consider_boundary, + edge_depth = edge_depth, + as_NA = as_NA, + patch_id = patch_id) # convert back to raster if (return_raster) { @@ -216,18 +196,11 @@ get_boundaries.list <- function(landscape, #' @name get_boundaries #' @export -get_boundaries.matrix <- function(landscape, - directions = 4, - as_NA = FALSE, - consider_boundary = FALSE, - return_raster = FALSE) { - - if (return_raster) { - - warning("'return_raster = TRUE' not able for matrix input.", - call. = FALSE) - } - +get_boundaries_calc <- function(landscape, + consider_boundary, + edge_depth, + as_NA, + patch_id) { # add padding for landscape boundary if (!consider_boundary) { @@ -240,23 +213,72 @@ get_boundaries.matrix <- function(landscape, } # get boundaries - landscape <- rcpp_get_boundaries(landscape, - directions = directions) + landscape_boundaries <- rcpp_get_boundaries(landscape, + directions = 4) + + # loop if edge_depth > 1 + if (edge_depth > 1) { + + # save original landscape + landscape_boundaries_temp <- landscape_boundaries + + # first edge depth already labels + for (i in seq_len(edge_depth - 1)) { + + # set all already edge to NA + landscape_boundaries_temp[landscape_boundaries_temp == 1] <- NA + + # set current_edge + 1 to new edge + landscape_boundaries_temp <- rcpp_get_boundaries(landscape_boundaries_temp, + directions = 4) + + landscape_boundaries[which(landscape_boundaries_temp[] == 1)] <- 1 + } + } # remove padded rows/cols if (!consider_boundary) { - landscape <- unpad_raster(landscape, - unpad_raster_cells = 1, - return_raster = FALSE, - to_disk = FALSE)[[1]] + landscape_boundaries <- unpad_raster(landscape_boundaries, + unpad_raster_cells = 1, + return_raster = FALSE, + to_disk = FALSE)[[1]] + } + + # use original patch id + if(patch_id) { + + # issue if class 0 is present because used for non-edge cells + present_classes <- rcpp_get_unique_values(landscape) + + if(any(present_classes == 0)) { + warning("Not able to use original patch id because at least one id equals zero.", + call. = FALSE) + } + + # relabel edge cells (value = 1) with original patch id + else { + + # remove padded rows/cols + if (!consider_boundary) { + + landscape <- unpad_raster(landscape, + unpad_raster_cells = 1, + return_raster = FALSE, + to_disk = FALSE)[[1]] + } + + landscape_boundaries[landscape_boundaries == 1 & + !is.na(landscape_boundaries)] <- landscape[landscape_boundaries == 1 & + !is.na(landscape_boundaries)] + } } # convert all 0 as NA if (as_NA) { - landscape[which(landscape == 0)] <- NA + landscape_boundaries[which(landscape_boundaries == 0)] <- NA } - return(list(landscape)) + return(landscape_boundaries) } diff --git a/R/get_centroids.R b/R/get_centroids.R new file mode 100644 index 000000000..aa614bfef --- /dev/null +++ b/R/get_centroids.R @@ -0,0 +1,281 @@ +#' get_centroids +#' +#' @description Centroid of patches +#' +#' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. +#' @param directions The number of directions in which patches should be +#' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. +#' @param return_sp If true, a SpatialPointsDataFrame is returned. +#' @param verbose Print warning messages +#' +#' @details +#' Get the coordinates of the centroid of each patch. The centroid is by default +#' defined as the mean location of all cell centers. To force the centroid to be +#' located within each patch, use the `cell_center` argument. In this case, the +#' centroid is defined as the cell center that is the closest to the mean location. +#' +#' @examples +#' # get centroid location +#' get_centroids(landscape) +#' +#' @aliases get_centroids +#' @rdname get_centroids +#' +#' @export +get_centroids <- function(landscape, directions, cell_center, return_sp, verbose) UseMethod("get_centroids") + +#' @name get_centroids +#' @export +get_centroids.RasterLayer <- function(landscape, directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE) { + + result <- lapply(X = raster::as.list(landscape), + FUN = get_centroids_calc, + directions = directions, + cell_center = cell_center, + verbose = verbose) + + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) + + result <- do.call(rbind, result) + + result <- tibble::add_column(result, layer, .before = TRUE) + + if (return_sp) { + + result <- sp::SpatialPointsDataFrame(coords = result[, c(5:6)], + data = result[, c(1:4)], + proj4string = raster::crs(landscape)) + } + + return(result) +} + +#' @name get_centroids +#' @export +get_centroids.RasterStack <- function(landscape, directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE) { + + result <- lapply(X = raster::as.list(landscape), + FUN = get_centroids_calc, + directions = directions, + cell_center = cell_center, + verbose = verbose) + + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) + + result <- do.call(rbind, result) + + result <- tibble::add_column(result, layer, .before = TRUE) + + return(result) +} + +#' @name get_centroids +#' @export +get_centroids.RasterBrick <- function(landscape, directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE) { + + result <- lapply(X = raster::as.list(landscape), + FUN = get_centroids_calc, + directions = directions, + cell_center = cell_center, + verbose = verbose) + + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) + + result <- do.call(rbind, result) + + result <- tibble::add_column(result, layer, .before = TRUE) + + if (return_sp) { + + result <- sp::SpatialPointsDataFrame(coords = result[, c(5:6)], + data = result[, c(1:4)], + proj4string = raster::crs(landscape)) + } + + return(result) +} + +#' @name get_centroids +#' @export +get_centroids.stars <- function(landscape, directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE) { + + landscape <- methods::as(landscape, "Raster") + + result <- lapply(X = raster::as.list(landscape), + FUN = get_centroids_calc, + directions = directions, + cell_center = cell_center, + verbose = verbose) + + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) + + result <- do.call(rbind, result) + + result <- tibble::add_column(result, layer, .before = TRUE) + + if (return_sp) { + + result <- sp::SpatialPointsDataFrame(coords = result[, c(5:6)], + data = result[, c(1:4)], + proj4string = raster::crs(landscape)) + } + + return(result) +} + +#' @name get_centroids +#' @export +get_centroids.list <- function(landscape, directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE) { + + result <- lapply(X = landscape, + FUN = get_centroids_calc, + directions = directions, + cell_center = cell_center, + verbose = verbose) + + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) + + result <- do.call(rbind, result) + + result <- tibble::add_column(result, layer, .before = TRUE) + + if (return_sp) { + + result <- sp::SpatialPointsDataFrame(coords = result[, c(5:6)], + data = result[, c(1:4)], + proj4string = raster::crs(landscape)) + } + + return(result) +} + +get_centroids_calc <- function(landscape, directions, cell_center, verbose) { + + # conver 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 <- raster::as.matrix(landscape) + } + + # all values NA + if (all(is.na(landscape))) { + + return(tibble::tibble(level = "patch", + class = as.integer(NA), + id = as.integer(NA), + y = as.double(NA), + y = as.double(NA))) + } + + # get uniuqe class id + classes <- get_unique_values(landscape)[[1]] + + centroid <- do.call(rbind, + lapply(classes, function(patches_class) { + # get connected patches + landscape_labeled <- get_patches(landscape, + class = patches_class, + directions = directions, + return_raster = FALSE)[[1]] + + # 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) + + # set ID from class ID to unique patch ID + points[, 3] <- landscape_labeled[!is.na(landscape_labeled)] + + # # conver to tibble + points <- stats::setNames(object = data.frame(points), + nm = c("x", "y", "id")) + + # calcuale the centroid of each patch (mean of all coords) + centroid_temp <- stats::aggregate(points[, c(1, 2)], + by = list(id = points[, 3]), + FUN = mean) + + # force centroid to be within patch + if (cell_center) { + + # create full data set with raster-points and patch centroids + full_data <- merge(x = points, y = centroid_temp, by = "id", + suffixes = c("","_centroid")) + + # calculate distance from each cell center to centroid + full_data$dist <- sqrt((full_data$x - full_data$x_centroid) ^ 2 + + (full_data$y - full_data$y_centroid) ^ 2) + + # which cell has the shortest distance to centroid + centroid_temp <- + do.call(rbind, + by(data = full_data, + INDICES = full_data[, 1], + FUN = function(x) { + x[x$dist == min(x$dist), ][, c(1, 2, 3)]})) + } + + # return current class id and coords + data.frame(class = patches_class, + id = centroid_temp$id, + x = centroid_temp$x, + y = centroid_temp$y) + }) + ) + + # get number of total patches to construct id seq + np <- lsm_l_np_calc(landscape, directions = directions)[[1, 5]] + + # check how often different combinations of class-id are present + times <- as.numeric(t(table(centroid[, c(1, 2)]))) + + # remove all 0 cases + times <- times[which(times != 0)] + + # repeat each id (# patches) where times is the number of often the class-id + # combination is present + id <- rep(seq_len(np), times = times[times != 0]) + + # return warning if any patch has several centroids + if (verbose) { + + if (any(times != 1)) { + warning("For some patches several cell centers are returned as centroid.", + call. = FALSE) + } + } + + tibble::tibble(level = "patch", + class = as.integer(centroid$class), + id = as.integer(id), + x = as.double(centroid$x), + y = as.double(centroid$y)) +} diff --git a/R/get_circumscribingcircle.R b/R/get_circumscribingcircle.R index cda53226b..dcb943c7a 100644 --- a/R/get_circumscribingcircle.R +++ b/R/get_circumscribingcircle.R @@ -178,26 +178,29 @@ get_circumscribingcircle_calc <- function(landscape, level, directions) { classes <- get_unique_values(landscape)[[1]] # loop all classes - circle <- do.call(rbind, lapply(classes, function(patches_class) { - - # get patches - landscape_labeled <- get_patches(landscape, - class = patches_class, - directions = directions, - to_disk = FALSE, - return_raster = FALSE)[[1]] - - # get circle - circle_patch <- rcpp_get_circle(landscape_labeled, - resolution_xy = resolution[1]) - - # resulting tibble - circle_patch <- tibble::tibble(level = "patch", - class = as.integer(patches_class), - id = as.integer(circle_patch$patch_id), - value = circle_patch$circle_diameter, - center_x = circle_patch$circle_center_x, - center_y = circle_patch$circle_center_y)})) + circle <- do.call(rbind, + lapply(classes, function(patches_class) { + # get patches + landscape_labeled <- get_patches(landscape, + class = patches_class, + directions = directions, + to_disk = FALSE, + return_raster = FALSE)[[1]] + + # get circle + cbind(class = as.integer(patches_class), + rcpp_get_circle(landscape_labeled, + resolution_xy = resolution[1])) + }) + ) + + # resulting tibble + circle <- tibble::tibble(level = "patch", + 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) } # class level (no labeling) @@ -215,7 +218,6 @@ get_circumscribingcircle_calc <- function(landscape, level, directions) { center_y = circle_class$circle_center_y) } - # shift the coordinates to the original coordinate system circle$center_x = circle$center_x + extent@xmin circle$center_y = circle$center_y + extent@ymin diff --git a/R/get_nearestneighbour.R b/R/get_nearestneighbour.R index e6032228c..f54eae4ba 100644 --- a/R/get_nearestneighbour.R +++ b/R/get_nearestneighbour.R @@ -2,225 +2,170 @@ #' #' @description Euclidean distance to nearest neighbour #' -#' @param landscape RasterLayer or matrix (with x,y,id columns) +#' @param landscape RasterLayer or matrix (with x,y,id columns). +#' @param return_id If TRUE, also the patch ID of the nearest neighbour is returned. #' #' @details #' Fast and memory safe Rcpp implementation for calculating the minimum Euclidean -#' distances to the nearest patch of the same class in a raster or matrix. All patches need an unique -#' ID (see \code{\link{get_patches}}). +#' distances to the nearest patch of the same class in a raster or matrix. +#' All patches need an unique ID (see \code{\link{get_patches}}). Please be aware +#' that the patch ID is not identical to the patch ID of all metric functions (lsm_). +#' If `return_ID = TRUE`, for some focal patches several nearest neighbour patches +#' might be returned. #' #' @references #' Based on RCpp code of Florian Privé \email{florian.prive.21@gmail.com} #' #' @examples -#' # get patches for class 1 from testdata as raster -#' class_1 <- get_patches(landscape,1)[[1]] +#' # get patches for class 1 +#' class_1 <- get_patches(landscape, class = 2)[[1]] #' #' # calculate the distance between patches #' get_nearestneighbour(class_1) -#' -#' # do the same with a 3 column matrix (x, y, id) -#' class_1_matrix <- raster::rasterToPoints(class_1) -#' get_nearestneighbour(class_1_matrix) +#' get_nearestneighbour(class_1, return_id = TRUE) #' #' @aliases get_nearestneighbour #' @rdname get_nearestneighbour #' #' @export -get_nearestneighbour <- function(landscape) UseMethod("get_nearestneighbour") +get_nearestneighbour <- function(landscape, return_id) UseMethod("get_nearestneighbour") #' @name get_nearestneighbour #' @export -get_nearestneighbour.RasterLayer <- function(landscape) { - - result <- lapply(seq_along(raster::as.list(landscape)), function(x) { - - points_mat <- raster_to_points(landscape[[x]], return_NA = FALSE)[, 2:4] - - ord <- order(as.matrix(points_mat)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) - - res <- rcpp_get_nearest_neighbor(raster::as.matrix(points_mat)[ord, ]) +get_nearestneighbour.RasterLayer <- function(landscape, return_id = FALSE) { - min_dist <- unname(cbind(num, res[rank], as.matrix(points_mat)[, 3])) + result <- lapply(X = raster::as.list(landscape), + FUN = get_nearestneighbour_calc, + return_id = return_id) - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) - - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) - - tibble::add_column(tbl, layer = x, .before = TRUE) - }) + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) result <- do.call(rbind, result) - return(result) + tibble::add_column(result, layer, .before = TRUE) } #' @name get_nearestneighbour #' @export -get_nearestneighbour.RasterStack <- function(landscape) { - - result <- lapply(seq_along(raster::as.list(landscape)), function(x) { - - points_mat <- raster_to_points(landscape[[x]], return_NA = FALSE)[, 2:4] +get_nearestneighbour.RasterStack <- function(landscape, return_id = FALSE) { - ord <- order(as.matrix(points_mat)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) + result <- lapply(X = raster::as.list(landscape), + FUN = get_nearestneighbour_calc, + return_id = return_id) - res <- rcpp_get_nearest_neighbor(raster::as.matrix(points_mat)[ord, ]) - - min_dist <- unname(cbind(num, res[rank], as.matrix(points_mat)[, 3])) - - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) - - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) - - tibble::add_column(tbl, layer = x, .before = TRUE) - }) + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) result <- do.call(rbind, result) - return(result) + tibble::add_column(result, layer, .before = TRUE) } #' @name get_nearestneighbour #' @export -get_nearestneighbour.RasterBrick <- function(landscape) { - - result <- lapply(seq_along(raster::as.list(landscape)), function(x) { - - points_mat <- raster_to_points(landscape[[x]], return_NA = FALSE)[, 2:4] - - ord <- order(as.matrix(points_mat)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) - - res <- rcpp_get_nearest_neighbor(raster::as.matrix(points_mat)[ord, ]) - - min_dist <- unname(cbind(num, res[rank], as.matrix(points_mat)[, 3])) +get_nearestneighbour.RasterBrick <- function(landscape, return_id = FALSE) { - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) + result <- lapply(X = raster::as.list(landscape), + FUN = get_nearestneighbour_calc, + return_id = return_id) - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) - - tibble::add_column(tbl, layer = x, .before = TRUE) - }) + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) result <- do.call(rbind, result) - return(result) + tibble::add_column(result, layer, .before = TRUE) } #' @name get_nearestneighbour #' @export -get_nearestneighbour.stars <- function(landscape) { +get_nearestneighbour.stars <- function(landscape, return_id = FALSE) { landscape <- methods::as(landscape, "Raster") - result <- lapply(seq_along(raster::as.list(landscape)), function(x) { - - points_mat <- raster_to_points(landscape[[x]], return_NA = FALSE)[, 2:4] - - ord <- order(as.matrix(points_mat)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) - - res <- rcpp_get_nearest_neighbor(raster::as.matrix(points_mat)[ord, ]) - - min_dist <- unname(cbind(num, res[rank], as.matrix(points_mat)[, 3])) + result <- lapply(X = raster::as.list(landscape), + FUN = get_nearestneighbour_calc, + return_id = return_id) - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) - - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) - - tibble::add_column(tbl, layer = x, .before = TRUE) - }) + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) result <- do.call(rbind, result) - return(result) + tibble::add_column(result, layer, .before = TRUE) } #' @name get_nearestneighbour #' @export -get_nearestneighbour.list <- function(landscape) { +get_nearestneighbour.list <- function(landscape, return_id = FALSE) { - result <- lapply(seq_along(landscape), function(x) { + result <- lapply(X = landscape, + FUN = get_nearestneighbour_calc, + return_id = return_id) - points_mat <- raster_to_points(landscape[[x]], return_NA = FALSE)[, 2:4] + layer <- rep(seq_along(result), + vapply(result, nrow, FUN.VALUE = integer(1))) - ord <- order(as.matrix(points_mat)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) + result <- do.call(rbind, result) - res <- rcpp_get_nearest_neighbor(raster::as.matrix(points_mat)[ord, ]) + tibble::add_column(result, layer, .before = TRUE) +} - min_dist <- unname(cbind(num, res[rank], as.matrix(points_mat)[, 3])) +get_nearestneighbour_calc <- function(landscape, return_id, + points = NULL) { - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) + # convert to matrix + if (!inherits(x = landscape, what = "matrix")) { - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) + # get coordinates and values of all cells + points <- raster_to_points(landscape)[, 2:4] - tibble::add_column(tbl, layer = x, .before = TRUE) - }) + # convert to matrix + landscape <- raster::as.matrix(landscape) + } - result <- do.call(rbind, result) + # get edge cells because only they are important for ENN + class_boundaries <- get_boundaries_calc(landscape, + consider_boundary = FALSE, + edge_depth = 1, + as_NA = TRUE, + patch_id = TRUE) - return(result) -} + # transpose to get same direction of ID + class_boundaries <- t(class_boundaries) -#' @name get_nearestneighbour -#' @export -get_nearestneighbour.matrix <- function(landscape) { + # get coordinates of current class + points <- points[which(!is.na(class_boundaries)), ] - if ( ncol(landscape) != 3) { - stop("Coordinate matrix must have 3 (x,y,id) columns.", call. = TRUE) - } + # set ID from class ID to unique patch ID + points[, 3] <- class_boundaries[!is.na(class_boundaries)] - ord <- order(as.matrix(landscape)[, 1]) + ord <- order(as.matrix(points)[, 1]) num <- seq_along(ord) rank <- match(num, ord) - res <- rcpp_get_nearest_neighbor(raster::as.matrix(landscape)[ord, ]) + res <- rcpp_get_nearest_neighbor(raster::as.matrix(points)[ord, ]) - min_dist <- unname(cbind(num, res[rank], as.matrix(landscape)[, 3])) + min_dist <- tibble::tibble(cell = num, + dist = res[rank, 1], + id_focal = points[, 3], + id_neighbour = res[rank, 2]) - tbl <- tibble::tibble(cell = min_dist[, 1], - dist = min_dist[, 2], - id = min_dist[, 3]) + min_dist_aggr <- stats::setNames(stats::aggregate(x = min_dist$dist, + by = list(min_dist$id_focal), + FUN = min), + c("id", "dist")) - tbl <- stats::setNames(tibble::as_tibble(stats::aggregate(x = tbl[, 2], - by = tbl[,3], - FUN = min)), - c("id", "distance")) + if(return_id) { - tibble::add_column(tbl, layer = 1, .before = TRUE) + min_dist_aggr <- merge(x = min_dist_aggr, y = min_dist[, c(2, 3, 4)], + by.x = c("id", "dist"), + by.y = c("id_focal", "dist"), + sort = FALSE) + + min_dist_aggr <- min_dist_aggr[!duplicated(min_dist_aggr), ] + } + tibble::tibble(min_dist_aggr) } diff --git a/R/lsm_c_gyrate_cv.R b/R/lsm_c_gyrate_cv.R index 7edd9b967..117d36683 100644 --- a/R/lsm_c_gyrate_cv.R +++ b/R/lsm_c_gyrate_cv.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{CV} = cv(GYRATE[patch_{ij}])} @@ -17,6 +19,10 @@ #' both the patch area and compactness. The Coefficient of variation is #' scaled to the mean and comparable among different landscapes. #' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. +#' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_CV >= 0 } #' \subsection{Behaviour}{Equals GYRATE_CV = 0 if the radius of gyration is identical @@ -50,15 +56,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_c_gyrate_cv <- function(landscape, directions) UseMethod("lsm_c_gyrate_cv") +lsm_c_gyrate_cv <- function(landscape, directions, cell_center) UseMethod("lsm_c_gyrate_cv") #' @name lsm_c_gyrate_cv #' @export -lsm_c_gyrate_cv.RasterLayer <- function(landscape, directions = 8) { +lsm_c_gyrate_cv.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -70,11 +78,13 @@ lsm_c_gyrate_cv.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_cv #' @export -lsm_c_gyrate_cv.RasterStack <- function(landscape, directions = 8) { +lsm_c_gyrate_cv.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -86,11 +96,13 @@ lsm_c_gyrate_cv.RasterStack <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_cv #' @export -lsm_c_gyrate_cv.RasterBrick <- function(landscape, directions = 8) { +lsm_c_gyrate_cv.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -102,13 +114,15 @@ lsm_c_gyrate_cv.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_cv #' @export -lsm_c_gyrate_cv.stars <- function(landscape, directions = 8) { +lsm_c_gyrate_cv.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -120,11 +134,13 @@ lsm_c_gyrate_cv.stars <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_cv #' @export -lsm_c_gyrate_cv.list <- function(landscape, directions = 8) { +lsm_c_gyrate_cv.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_c_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -134,11 +150,12 @@ lsm_c_gyrate_cv.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_cv_calc <- function(landscape, directions, +lsm_c_gyrate_cv_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all cells are NA @@ -150,7 +167,8 @@ lsm_c_gyrate_cv_calc <- function(landscape, directions, value = as.double(NA))) } - gyrate_cv <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], FUN = raster::cv) + gyrate_cv <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], + FUN = raster::cv) return(tibble::tibble(level = "class", class = as.integer(gyrate_cv$class), diff --git a/R/lsm_c_gyrate_mn.R b/R/lsm_c_gyrate_mn.R index fbb89fbe9..62d82cc39 100644 --- a/R/lsm_c_gyrate_mn.R +++ b/R/lsm_c_gyrate_mn.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{MN} = mean(GYRATE[patch_{ij}])} @@ -14,8 +16,11 @@ #' as the mean of the radius of gyration of all patches belonging to class i. #' GYRATE measures the distance from each cell to the patch centroid and is based on #' cell center-to-cell center distances. The metrics characterises -#' both the patch area and compactness. The Coefficient of variation is -#' scaled to the mean and comparable among different landscapes. +#' both the patch area and compactness. +#' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. #' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_MN >= 0 } @@ -49,15 +54,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_c_gyrate_mn <- function(landscape, directions) UseMethod("lsm_c_gyrate_mn") +lsm_c_gyrate_mn <- function(landscape, directions, cell_center) UseMethod("lsm_c_gyrate_mn") #' @name lsm_c_gyrate_mn #' @export -lsm_c_gyrate_mn.RasterLayer <- function(landscape, directions = 8) { +lsm_c_gyrate_mn.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -69,11 +76,13 @@ lsm_c_gyrate_mn.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_mn #' @export -lsm_c_gyrate_mn.RasterStack <- function(landscape, directions = 8) { +lsm_c_gyrate_mn.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -85,11 +94,13 @@ lsm_c_gyrate_mn.RasterStack <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_mn #' @export -lsm_c_gyrate_mn.RasterBrick <- function(landscape, directions = 8) { +lsm_c_gyrate_mn.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -101,13 +112,15 @@ lsm_c_gyrate_mn.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_mn #' @export -lsm_c_gyrate_mn.stars <- function(landscape, directions = 8) { +lsm_c_gyrate_mn.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -119,11 +132,13 @@ lsm_c_gyrate_mn.stars <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_mn #' @export -lsm_c_gyrate_mn.list <- function(landscape, directions = 8) { +lsm_c_gyrate_mn.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_c_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -133,11 +148,12 @@ lsm_c_gyrate_mn.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_mn_calc <- function(landscape, directions, +lsm_c_gyrate_mn_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all cells are NA diff --git a/R/lsm_c_gyrate_sd.R b/R/lsm_c_gyrate_sd.R index bd3eb0132..99952e117 100644 --- a/R/lsm_c_gyrate_sd.R +++ b/R/lsm_c_gyrate_sd.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{SD} = sd(GYRATE[patch_{ij}])} @@ -16,6 +18,10 @@ #' centroid and is based on cell center-to-cell center distances. The metrics characterises #' both the patch area and compactness. #' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. +#' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_SD >= 0 } #' \subsection{Behaviour}{Equals GYRATE_SD = 0 if the radius of gyration is identical @@ -49,15 +55,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_c_gyrate_sd <- function(landscape, directions) UseMethod("lsm_c_gyrate_sd") +lsm_c_gyrate_sd <- function(landscape, directions, cell_center) UseMethod("lsm_c_gyrate_sd") #' @name lsm_c_gyrate_sd #' @export -lsm_c_gyrate_sd.RasterLayer <- function(landscape, directions = 8) { +lsm_c_gyrate_sd.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -69,11 +77,13 @@ lsm_c_gyrate_sd.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_sd #' @export -lsm_c_gyrate_sd.RasterStack <- function(landscape, directions = 8) { +lsm_c_gyrate_sd.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -85,11 +95,13 @@ lsm_c_gyrate_sd.RasterStack <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_sd #' @export -lsm_c_gyrate_sd.RasterBrick <- function(landscape, directions = 8) { +lsm_c_gyrate_sd.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -101,13 +113,15 @@ lsm_c_gyrate_sd.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_sd #' @export -lsm_c_gyrate_sd.stars <- function(landscape, directions = 8) { +lsm_c_gyrate_sd.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_c_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -119,11 +133,13 @@ lsm_c_gyrate_sd.stars <- function(landscape, directions = 8) { #' @name lsm_c_gyrate_sd #' @export -lsm_c_gyrate_sd.list <- function(landscape, directions = 8) { +lsm_c_gyrate_sd.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_c_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -133,11 +149,12 @@ lsm_c_gyrate_sd.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_c_gyrate_sd_calc <- function(landscape, directions, +lsm_c_gyrate_sd_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all cells are NA @@ -149,7 +166,8 @@ lsm_c_gyrate_sd_calc <- function(landscape, directions, value = as.double(NA))) } - gyrate_sd <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], FUN = stats::sd) + gyrate_sd <- stats::aggregate(x = gyrate[, 5], by = gyrate[, 2], + FUN = stats::sd) return(tibble::tibble(level = "class", class = as.integer(gyrate_sd$class), diff --git a/R/lsm_l_gyrate_cv.R b/R/lsm_l_gyrate_cv.R index 11d9623f0..2eade7382 100644 --- a/R/lsm_l_gyrate_cv.R +++ b/R/lsm_l_gyrate_cv.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{CV} = cv(GYRATE[patch_{ij}])} @@ -17,6 +19,10 @@ #' both the patch area and compactness. The Coefficient of variation is #' scaled to the mean and comparable among different landscapes. #' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. +#' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_CV >= 0 } #' \subsection{Behaviour}{Equals GYRATE_CV = 0 if the radius of gyration is identical @@ -50,15 +56,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_l_gyrate_cv <- function(landscape, directions) UseMethod("lsm_l_gyrate_cv") +lsm_l_gyrate_cv <- function(landscape, directions, cell_center) UseMethod("lsm_l_gyrate_cv") #' @name lsm_l_gyrate_cv #' @export -lsm_l_gyrate_cv.RasterLayer <- function(landscape, directions = 8) { +lsm_l_gyrate_cv.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -70,11 +78,13 @@ lsm_l_gyrate_cv.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_cv #' @export -lsm_l_gyrate_cv.RasterStack <- function(landscape, directions = 8) { +lsm_l_gyrate_cv.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -86,11 +96,13 @@ lsm_l_gyrate_cv.RasterStack <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_cv #' @export -lsm_l_gyrate_cv.RasterBrick <- function(landscape, directions = 8) { +lsm_l_gyrate_cv.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -102,13 +114,15 @@ lsm_l_gyrate_cv.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_cv #' @export -lsm_l_gyrate_cv.stars <- function(landscape, directions = 8) { +lsm_l_gyrate_cv.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -120,11 +134,13 @@ lsm_l_gyrate_cv.stars <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_cv #' @export -lsm_l_gyrate_cv.list <- function(landscape, directions = 8) { +lsm_l_gyrate_cv.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_l_gyrate_cv_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -134,11 +150,12 @@ lsm_l_gyrate_cv.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_cv_calc <- function(landscape, directions, +lsm_l_gyrate_cv_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all values NA diff --git a/R/lsm_l_gyrate_mn.R b/R/lsm_l_gyrate_mn.R index 236e08a45..1639f5b26 100644 --- a/R/lsm_l_gyrate_mn.R +++ b/R/lsm_l_gyrate_mn.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{MN} = mean(GYRATE[patch_{ij}])} @@ -14,8 +16,11 @@ #' as the mean of the radius of gyration of all patches in the landscape. #' GYRATE measures the distance from each cell to the patch centroid and is based on #' cell center-to-cell center distances. The metrics characterises -#' both the patch area and compactness. The Coefficient of variation is -#' scaled to the mean and comparable among different landscapes. +#' both the patch area and compactness. +#' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. #' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_MN >= 0 } @@ -49,15 +54,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_l_gyrate_mn <- function(landscape, directions) UseMethod("lsm_l_gyrate_mn") +lsm_l_gyrate_mn <- function(landscape, directions, cell_center) UseMethod("lsm_l_gyrate_mn") #' @name lsm_l_gyrate_mn #' @export -lsm_l_gyrate_mn.RasterLayer <- function(landscape, directions = 8) { +lsm_l_gyrate_mn.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -69,11 +76,13 @@ lsm_l_gyrate_mn.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_mn #' @export -lsm_l_gyrate_mn.RasterStack <- function(landscape, directions = 8) { +lsm_l_gyrate_mn.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -85,11 +94,13 @@ lsm_l_gyrate_mn.RasterStack <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_mn #' @export -lsm_l_gyrate_mn.RasterBrick <- function(landscape, directions = 8) { +lsm_l_gyrate_mn.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -101,13 +112,15 @@ lsm_l_gyrate_mn.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_mn #' @export -lsm_l_gyrate_mn.stars <- function(landscape, directions = 8) { +lsm_l_gyrate_mn.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -119,11 +132,13 @@ lsm_l_gyrate_mn.stars <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_mn #' @export -lsm_l_gyrate_mn.list <- function(landscape, directions = 8) { +lsm_l_gyrate_mn.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_l_gyrate_mn_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -133,11 +148,12 @@ lsm_l_gyrate_mn.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_mn_calc <- function(landscape, directions, +lsm_l_gyrate_mn_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all values NA diff --git a/R/lsm_l_gyrate_sd.R b/R/lsm_l_gyrate_sd.R index 5d817f317..ea650925b 100644 --- a/R/lsm_l_gyrate_sd.R +++ b/R/lsm_l_gyrate_sd.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE_{SD} = sd(GYRATE[patch_{ij}])} @@ -16,6 +18,10 @@ #' centroid and is based on cell center-to-cell center distances. The metrics characterises #' both the patch area and compactness. #' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. +#' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE_SD >= 0 } #' \subsection{Behaviour}{Equals GYRATE_SD = 0 if the radius of gyration is identical @@ -49,15 +55,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_l_gyrate_sd <- function(landscape, directions) UseMethod("lsm_l_gyrate_sd") +lsm_l_gyrate_sd <- function(landscape, directions, cell_center) UseMethod("lsm_l_gyrate_sd") #' @name lsm_l_gyrate_sd #' @export -lsm_l_gyrate_sd.RasterLayer <- function(landscape, directions = 8) { +lsm_l_gyrate_sd.RasterLayer <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -69,11 +77,13 @@ lsm_l_gyrate_sd.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_sd #' @export -lsm_l_gyrate_sd.RasterStack <- function(landscape, directions = 8) { +lsm_l_gyrate_sd.RasterStack <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -85,11 +95,13 @@ lsm_l_gyrate_sd.RasterStack <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_sd #' @export -lsm_l_gyrate_sd.RasterBrick <- function(landscape, directions = 8) { +lsm_l_gyrate_sd.RasterBrick <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -101,13 +113,15 @@ lsm_l_gyrate_sd.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_sd #' @export -lsm_l_gyrate_sd.stars <- function(landscape, directions = 8) { +lsm_l_gyrate_sd.stars <- function(landscape, + directions = 8, cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_l_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -119,11 +133,13 @@ lsm_l_gyrate_sd.stars <- function(landscape, directions = 8) { #' @name lsm_l_gyrate_sd #' @export -lsm_l_gyrate_sd.list <- function(landscape, directions = 8) { +lsm_l_gyrate_sd.list <- function(landscape, + directions = 8, cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_l_gyrate_sd_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -133,11 +149,12 @@ lsm_l_gyrate_sd.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_l_gyrate_sd_calc <- function(landscape, directions, +lsm_l_gyrate_sd_calc <- function(landscape, directions, cell_center, points = NULL) { gyrate_patch <- lsm_p_gyrate_calc(landscape, directions = directions, + cell_center = cell_center, points = points) # all values NA diff --git a/R/lsm_p_core.R b/R/lsm_p_core.R index 7c5616e72..8d7bfb86e 100644 --- a/R/lsm_p_core.R +++ b/R/lsm_p_core.R @@ -176,54 +176,36 @@ lsm_p_core_calc <- function(landscape, directions, consider_boundary, edge_depth core <- do.call(rbind, lapply(classes, function(patches_class) { - # get connected patches - landscape_labeled <- get_patches(landscape, - class = patches_class, - directions = directions, - return_raster = FALSE)[[1]] - - # label all edge cells - class_edge <- get_boundaries(landscape_labeled, - directions = 4, - consider_boundary = consider_boundary)[[1]] - - # count number of edge cells in each patch (edge == 1) - cells_edge_patch <- table(landscape_labeled[class_edge == 1]) - - # loop if edge_depth > 1 - if (edge_depth > 1) { - - # first edge depth already labels - for (i in seq_len(edge_depth - 1)) { - - # set all already edge to NA - class_edge[class_edge == 1] <- NA - - # set current_edge + 1 to new edge - class_edge <- get_boundaries(class_edge, - directions = 4, - consider_boundary = consider_boundary)[[1]] - - # count number of edge cells in each patch (edge == 1) and add to already counted edge - cells_edge_patch <- cells_edge_patch + tabulate(landscape_labeled[class_edge == 1], - nbins = length(cells_edge_patch)) - } - } - - # all cells of the patch - cells_patch <- table(landscape_labeled) - - # check if no cell is edge, i.e. only one patch is present - if (dim(cells_edge_patch) == 0) { - cells_edge_patch <- 0 - } - - # 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) - }) + # get connected patches + landscape_labeled <- get_patches(landscape, + class = patches_class, + directions = directions, + return_raster = FALSE)[[1]] + + # label all edge cells + class_edge <- get_boundaries_calc(landscape_labeled, + edge_depth = edge_depth, + consider_boundary = consider_boundary, + as_NA = FALSE, + 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) + + # check if no cell is edge, i.e. only one patch is present + if (dim(cells_edge_patch) == 0) { + cells_edge_patch <- 0 + } + + # 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::tibble( diff --git a/R/lsm_p_enn.R b/R/lsm_p_enn.R index a03c72a64..68ebc561e 100644 --- a/R/lsm_p_enn.R +++ b/R/lsm_p_enn.R @@ -143,7 +143,7 @@ lsm_p_enn.list <- function(landscape, directions = 8, verbose = TRUE) { lsm_p_enn_calc <- function(landscape, directions, verbose, points = NULL) { - # conver to matrix + # convert to matrix if (!inherits(x = landscape, what = "matrix")) { # get coordinates and values of all cells @@ -168,69 +168,38 @@ lsm_p_enn_calc <- function(landscape, directions, verbose, enn_patch <- do.call(rbind, lapply(classes, function(patches_class) { - # get connected patches - landscape_labeled <- get_patches(landscape, - class = patches_class, - directions = directions, - return_raster = FALSE)[[1]] + # get connected patches + landscape_labeled <- get_patches(landscape, + class = patches_class, + directions = directions, + return_raster = FALSE)[[1]] - # get number of patches - np_class <- max(landscape_labeled, na.rm = TRUE) + # 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 doesn't make sense if only one patch is present + if (np_class == 1) { - enn <- tibble::tibble(class = patches_class, - dist = as.double(NA)) + 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) - } - } + if (verbose) { + warning(paste0("Class ", patches_class, + ": ENN = NA for class with only 1 patch."), + call. = FALSE) + } + } - else { + else { - # get edge cells because only they are important for ENN - class_boundaries <- get_boundaries(landscape_labeled, - directions = 4, - as_NA = TRUE)[[1]] + enn <- get_nearestneighbour_calc(landscape = landscape_labeled, + return_id = FALSE, + points = points) + } - # set edge cell value to patch id - class_boundaries[!is.na(class_boundaries)] <- landscape_labeled[!is.na(class_boundaries)] - - # transpose to get same direction of ID - class_boundaries <- t(class_boundaries) - - # get coordinates of current class - points <- points[which(!is.na(class_boundaries)), ] - - # set ID from class ID to unique patch ID - points[, 3] <- class_boundaries[!is.na(class_boundaries)] - - # order points - ord <- order(as.matrix(points)[, 1]) - num <- seq_along(ord) - rank <- match(num, ord) - - # get nearest neighbor between patches - res <- rcpp_get_nearest_neighbor(as.matrix(points)[ord,]) - - # order results - min_dist <- unname(cbind(num, res[rank], as.matrix(points)[, 3])) - - tbl <- tibble::tibble(cell = min_dist[,1], - dist = min_dist[,2], - id = min_dist[,3]) - - # only get minimum value for each patch - enn <- stats::aggregate(x = tbl[, 2], by = tbl[, 3], FUN = min) - } - - tibble::tibble(class = patches_class, - value = enn$dist) - }) + tibble::tibble(class = patches_class, + value = enn$dist) + }) ) tibble::tibble(level = "patch", diff --git a/R/lsm_p_gyrate.R b/R/lsm_p_gyrate.R index 0dd5f172c..7455bf4cd 100644 --- a/R/lsm_p_gyrate.R +++ b/R/lsm_p_gyrate.R @@ -5,6 +5,8 @@ #' @param landscape Raster* Layer, Stack, Brick or a list of rasterLayers. #' @param directions The number of directions in which patches should be #' connected: 4 (rook's case) or 8 (queen's case). +#' @param cell_center If true, the coordinates of the centroid are forced to be +#' a cell center within the patch. #' #' @details #' \deqn{GYRATE = \sum \limits_{r = 1}^{z} \frac{h_{ijr}} {z}} @@ -12,10 +14,13 @@ #' patch and \eqn{z} is the number of cells. #' #' GYRATE is an 'Area and edge metric'. The distance from each cell to the -#' patch -#' centroid is based on cell center-to-cell center distances. The metrics +#' patch centroid is based on cell center to centroid distances. The metric #' characterises both the patch area and compactness. #' +#' If `cell_center = TRUE` some patches might have several possible cell-center +#' centroids. In this case, the gyrate index is based on the mean distance of all +#' cells to all possible cell-center centroids. +#' #' \subsection{Units}{Meters} #' \subsection{Range}{GYRATE >= 0} #' \subsection{Behaviour}{Approaches GYRATE = 0 if patch is a single cell. @@ -46,15 +51,17 @@ #' in fragmented landscapes. Conservation ecology, 1(1). #' #' @export -lsm_p_gyrate <- function(landscape, directions) UseMethod("lsm_p_gyrate") +lsm_p_gyrate <- function(landscape, directions, cell_center) UseMethod("lsm_p_gyrate") #' @name lsm_p_gyrate #' @export -lsm_p_gyrate.RasterLayer <- function(landscape, directions = 8) { +lsm_p_gyrate.RasterLayer <- function(landscape, directions = 8, + cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_p_gyrate_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -66,11 +73,13 @@ lsm_p_gyrate.RasterLayer <- function(landscape, directions = 8) { #' @name lsm_p_gyrate #' @export -lsm_p_gyrate.RasterStack <- function(landscape, directions = 8) { +lsm_p_gyrate.RasterStack <- function(landscape, directions = 8, + cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_p_gyrate_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -82,11 +91,13 @@ lsm_p_gyrate.RasterStack <- function(landscape, directions = 8) { #' @name lsm_p_gyrate #' @export -lsm_p_gyrate.RasterBrick <- function(landscape, directions = 8) { +lsm_p_gyrate.RasterBrick <- function(landscape, directions = 8, + cell_center = FALSE) { result <- lapply(X = raster::as.list(landscape), FUN = lsm_p_gyrate_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -98,14 +109,16 @@ lsm_p_gyrate.RasterBrick <- function(landscape, directions = 8) { #' @name lsm_p_gyrate #' @export -lsm_p_gyrate.stars <- function(landscape, directions = 8) { +lsm_p_gyrate.stars <- function(landscape, directions = 8, + cell_center = FALSE) { landscape <- methods::as(landscape, "Raster") result <- lapply(X = raster::as.list(landscape), FUN = lsm_p_gyrate_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -117,11 +130,13 @@ lsm_p_gyrate.stars <- function(landscape, directions = 8) { #' @name lsm_p_gyrate #' @export -lsm_p_gyrate.list <- function(landscape, directions = 8) { +lsm_p_gyrate.list <- function(landscape, directions = 8, + cell_center = FALSE) { result <- lapply(X = landscape, FUN = lsm_p_gyrate_calc, - directions = directions) + directions = directions, + cell_center = cell_center) layer <- rep(seq_along(result), vapply(result, nrow, FUN.VALUE = integer(1))) @@ -131,7 +146,7 @@ lsm_p_gyrate.list <- function(landscape, directions = 8) { tibble::add_column(result, layer, .before = TRUE) } -lsm_p_gyrate_calc <- function(landscape, directions, +lsm_p_gyrate_calc <- function(landscape, directions, cell_center, points = NULL) { # conver to matrix @@ -175,30 +190,49 @@ lsm_p_gyrate_calc <- function(landscape, directions, # set ID from class ID to unique patch ID points[, 3] <- landscape_labeled[!is.na(landscape_labeled)] - # conver to tibble -> do we still need to do this? - points <- tibble::as_tibble(points) - names(points) <- c("x", "y", "id") + # # conver to tibble + points <- stats::setNames(object = data.frame(points), + nm = c("x", "y", "id")) # calcuale the centroid of each patch (mean of all coords) centroid <- stats::aggregate(points[, c(1, 2)], - by = list(id = points$id), + by = list(id = points[, 3]), FUN = mean) # create full data set with raster-points and patch centroids - full_data <- tibble::as_tibble(merge(x = points, y = centroid, by = "id", - suffixes = c("","_centroid"))) + full_data <- merge(x = points, y = centroid, by = "id", + suffixes = c("","_centroid")) # calculate distance from each cell center to centroid full_data$dist <- sqrt((full_data$x - full_data$x_centroid) ^ 2 + (full_data$y - full_data$y_centroid) ^ 2) + # force centroid to be within patch + if (cell_center) { + + # which cell has the shortest distance to centroid + 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)] + + # create full data set with raster-points and patch centroids + full_data <- merge(x = points, y = centroid, by = "id", + suffixes = c("","_centroid")) + + # calculate distance from each cell center to centroid + full_data$dist <- sqrt((full_data$x - full_data$x_centroid) ^ 2 + + (full_data$y - full_data$y_centroid) ^ 2) + } + # mean distance for each patch - gyrate_class <- stats::aggregate(x = full_data[, 6], - by = full_data[, 1], - FUN = mean) + gyrate_class <- stats::setNames(stats::aggregate(x = full_data[, 6], + by = list(full_data[, 1]), + FUN = mean), + nm = c("id", "dist")) - tibble::tibble(class = as.integer(patches_class), - value = as.double(gyrate_class$dist)) + data.frame(class = as.integer(patches_class), + value = as.double(gyrate_class$dist)) }) ) diff --git a/R/lsm_p_ncore.R b/R/lsm_p_ncore.R index 67b4d33a0..045df9170 100644 --- a/R/lsm_p_ncore.R +++ b/R/lsm_p_ncore.R @@ -203,24 +203,11 @@ lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_dept patches_id <- 1:max(landscape_labeled, na.rm = TRUE) # label all edge cells - class_edge <- get_boundaries(landscape_labeled, - directions = 4, - consider_boundary = consider_boundary)[[1]] - - # loop if edge_depth is more than 1 - if (edge_depth > 1) { - - for (i in seq_len(edge_depth - 1)) { - - # set all already edge to NA - class_edge[class_edge == 1] <- NA - - # set current_edge + 1 to new edge - class_edge <- get_boundaries(class_edge, - directions = 4, - consider_boundary = consider_boundary)[[1]] - } - } + class_edge <- get_boundaries_calc(landscape_labeled, + edge_depth = edge_depth, + consider_boundary = consider_boundary, + as_NA = FALSE, + patch_id = FALSE) # set all edge and background to -999 class_edge[class_edge == 1 | is.na(class_edge)] <- -999 @@ -264,7 +251,7 @@ lsm_p_ncore_calc <- function(landscape, directions, consider_boundary, edge_dept n_core_area <- table(unique(points[, c(4, 5)])[, 2]) # sth breaking here - # set up results samel length as number of patches (in case patch has no core) + # set up results same length as number of patches (in case patch has no core) result <- c(rep(0, length(patches_id))) names(result) <- patches_id diff --git a/R/show_cores.R b/R/show_cores.R index 89e7f0113..ee833d7b0 100644 --- a/R/show_cores.R +++ b/R/show_cores.R @@ -201,7 +201,6 @@ show_cores_internal <- function(landscape, directions, class, labels, nrow, ncol # } class_edge <- get_boundaries(patches_class, - directions = 4, consider_boundary = consider_boundary)[[1]] full_edge <- class_edge @@ -213,7 +212,6 @@ show_cores_internal <- function(landscape, directions, class, labels, nrow, ncol raster::values(class_edge)[raster::values(class_edge) == 1] <- NA class_edge <- get_boundaries(class_edge, - directions = 4, consider_boundary)[[1]] full_edge[which(class_edge[] == 1)] <- 1 diff --git a/cran-comments.md b/cran-comments.md index 34992c4c1..4ef98eee7 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,3 +1,6 @@ +# landscapemetrics 1.4.5 +Minor improvments, bug fixes and new functions + # landscapemetrics 1.4.4 Minor improvments and bug fixes diff --git a/man/calculate_lsm.Rd b/man/calculate_lsm.Rd index 53d457302..34ab908e2 100644 --- a/man/calculate_lsm.Rd +++ b/man/calculate_lsm.Rd @@ -20,6 +20,7 @@ calculate_lsm( count_boundary, consider_boundary, edge_depth, + cell_center, classes_max, neighbourhood, ordered, @@ -40,6 +41,7 @@ calculate_lsm( count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -60,6 +62,7 @@ calculate_lsm( count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -80,6 +83,7 @@ calculate_lsm( count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -100,6 +104,7 @@ calculate_lsm( count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -120,6 +125,7 @@ calculate_lsm( count_boundary = FALSE, consider_boundary = FALSE, edge_depth = 1, + cell_center = FALSE, classes_max = NULL, neighbourhood = 4, ordered = TRUE, @@ -136,7 +142,7 @@ calculate_lsm( \item{metric}{Abbreviation of metrics (e.g. 'area').} -\item{name}{Full name of metrics (e.g. 'core area')} +\item{name}{Full name of metrics (e.g. 'core area').} \item{type}{Type according to FRAGSTATS grouping (e.g. 'aggregation metrics').} @@ -146,15 +152,18 @@ It is also possible to specify functions as a vector of strings, e.g. \code{what \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} -\item{count_boundary}{Include landscape boundary in edge length} +\item{count_boundary}{Include landscape boundary in edge length.} \item{consider_boundary}{Logical if cells that only neighbour the landscape -boundary should be considered as core} +boundary should be considered as core.} \item{edge_depth}{Distance (in cells) a cell has the be away from the patch -edge to be considered as core cell} +edge to be considered as core cell.} -\item{classes_max}{Potential maximum number of present classes} +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} + +\item{classes_max}{Potential maximum number of present classes.} \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.} diff --git a/man/get_boundaries.Rd b/man/get_boundaries.Rd index 1d48fdaa1..c114fe2cf 100644 --- a/man/get_boundaries.Rd +++ b/man/get_boundaries.Rd @@ -7,70 +7,79 @@ \alias{get_boundaries.RasterBrick} \alias{get_boundaries.stars} \alias{get_boundaries.list} -\alias{get_boundaries.matrix} +\alias{get_boundaries_calc} \title{get_boundaries} \usage{ -get_boundaries(landscape, directions, as_NA, consider_boundary, return_raster) +get_boundaries( + landscape, + consider_boundary, + edge_depth, + as_NA, + patch_id, + return_raster +) \method{get_boundaries}{RasterLayer}( landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE ) \method{get_boundaries}{RasterStack}( landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE ) \method{get_boundaries}{RasterBrick}( landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE ) \method{get_boundaries}{stars}( landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE ) \method{get_boundaries}{list}( landscape, - directions = 4, - as_NA = FALSE, consider_boundary = FALSE, + edge_depth = 1, + as_NA = FALSE, + patch_id = FALSE, return_raster = TRUE ) -\method{get_boundaries}{matrix}( - landscape, - directions = 4, - as_NA = FALSE, - consider_boundary = FALSE, - return_raster = FALSE -) +get_boundaries_calc(landscape, consider_boundary, edge_depth, as_NA, patch_id) } \arguments{ \item{landscape}{RasterLayer or matrix.} -\item{directions}{Rook's case (4 neighbours) or queen's case (8 neighbours) should be used as neighbourhood rule} +\item{consider_boundary}{Logical if cells that only neighbour the landscape +boundary should be considered as edge.} -\item{as_NA}{If true, non-boundary cells area labeld NA} +\item{edge_depth}{Distance (in cells) a cell has the be away from the patch +edge to be considered as core cell.} -\item{consider_boundary}{Logical if cells that only neighbour the landscape -boundary should be considered as edge} +\item{as_NA}{If true, non-boundary cells area labeld NA.} -\item{return_raster}{If false, matrix is returned} +\item{patch_id}{If true, boundary/edge cells are labeled with the original patch id.} + +\item{return_raster}{If false, matrix is returned.} } \value{ List with RasterLayer or matrix @@ -90,7 +99,4 @@ class_1 <- get_patches(landscape, class = 1)[[1]] get_boundaries(class_1) get_boundaries(class_1, return_raster = FALSE) -class_1_matrix <- raster::as.matrix(class_1) -get_boundaries(class_1_matrix, return_raster = FALSE) - } diff --git a/man/get_centroids.Rd b/man/get_centroids.Rd new file mode 100644 index 000000000..9e494fa9e --- /dev/null +++ b/man/get_centroids.Rd @@ -0,0 +1,80 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/get_centroids.R +\name{get_centroids} +\alias{get_centroids} +\alias{get_centroids.RasterLayer} +\alias{get_centroids.RasterStack} +\alias{get_centroids.RasterBrick} +\alias{get_centroids.stars} +\alias{get_centroids.list} +\title{get_centroids} +\usage{ +get_centroids(landscape, directions, cell_center, return_sp, verbose) + +\method{get_centroids}{RasterLayer}( + landscape, + directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE +) + +\method{get_centroids}{RasterStack}( + landscape, + directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE +) + +\method{get_centroids}{RasterBrick}( + landscape, + directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE +) + +\method{get_centroids}{stars}( + landscape, + directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE +) + +\method{get_centroids}{list}( + landscape, + directions = 8, + cell_center = FALSE, + return_sp = FALSE, + verbose = TRUE +) +} +\arguments{ +\item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} + +\item{directions}{The number of directions in which patches should be +connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} + +\item{return_sp}{If true, a SpatialPointsDataFrame is returned.} + +\item{verbose}{Print warning messages} +} +\description{ +Centroid of patches +} +\details{ +Get the coordinates of the centroid of each patch. The centroid is by default +defined as the mean location of all cell centers. To force the centroid to be +located within each patch, use the \code{cell_center} argument. In this case, the +centroid is defined as the cell center that is the closest to the mean location. +} +\examples{ +# get centroid location +get_centroids(landscape) + +} diff --git a/man/get_nearestneighbour.Rd b/man/get_nearestneighbour.Rd index 438d1178e..9792b793c 100644 --- a/man/get_nearestneighbour.Rd +++ b/man/get_nearestneighbour.Rd @@ -7,44 +7,43 @@ \alias{get_nearestneighbour.RasterBrick} \alias{get_nearestneighbour.stars} \alias{get_nearestneighbour.list} -\alias{get_nearestneighbour.matrix} \title{get_nearestneighbour} \usage{ -get_nearestneighbour(landscape) +get_nearestneighbour(landscape, return_id) -\method{get_nearestneighbour}{RasterLayer}(landscape) +\method{get_nearestneighbour}{RasterLayer}(landscape, return_id = FALSE) -\method{get_nearestneighbour}{RasterStack}(landscape) +\method{get_nearestneighbour}{RasterStack}(landscape, return_id = FALSE) -\method{get_nearestneighbour}{RasterBrick}(landscape) +\method{get_nearestneighbour}{RasterBrick}(landscape, return_id = FALSE) -\method{get_nearestneighbour}{stars}(landscape) +\method{get_nearestneighbour}{stars}(landscape, return_id = FALSE) -\method{get_nearestneighbour}{list}(landscape) - -\method{get_nearestneighbour}{matrix}(landscape) +\method{get_nearestneighbour}{list}(landscape, return_id = FALSE) } \arguments{ -\item{landscape}{RasterLayer or matrix (with x,y,id columns)} +\item{landscape}{RasterLayer or matrix (with x,y,id columns).} + +\item{return_id}{If TRUE, also the patch ID of the nearest neighbour is returned.} } \description{ Euclidean distance to nearest neighbour } \details{ Fast and memory safe Rcpp implementation for calculating the minimum Euclidean -distances to the nearest patch of the same class in a raster or matrix. All patches need an unique -ID (see \code{\link{get_patches}}). +distances to the nearest patch of the same class in a raster or matrix. +All patches need an unique ID (see \code{\link{get_patches}}). Please be aware +that the patch ID is not identical to the patch ID of all metric functions (lsm_). +If \code{return_ID = TRUE}, for some focal patches several nearest neighbour patches +might be returned. } \examples{ -# get patches for class 1 from testdata as raster -class_1 <- get_patches(landscape,1)[[1]] +# get patches for class 1 +class_1 <- get_patches(landscape, class = 2)[[1]] # calculate the distance between patches get_nearestneighbour(class_1) - -# do the same with a 3 column matrix (x, y, id) -class_1_matrix <- raster::rasterToPoints(class_1) -get_nearestneighbour(class_1_matrix) +get_nearestneighbour(class_1, return_id = TRUE) } \references{ diff --git a/man/lsm_c_gyrate_cv.Rd b/man/lsm_c_gyrate_cv.Rd index b39e4162c..4d5c78d96 100644 --- a/man/lsm_c_gyrate_cv.Rd +++ b/man/lsm_c_gyrate_cv.Rd @@ -9,23 +9,26 @@ \alias{lsm_c_gyrate_cv.list} \title{GYRATE_CV (class level)} \usage{ -lsm_c_gyrate_cv(landscape, directions) +lsm_c_gyrate_cv(landscape, directions, cell_center) -\method{lsm_c_gyrate_cv}{RasterLayer}(landscape, directions = 8) +\method{lsm_c_gyrate_cv}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_cv}{RasterStack}(landscape, directions = 8) +\method{lsm_c_gyrate_cv}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_cv}{RasterBrick}(landscape, directions = 8) +\method{lsm_c_gyrate_cv}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_cv}{stars}(landscape, directions = 8) +\method{lsm_c_gyrate_cv}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_cv}{list}(landscape, directions = 8) +\method{lsm_c_gyrate_cv}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -44,6 +47,10 @@ centroid and is based on cell center-to-cell center distances. The metrics chara both the patch area and compactness. The Coefficient of variation is scaled to the mean and comparable among different landscapes. +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. + \subsection{Units}{Meters} \subsection{Range}{GYRATE_CV >= 0 } \subsection{Behaviour}{Equals GYRATE_CV = 0 if the radius of gyration is identical diff --git a/man/lsm_c_gyrate_mn.Rd b/man/lsm_c_gyrate_mn.Rd index b81feeacf..2bedd4185 100644 --- a/man/lsm_c_gyrate_mn.Rd +++ b/man/lsm_c_gyrate_mn.Rd @@ -9,23 +9,26 @@ \alias{lsm_c_gyrate_mn.list} \title{GYRATE_MN (class level)} \usage{ -lsm_c_gyrate_mn(landscape, directions) +lsm_c_gyrate_mn(landscape, directions, cell_center) -\method{lsm_c_gyrate_mn}{RasterLayer}(landscape, directions = 8) +\method{lsm_c_gyrate_mn}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_mn}{RasterStack}(landscape, directions = 8) +\method{lsm_c_gyrate_mn}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_mn}{RasterBrick}(landscape, directions = 8) +\method{lsm_c_gyrate_mn}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_mn}{stars}(landscape, directions = 8) +\method{lsm_c_gyrate_mn}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_mn}{list}(landscape, directions = 8) +\method{lsm_c_gyrate_mn}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -41,8 +44,11 @@ GYRATE_MN is an 'Area and edge metric'. The metric summarises each class as the mean of the radius of gyration of all patches belonging to class i. GYRATE measures the distance from each cell to the patch centroid and is based on cell center-to-cell center distances. The metrics characterises -both the patch area and compactness. The Coefficient of variation is -scaled to the mean and comparable among different landscapes. +both the patch area and compactness. + +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. \subsection{Units}{Meters} \subsection{Range}{GYRATE_MN >= 0 } diff --git a/man/lsm_c_gyrate_sd.Rd b/man/lsm_c_gyrate_sd.Rd index 7e21b9f84..4d4bae801 100644 --- a/man/lsm_c_gyrate_sd.Rd +++ b/man/lsm_c_gyrate_sd.Rd @@ -9,23 +9,26 @@ \alias{lsm_c_gyrate_sd.list} \title{GYRATE_SD (class level)} \usage{ -lsm_c_gyrate_sd(landscape, directions) +lsm_c_gyrate_sd(landscape, directions, cell_center) -\method{lsm_c_gyrate_sd}{RasterLayer}(landscape, directions = 8) +\method{lsm_c_gyrate_sd}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_sd}{RasterStack}(landscape, directions = 8) +\method{lsm_c_gyrate_sd}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_sd}{RasterBrick}(landscape, directions = 8) +\method{lsm_c_gyrate_sd}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_sd}{stars}(landscape, directions = 8) +\method{lsm_c_gyrate_sd}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_c_gyrate_sd}{list}(landscape, directions = 8) +\method{lsm_c_gyrate_sd}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -43,6 +46,10 @@ belonging to class i. GYRATE measures the distance from each cell to the patch centroid and is based on cell center-to-cell center distances. The metrics characterises both the patch area and compactness. +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. + \subsection{Units}{Meters} \subsection{Range}{GYRATE_SD >= 0 } \subsection{Behaviour}{Equals GYRATE_SD = 0 if the radius of gyration is identical diff --git a/man/lsm_l_gyrate_cv.Rd b/man/lsm_l_gyrate_cv.Rd index 8856f1b83..29570d317 100644 --- a/man/lsm_l_gyrate_cv.Rd +++ b/man/lsm_l_gyrate_cv.Rd @@ -9,23 +9,26 @@ \alias{lsm_l_gyrate_cv.list} \title{GYRATE_CV (landscape level)} \usage{ -lsm_l_gyrate_cv(landscape, directions) +lsm_l_gyrate_cv(landscape, directions, cell_center) -\method{lsm_l_gyrate_cv}{RasterLayer}(landscape, directions = 8) +\method{lsm_l_gyrate_cv}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_cv}{RasterStack}(landscape, directions = 8) +\method{lsm_l_gyrate_cv}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_cv}{RasterBrick}(landscape, directions = 8) +\method{lsm_l_gyrate_cv}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_cv}{stars}(landscape, directions = 8) +\method{lsm_l_gyrate_cv}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_cv}{list}(landscape, directions = 8) +\method{lsm_l_gyrate_cv}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -44,6 +47,10 @@ centroid and is based on cell center-to-cell center distances. The metrics chara both the patch area and compactness. The Coefficient of variation is scaled to the mean and comparable among different landscapes. +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. + \subsection{Units}{Meters} \subsection{Range}{GYRATE_CV >= 0 } \subsection{Behaviour}{Equals GYRATE_CV = 0 if the radius of gyration is identical diff --git a/man/lsm_l_gyrate_mn.Rd b/man/lsm_l_gyrate_mn.Rd index 561471884..e53f3ad95 100644 --- a/man/lsm_l_gyrate_mn.Rd +++ b/man/lsm_l_gyrate_mn.Rd @@ -9,23 +9,26 @@ \alias{lsm_l_gyrate_mn.list} \title{GYRATE_MN (landscape level)} \usage{ -lsm_l_gyrate_mn(landscape, directions) +lsm_l_gyrate_mn(landscape, directions, cell_center) -\method{lsm_l_gyrate_mn}{RasterLayer}(landscape, directions = 8) +\method{lsm_l_gyrate_mn}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_mn}{RasterStack}(landscape, directions = 8) +\method{lsm_l_gyrate_mn}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_mn}{RasterBrick}(landscape, directions = 8) +\method{lsm_l_gyrate_mn}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_mn}{stars}(landscape, directions = 8) +\method{lsm_l_gyrate_mn}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_mn}{list}(landscape, directions = 8) +\method{lsm_l_gyrate_mn}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -41,8 +44,11 @@ GYRATE_MN is an 'Area and edge metric'. The metric summarises the landscape as the mean of the radius of gyration of all patches in the landscape. GYRATE measures the distance from each cell to the patch centroid and is based on cell center-to-cell center distances. The metrics characterises -both the patch area and compactness. The Coefficient of variation is -scaled to the mean and comparable among different landscapes. +both the patch area and compactness. + +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. \subsection{Units}{Meters} \subsection{Range}{GYRATE_MN >= 0 } diff --git a/man/lsm_l_gyrate_sd.Rd b/man/lsm_l_gyrate_sd.Rd index 0817bf34a..2f59ab278 100644 --- a/man/lsm_l_gyrate_sd.Rd +++ b/man/lsm_l_gyrate_sd.Rd @@ -9,23 +9,26 @@ \alias{lsm_l_gyrate_sd.list} \title{GYRATE_SD (landscape level)} \usage{ -lsm_l_gyrate_sd(landscape, directions) +lsm_l_gyrate_sd(landscape, directions, cell_center) -\method{lsm_l_gyrate_sd}{RasterLayer}(landscape, directions = 8) +\method{lsm_l_gyrate_sd}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_sd}{RasterStack}(landscape, directions = 8) +\method{lsm_l_gyrate_sd}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_sd}{RasterBrick}(landscape, directions = 8) +\method{lsm_l_gyrate_sd}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_sd}{stars}(landscape, directions = 8) +\method{lsm_l_gyrate_sd}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_l_gyrate_sd}{list}(landscape, directions = 8) +\method{lsm_l_gyrate_sd}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -43,6 +46,10 @@ in the landscape. GYRATE measures the distance from each cell to the patch centroid and is based on cell center-to-cell center distances. The metrics characterises both the patch area and compactness. +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. + \subsection{Units}{Meters} \subsection{Range}{GYRATE_SD >= 0 } \subsection{Behaviour}{Equals GYRATE_SD = 0 if the radius of gyration is identical diff --git a/man/lsm_p_gyrate.Rd b/man/lsm_p_gyrate.Rd index 8d8fd9a48..06bd82b54 100644 --- a/man/lsm_p_gyrate.Rd +++ b/man/lsm_p_gyrate.Rd @@ -9,23 +9,26 @@ \alias{lsm_p_gyrate.list} \title{GYRATE (patch level)} \usage{ -lsm_p_gyrate(landscape, directions) +lsm_p_gyrate(landscape, directions, cell_center) -\method{lsm_p_gyrate}{RasterLayer}(landscape, directions = 8) +\method{lsm_p_gyrate}{RasterLayer}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_p_gyrate}{RasterStack}(landscape, directions = 8) +\method{lsm_p_gyrate}{RasterStack}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_p_gyrate}{RasterBrick}(landscape, directions = 8) +\method{lsm_p_gyrate}{RasterBrick}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_p_gyrate}{stars}(landscape, directions = 8) +\method{lsm_p_gyrate}{stars}(landscape, directions = 8, cell_center = FALSE) -\method{lsm_p_gyrate}{list}(landscape, directions = 8) +\method{lsm_p_gyrate}{list}(landscape, directions = 8, cell_center = FALSE) } \arguments{ \item{landscape}{Raster* Layer, Stack, Brick or a list of rasterLayers.} \item{directions}{The number of directions in which patches should be connected: 4 (rook's case) or 8 (queen's case).} + +\item{cell_center}{If true, the coordinates of the centroid are forced to be +a cell center within the patch.} } \value{ tibble @@ -39,10 +42,13 @@ where \eqn{h_{ijr}} is the distance from each cell to the centroid of the patch and \eqn{z} is the number of cells. GYRATE is an 'Area and edge metric'. The distance from each cell to the -patch -centroid is based on cell center-to-cell center distances. The metrics +patch centroid is based on cell center to centroid distances. The metric characterises both the patch area and compactness. +If \code{cell_center = TRUE} some patches might have several possible cell-center +centroids. In this case, the gyrate index is based on the mean distance of all +cells to all possible cell-center centroids. + \subsection{Units}{Meters} \subsection{Range}{GYRATE >= 0} \subsection{Behaviour}{Approaches GYRATE = 0 if patch is a single cell. diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp index 1d082d846..040ab2bbb 100644 --- a/src/RcppExports.cpp +++ b/src/RcppExports.cpp @@ -148,8 +148,21 @@ BEGIN_RCPP return rcpp_result_gen; END_RCPP } +// find_min +NumericVector find_min(const NumericMatrix& points, int i, int m); +RcppExport SEXP _landscapemetrics_find_min(SEXP pointsSEXP, SEXP iSEXP, SEXP mSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< const NumericMatrix& >::type points(pointsSEXP); + Rcpp::traits::input_parameter< int >::type i(iSEXP); + Rcpp::traits::input_parameter< int >::type m(mSEXP); + rcpp_result_gen = Rcpp::wrap(find_min(points, i, m)); + return rcpp_result_gen; +END_RCPP +} // rcpp_get_nearest_neighbor -NumericVector rcpp_get_nearest_neighbor(const NumericMatrix& points); +NumericMatrix rcpp_get_nearest_neighbor(const NumericMatrix& points); RcppExport SEXP _landscapemetrics_rcpp_get_nearest_neighbor(SEXP pointsSEXP) { BEGIN_RCPP Rcpp::RObject rcpp_result_gen; @@ -185,6 +198,7 @@ static const R_CallMethodDef CallEntries[] = { {"_landscapemetrics_triangular_index", (DL_FUNC) &_landscapemetrics_triangular_index, 2}, {"_landscapemetrics_rcpp_get_coocurrence_vector", (DL_FUNC) &_landscapemetrics_rcpp_get_coocurrence_vector, 3}, {"_landscapemetrics_rcpp_get_entropy", (DL_FUNC) &_landscapemetrics_rcpp_get_entropy, 2}, + {"_landscapemetrics_find_min", (DL_FUNC) &_landscapemetrics_find_min, 3}, {"_landscapemetrics_rcpp_get_nearest_neighbor", (DL_FUNC) &_landscapemetrics_rcpp_get_nearest_neighbor, 1}, {"_landscapemetrics_rcpp_get_unique_values", (DL_FUNC) &_landscapemetrics_rcpp_get_unique_values, 2}, {NULL, NULL, 0} diff --git a/src/rcpp_get_nearest_neighbor.cpp b/src/rcpp_get_nearest_neighbor.cpp index a5b7346c7..a80e23feb 100644 --- a/src/rcpp_get_nearest_neighbor.cpp +++ b/src/rcpp_get_nearest_neighbor.cpp @@ -9,12 +9,16 @@ inline double compute_d2(double x1, double y1, double x2, double y2) { return dx * dx + dy * dy; } -double find_min(const NumericMatrix& points, int i, int m) { +// [[Rcpp::export]] +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);; + double x_i = points(i, 0), y_i = points(i, 1), id_i = points(i, 2); double x_k, x_min, x_max, d, d0 = R_PosInf; - int k; + + int k, id0; + + NumericVector dist_vec (2, 0.0); // Search before i x_min = R_NegInf; @@ -25,6 +29,7 @@ double find_min(const NumericMatrix& points, int i, int m) { d = compute_d2(x_i, y_i, x_k, points(k, 1)); if (d < d0) { d0 = d; + id0 = points(k, 2); x_min = x_i - ::sqrt(d0); } } else { @@ -41,6 +46,7 @@ double find_min(const NumericMatrix& points, int i, int m) { d = compute_d2(x_i, y_i, x_k, points(k, 1)); if (d < d0) { d0 = d; + id0 = points(k, 2); x_max = x_i + ::sqrt(d0); } } else { @@ -49,7 +55,10 @@ double find_min(const NumericMatrix& points, int i, int m) { } } - return ::sqrt(d0); + dist_vec(0) = ::sqrt(d0); + dist_vec(1) = id0; + + return(dist_vec); } //' @title First nearest neighbor distance @@ -68,13 +77,14 @@ double find_min(const NumericMatrix& points, int i, int m) { //' @name rcpp_get_nearest_neighbor //' @export // [[Rcpp::export]] -NumericVector rcpp_get_nearest_neighbor(const NumericMatrix& points) { +NumericMatrix rcpp_get_nearest_neighbor(const NumericMatrix& points) { int nrows = points.nrow(); - NumericVector distances(nrows); + NumericMatrix distances(nrows, 2); for (int i = 0; i < nrows; i++) { - distances[i] = find_min(points, i, nrows); + + distances(i, _) = find_min(points, i, nrows); } return distances; diff --git a/tests/testthat/test-get-boundaries.R b/tests/testthat/test-get-boundaries.R index 24f956ffe..b65297240 100644 --- a/tests/testthat/test-get-boundaries.R +++ b/tests/testthat/test-get-boundaries.R @@ -1,51 +1,85 @@ context("get_boundaries") -test_that("get_boundaries works for RasterLayer", { +classes_lsm <- get_patches(landscape) - result <- get_boundaries(landscape)[[1]] +test_that("get_boundaries works for all data types", { - expect_is(result, "RasterLayer") - expect_true(raster::extent(landscape) == raster::extent(result)) - expect_true(all(get_unique_values(result)[[1]] == c(0, 1))) + raster_layer <- get_boundaries(classes_lsm[[1]]) + raster_stack <- get_boundaries(raster::stack(classes_lsm)) + raster_brick <- get_boundaries(raster::brick(classes_lsm)) + raster_list <- get_boundaries(classes_lsm) + + expect_true(all(sapply(raster_layer, inherits, what = "RasterLayer"))) + expect_true(all(sapply(raster_stack, inherits, what = "RasterLayer"))) + expect_true(all(sapply(raster_brick, inherits, what = "RasterLayer"))) + expect_true(all(sapply(raster_list, inherits, what = "RasterLayer"))) + + expect_true(raster::extent(raster_layer[[1]]) == raster::extent(landscape)) + + expect_length(object = raster_list, n = length(classes_lsm)) +}) + +test_that("get_boundaries returns matrix", { + + raster_layer <- get_boundaries(classes_lsm[[1]], + return_raster = FALSE) + raster_stack <- get_boundaries(raster::stack(classes_lsm), + return_raster = FALSE) + raster_brick <- get_boundaries(raster::brick(classes_lsm), + return_raster = FALSE) + raster_list <- get_boundaries(classes_lsm, + return_raster = FALSE) + + expect_true(all(sapply(raster_layer, inherits, what = "matrix"))) + expect_true(all(sapply(raster_stack, inherits, what = "matrix"))) + expect_true(all(sapply(raster_brick, inherits, what = "matrix"))) + expect_true(all(sapply(raster_list, inherits, what = "matrix"))) + + expect_length(object = raster_list, n = length(classes_lsm)) }) -test_that("get_boundaries works for matrix", { +test_that("get_boundaries return either 1/0 or 1/NA", { - result <- get_boundaries(landscape = landscape, - return_raster = FALSE)[[1]] + result_10 <- get_boundaries(classes_lsm[[1]], + as_NA = FALSE) - expect_is(result, "matrix") - expect_equal(prod(dim(result)), - expected = raster::ncell(landscape)) - expect_equal(get_unique_values(result)[[1]], + result_NA <- get_boundaries(classes_lsm[[1]], + as_NA = TRUE) + + expect_equal(object = get_unique_values(result_10[[1]])[[1]], expected = c(0, 1)) + + expect_equal(object = get_unique_values(result_NA[[1]])[[1]], + expected = 1) }) -test_that("get_boundaries works for all other data types", { +test_that("get_boundaries can increase edge_depth", { + + result_depth_1 <- get_boundaries(classes_lsm[[1]], edge_depth = 1) + result_depth_3 <- get_boundaries(classes_lsm[[1]], edge_depth = 3) - result_stack <- get_boundaries(landscape_stack) - result_brick <- get_boundaries(landscape_brick) - result_list <- get_boundaries(landscape_list) + check <- sum(raster::values(result_depth_1[[1]]), na.rm = TRUE) < + sum(raster::values(result_depth_3[[1]]), na.rm = TRUE) - expect_is(result_stack, "list") - expect_is(result_brick, "list") - expect_is(result_list, "list") + expect_true(object = check) }) -test_that("get_boundaries returns only 1 and NA", { +test_that("get_boundaries can use original patch id", { - result <- get_boundaries(landscape, - as_NA = TRUE)[[1]] + result <- get_boundaries(classes_lsm[[1]], patch_id = TRUE) - expect_equal(get_unique_values(result)[[1]], - expected = 1) + expect_equal(object = get_unique_values(result[[1]])[[1]], + expected = c(0, get_unique_values(classes_lsm[[1]])[[1]])) }) -test_that("get_boundaries works for 8 directions", { +test_that("get_boundaries can consider boundary", { + + result <- get_boundaries(classes_lsm[[1]], consider_boundary = FALSE) + result_boundary <- get_boundaries(classes_lsm[[1]], consider_boundary = TRUE) + + check <- sum(raster::values(result[[1]]), na.rm = TRUE) > + sum(raster::values(result_boundary[[1]]), na.rm = TRUE) - class_1 <- get_patches(landscape, class = 1)[[1]] - result4 <- get_boundaries(class_1, directions = 4)[[1]] - result8 <- get_boundaries(class_1, directions = 8)[[1]] + expect_true(object = check) - expect_true(min(raster::getValues(result8) - raster::getValues(result4), na.rm = TRUE) >= 0) }) diff --git a/tests/testthat/test-get-centroids.R b/tests/testthat/test-get-centroids.R new file mode 100644 index 000000000..684dc9264 --- /dev/null +++ b/tests/testthat/test-get-centroids.R @@ -0,0 +1,56 @@ +context("get_centroids") + +test_that("get_centroids runs for all data types", { + + raster_layer <- get_centroids(landscape) + raster_stack <- get_centroids(landscape_stack) + raster_brick <- get_centroids(landscape_brick) + raster_list <- get_centroids(landscape_list) + + expect_is(raster_layer, "tbl_df") + expect_is(raster_stack, "tbl_df") + expect_is(raster_brick, "tbl_df") + expect_is(raster_list, "tbl_df") +}) + +test_that("get_centroids returns in every column the correct type", { + + centroids <- get_centroids(landscape) + + expect_type(centroids$layer, "integer") + expect_type(centroids$level, "character") + expect_type(centroids$class, "integer") + expect_type(centroids$id, "integer") + expect_type(centroids$x, "double") + expect_type(centroids$y, "double") +}) + +test_that("get_centroids returns centroid for each patch", { + + centroids <- get_centroids(landscape) + + np <- lsm_l_np(landscape) + + expect_true(object = nrow(centroids) == np$value) +}) + +test_that("get_centroids allows to set cell_center", { + + expect_warning(get_centroids(landscape, cell_center = TRUE), + regexp = "For some patches several cell centers are returned as centroid.") + + centroids <- get_centroids(landscape, cell_center = TRUE, + verbose = FALSE) + + np <- lsm_l_np(landscape) + + expect_true(object = nrow(centroids) > np$value) +}) + +test_that("get_centroids can return sp", { + + centroids_sp <- get_centroids(landscape, cell_center = T, + return_sp = TRUE) + + expect_is(centroids_sp, "SpatialPointsDataFrame") +}) diff --git a/tests/testthat/test-get-nearestneighbour.R b/tests/testthat/test-get-nearestneighbour.R index 4dce0e84f..fd772c35d 100644 --- a/tests/testthat/test-get-nearestneighbour.R +++ b/tests/testthat/test-get-nearestneighbour.R @@ -1,33 +1,34 @@ context("get_nearestneighbour") +# get patches for class 1 +class_1 <- get_patches(landscape, class = 1)[[1]] +all_classes <- get_patches(landscape) -# get patches for class 1 from testdata as raster -class_1 <- get_patches(landscape,1)[[1]] -# calculate the distance between patches -nn_rast <- get_nearestneighbour(class_1) -# do the same with a 3 column matrix (x,y,id) -class_1_matrix <- raster_to_points(class_1, return_NA = FALSE) -nn_mat <- get_nearestneighbour(class_1_matrix[, 2:4]) +test_that("get_nearestneighbour works for all data types", { -test_that("get_adjacencies runs and returns a matrix", { - expect_is(nn_rast, "tbl_df") - expect_is(nn_mat, "tbl_df") + raster_layer <- get_nearestneighbour(class_1) + raster_stack <- get_nearestneighbour(raster::stack(all_classes)) + raster_brick <- get_nearestneighbour(raster::brick(all_classes)) + raster_list <- get_nearestneighbour(all_classes) - expect_true(nn_rast[1, 3] == 7) - expect_true(nn_mat[1, 3] == 7) + expect_is(raster_layer, "tbl_df") + expect_is(raster_stack, "tbl_df") + expect_is(raster_brick, "tbl_df") + expect_is(raster_list, "tbl_df") }) -test_that("get_adjacencies runs for all data type", { +test_that("get_nearestneighbour returns value for each patch", { - result_stack <- get_nearestneighbour(landscape_stack) - result_brick <- get_nearestneighbour(landscape_brick) - result_list <- get_nearestneighbour(landscape_list) + np <- lsm_l_np(class_1) + raster_layer <- get_nearestneighbour(class_1) - expect_is(result_stack, "tbl_df") - expect_is(result_brick, "tbl_df") - expect_is(result_list, "tbl_df") + expect_true(object = np$value == nrow(raster_layer)) +}) + +test_that("get_nearestneighbour can return focal and neighbour ID", { + + raster_layer <- get_nearestneighbour(class_1, return_id = TRUE) - expect_true(all(c(1, 2) %in% result_stack$layer)) - expect_true(all(c(1, 2) %in% result_brick$layer)) - expect_true(all(c(1, 2) %in% result_list$layer)) + expect_true(object = ncol(raster_layer) == 4) + expect_true(object = all(raster_layer$id != raster_layer$id_neighbour)) }) diff --git a/tests/testthat/test-lsm-p-gyrate.R b/tests/testthat/test-lsm-p-gyrate.R index bd586d875..f41386bcd 100644 --- a/tests/testthat/test-lsm-p-gyrate.R +++ b/tests/testthat/test-lsm-p-gyrate.R @@ -13,6 +13,14 @@ test_that("lsm_p_gyrate returns the desired number of columns", { expect_equal(ncol(landscapemetrics_patch_landscape_value), 6) }) +test_that("lsm_p_gyrate can force centroid to be within patch", { + + result_a <- lsm_p_gyrate(landscape) + result_b <- lsm_p_gyrate(landscape, cell_center = TRUE) + + expect_true(object = any(result_a$value != result_b$value)) +}) + test_that("lsm_p_gyrate returns in every column the correct type", { expect_type(landscapemetrics_patch_landscape_value$layer, "integer") expect_type(landscapemetrics_patch_landscape_value$level, "character") @@ -21,5 +29,3 @@ test_that("lsm_p_gyrate returns in every column the correct type", { expect_type(landscapemetrics_patch_landscape_value$metric, "character") expect_type(landscapemetrics_patch_landscape_value$value, "double") }) - - diff --git a/vignettes/articles/utility.Rmd b/vignettes/articles/utility.Rmd index e2a6ade67..efd3b99ac 100644 --- a/vignettes/articles/utility.Rmd +++ b/vignettes/articles/utility.Rmd @@ -171,8 +171,11 @@ library(bench) bench::mark( get_nearestneighbour(patches)[, 2:3], nearest_raster_fun(patches), - iterations = 100 + iterations = 100, check = FALSE ) + +# check if results are identical +get_nearestneighbour(patches)[, 2:3] == nearest_raster_fun(patches) ``` ### Get circumscribing circle