Merge pull request #335 from r-spatialecology/main

landscapemetrics 2.2

Author: mhesselbarth

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: landscapemetrics
 Title: Landscape Metrics for Categorical Map Patterns
-Version: 2.1.4
+Version: 2.2
 Authors@R: c(person("Maximilian H.K.", "Hesselbarth",
              role = c("aut", "cre"),
              email = "[email protected]",

NAMESPACE

@@ -172,6 +172,7 @@ export(proj_info)
 export(raster_to_points)
 export(rcpp_get_nearest_neighbor)
 export(sample_lsm)
+export(scale_sample)
 export(show_cores)
 export(show_correlation)
 export(show_lsm)

NEWS.md

@@ -1,3 +1,9 @@
+# landscapemetrics 2.2
+* New functions
+    * Adding `scale_sample` again
+* Improvements
+    * Better handling of point features
+
 # landscapemetrics 2.1.4
 * Various
     * Adding `landscape_as_list()` method for `PackedSpatRaster`

R/construct_buffer.R

@@ -2,10 +2,10 @@
 #'
 #' @description Internal function to construct plot area around coordinates
 #'
-#' @param coords SpatVector, sf object or 2-column matrix with coordinates of sample points
-#' @param shape String specifying plot shape. Either "circle" or "square"
+#' @param coords Point geometry as SpatVector or sf object or 2-column matrix with coordinates.
+#' @param shape String specifying plot shape. Either "circle" or "square".
 #' @param size Size of sample plot. Equals the radius for circles or the
-#' side-length for squares in map units
+#' side-length for squares in map units.
 #' @param return_vec If TRUE, vector objects are returned.
 #' @param crs The coordinate reference system used for vector objects.
 #' @param verbose Print warning messages.
@@ -28,7 +28,6 @@ construct_buffer <- function(coords, shape , size, return_vec = TRUE, crs="", ve
     if (verbose) {
 
         if (ncol(coords) != 2) {
-
             warning("'coords' should be a two column matrix including x- and y-coordinates.",
                     call. = FALSE)
         }

R/extract_lsm.R

@@ -3,7 +3,7 @@
 #' @description Extract metrics
 #'
 #' @param landscape A categorical raster object: SpatRaster; Raster* Layer, Stack, Brick; stars or a list of SpatRasters.
-#' @param y 2-column matrix with coordinates or sf point geometries.
+#' @param y Point geometry as SpatVector or sf object or 2-column matrix with coordinates.
 #' @param extract_id Vector with id of sample points. If not provided, sample
 #' points will be labelled 1...n.
 #' @param metric Abbreviation of metrics (e.g. 'area').
@@ -138,13 +138,14 @@ extract_lsm_internal <- function(landscape, y, extract_id, metric, name, type, w
 
     # calculate metrics
     # can we somehow calculate only the patches we actually want?
+    # MH: Extract id and set all others to NA?
     metrics <- calculate_lsm(landscape,
                              what = metrics_list,
                              directions = directions,
                              verbose = verbose,
                              progress = progress, ...)
 
-    # only patchs that contain a sample point
+    # only patches that contain a sample point
     extract_metrics <- merge(x = metrics, y = point_id,
                              by = "id", all.x = FALSE, all.y = FALSE, sort = FALSE)
 

R/points_as_mat.R

@@ -2,7 +2,7 @@
 #'
 #' @description Points as matrix
 #'
-#' @param pts SpatVector points or sf object
+#' @param pts Point geometry as SpatVector or sf object.
 #'
 #' @details
 #' Converts sf points to coordinates matrix
@@ -15,14 +15,13 @@
 points_as_mat = function(pts) {
 
     # convert to coords if sf object is provided
-    if (inherits(x = pts, what = "sf") | inherits(x = pts, what = "sfc") | inherits(x = pts, what = "sfg") |
-        inherits(x = pts, what = "SpatialPoints") | inherits(x = pts, what = "SpatVector")) {
+    if (inherits(x = pts, what = c("sf", "sfc", "sfg", "SpatialPoints", "SpatVector"))) {
 
         # convert to terra
         pts <- methods::as(pts, "SpatVector")
 
         # check of points
-        if (terra::geomtype(pts) != "points") stop("landscapemetrics currently only supports point or polygon features.",
+        if (terra::geomtype(pts) != "points") stop("landscapemetrics currently only supports point features.",
                                                    call. = FALSE)
 
         # get coords
@@ -34,7 +33,7 @@ points_as_mat = function(pts) {
     } else if (inherits(x = pts, what = "matrix")) {
 
         # return error if not just two cols
-        if (ncol(pts) != 2) stop("Please provide a matrix with coords, point or polygon  object.", call. = FALSE)
+        if (ncol(pts) != 2) stop("Please provide a matrix with coords or point object.", call. = FALSE)
 
         return(pts)
 

R/sample_lsm.R

@@ -3,7 +3,7 @@
 #' @description Sample metrics
 #'
 #' @param landscape A categorical raster object: SpatRaster; Raster* Layer, Stack, Brick; stars or a list of SpatRasters.
-#' @param y 2-column matrix with coordinates or sf point geometries.
+#' @param y 2-column matrix with coordinates or spatial object.
 #' @param plot_id Vector with id of sample points. If not provided, sample
 #' points will be labelled 1...n.
 #' @param shape String specifying plot shape. Either "circle" or "square"
@@ -25,7 +25,7 @@
 #' landscape boundary. Therefore, we report the actual clipped sample plot area relative
 #' in relation to the theoretical, maximum sample plot area e.g. a sample plot only half
 #' within the landscape will have a `percentage_inside = 50`. Additionally, if the polygon
-#' representing the sample plot is smaller than the cell size of the raster, 
+#' representing the sample plot is smaller than the cell size of the raster,
 #' the `percentage_inside` may exceed 100%.Please be aware that the
 #' output is slightly different to all other `lsm`-function of `landscapemetrics`.
 #'
@@ -106,16 +106,16 @@ sample_lsm_int <- function(landscape, y, plot_id, shape, size,
 
     }
 
-    # check if y is sf object
-    if (inherits(x = y, what = "sf") | inherits(x = y, what = "sfc") | inherits(x = y, what = "sfg") |
-        inherits(x = y, what = "SpatialPolygons") | inherits(x = y, what = "SpatVector")) {
+    # check if y is spatial object
+    if (inherits(x = y, what = c("sf", "sfc", "sfg", "SpatialPoints", "SpatialPolygons", "SpatVector"))) {
 
         # convert to terra
         y <- methods::as(y, "SpatVector")
 
         # get crs
         crs <- terra::crs(y)
 
+        # points provided
         if (terra::geomtype(y) == "points") {
 
             if (is.null(size) | size == 0) stop("Please provide size argument size > 0.", call. = FALSE)
@@ -125,7 +125,7 @@ sample_lsm_int <- function(landscape, y, plot_id, shape, size,
 
         }
 
-    # y should be matrix or points
+    # y should be matrix
     } else if (inherits(x = y, what = "matrix")) {
 
         if (is.null(size)) stop("Please provide size argument.", call. = FALSE)
@@ -135,12 +135,12 @@ sample_lsm_int <- function(landscape, y, plot_id, shape, size,
 
     } else {
 
-        stop("Please provide a matrix with coords, points or polygons object.", call. = FALSE)
+        stop("Please provide a matrix with coords or spatial object.", call. = FALSE)
 
     }
 
     # check if y is a polygon
-    if (terra::geomtype(y) != "polygons") stop("Please provide polygon object.", call. = FALSE)
+    if (terra::geomtype(y) != "polygons") stop("Please provide a matrix with coords or spatial object.", call. = FALSE)
 
     # check if length is identical if ids are provided
     if (!is.null(plot_id)) {
@@ -165,57 +165,59 @@ sample_lsm_int <- function(landscape, y, plot_id, shape, size,
     warning_messages <- character(0)
 
     # loop through each sample point and calculate metrics
-    result <- withCallingHandlers(expr = {do.call(rbind, lapply(X = 1:number_plots,
-                                                                FUN = function(current_plot) {
+    result <- withCallingHandlers(expr = {
+        do.call(rbind, lapply(X = 1:number_plots, FUN = function(current_plot) {
 
-        # print progess using the non-internal name
-        if (progress) {
+            # print progess using the non-internal name
+            if (progress) {
 
-            cat("\r> Progress sample plots: ", current_plot, "/", number_plots)
-        }
+                cat("\r> Progress sample plots: ", current_plot, "/", number_plots)
 
-        # crop sample plot
-        landscape_mask <- terra::crop(x = landscape, y = y[current_plot, ], mask = TRUE)
+            }
 
-        # calculate actual area of sample plot
-        area <- lsm_l_ta_calc(landscape_mask, directions = 8)
+            # crop sample plot
+            landscape_mask <- terra::crop(x = landscape, y = y[current_plot, ], mask = TRUE)
 
-        # calculate lsm
-        result_current_plot <- calculate_lsm(landscape = landscape_mask,
-                                             verbose = verbose,
-                                             progress = FALSE,
-                                             ...)
+            # calculate actual area of sample plot
+            area <- lsm_l_ta_calc(landscape_mask, directions = 8)
 
-        # add plot id 1...n
-        if (is.null(plot_id)) {
+            # calculate lsm
+            result_current_plot <- calculate_lsm(landscape = landscape_mask,
+                                                 verbose = verbose,
+                                                 progress = FALSE,
+                                                 ...)
 
-            result_current_plot$plot_id <- current_plot
+            # add plot id 1...n
+            if (is.null(plot_id)) {
 
-        # add plot_id
-        } else {
-            result_current_plot$plot_id <- plot_id[current_plot]
-        }
+                result_current_plot$plot_id <- current_plot
 
-        # all cells are NA
-        if (all(is.na(terra::values(landscape_mask, mat = FALSE)))) {
+            # add plot_id
+            } else {
+                result_current_plot$plot_id <- plot_id[current_plot]
+            }
 
-            # calculate ratio between actual area and theoretical area
-            result_current_plot$percentage_inside <- 0
-        } else {
+            # all cells are NA
+            if (all(is.na(terra::values(landscape_mask, mat = FALSE)))) {
 
-            # calculate ratio between actual area and theoretical area
-            result_current_plot$percentage_inside <- area$value /
-                maximum_area[[current_plot]] * 100
-        }
+                # calculate ratio between actual area and theoretical area
+                result_current_plot$percentage_inside <- 0
+            } else {
 
-        # add sample plot raster
-        result_current_plot$raster_sample_plots <- terra::as.list(landscape_mask)
+                # calculate ratio between actual area and theoretical area
+                result_current_plot$percentage_inside <- area$value /
+                    maximum_area[[current_plot]] * 100
+            }
 
-        return(result_current_plot)}))}, warning = function(cond) {
+            # add sample plot raster
+            result_current_plot$raster_sample_plots <- terra::as.list(landscape_mask)
 
-            warning_messages <<- c(warning_messages, conditionMessage(cond))
+            return(result_current_plot)
+            })
+        )}, warning = function(cond) {
+                warning_messages <<- c(warning_messages, conditionMessage(cond))
 
-            invokeRestart("muffleWarning")}
+                invokeRestart("muffleWarning")}
     )
 
     if (progress) {