Fixing most of goodpractice::gp()

r-spatialecology · Dec 4, 2018 · e8f924d · e8f924d
1 parent 944895f
commit e8f924d
Show file tree

Hide file tree

Showing 14 changed files with 48 additions and 35 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -2,7 +2,6 @@ Type: Package
 Package: landscapemetrics
 Title: Landscape Metrics for Categorical Map Patterns
 Version: 0.3
-Date: 2018-11-23
 Authors@R: c(person("Maximillian H.K.", "Hesselbarth",
              role = c("aut", "cre"),
              email = "maximilian.hesselbarth@uni-goettingen.de",

diff --git a/R/check_landscape.R b/R/check_landscape.R
@@ -66,7 +66,7 @@ check_landscape.list <- function(landscape) {
 
 }
 
-proj_info = function(landscape){
+proj_info <- function(landscape){
     landscape_proj <- raster::projection(landscape)
     if (!is.na(landscape_proj)){
         if(raster::isLonLat(landscape)){

diff --git a/R/construct_buffer.R b/R/construct_buffer.R
@@ -36,7 +36,7 @@ construct_buffer.matrix <- function(points, shape, size) {
 
         sample_plots_coords <- cbind(matrix(x_circle, ncol = 1),
                                      matrix(y_circle, ncol = 1),
-                                     rep(1:nrow(points), each = 100))
+                                     rep(seq_len(nrow(points)), each = 100))
 
         sample_plots_coords_split <- split(sample_plots_coords[, -3], sample_plots_coords[, 3])
 
@@ -65,7 +65,7 @@ construct_buffer.matrix <- function(points, shape, size) {
                   points[, 2] + size / 2,
                   points[, 2] - size / 2),
                 ncol = 1),
-            rep(1:nrow(points), times = 4)
+            rep(seq_len(nrow(points)), times = 4)
         )
 
         sample_plots_coords_split <- split(sample_plots_coords[, -3],

diff --git a/R/get_patches.R b/R/get_patches.R
@@ -250,12 +250,12 @@ get_patches_int <- function(landscape,
 
             # connected labeling with 4 neighbours
             if (directions == 4) {
-                patch_landscape = .Call('ccl_4', filter_matrix, PACKAGE = 'landscapemetrics')
+                patch_landscape <- .Call('ccl_4', filter_matrix, PACKAGE = 'landscapemetrics')
             }
 
             # connected labeling with 8 neighbours
             if (directions == 8) {
-                patch_landscape = .Call('ccl_8', filter_matrix, PACKAGE = 'landscapemetrics')
+                patch_landscape <- .Call('ccl_8', filter_matrix, PACKAGE = 'landscapemetrics')
             }
 
             return(patch_landscape)
@@ -272,11 +272,11 @@ get_patches_int <- function(landscape,
             filter_matrix[landscape == class] <- 1
 
             if (directions == 4) {
-                patch_landscape = .Call('ccl_4', filter_matrix, PACKAGE = 'landscapemetrics')
+                patch_landscape <- .Call('ccl_4', filter_matrix, PACKAGE = 'landscapemetrics')
             }
 
             if (directions == 8) {
-                patch_landscape = .Call('ccl_8', filter_matrix, PACKAGE = 'landscapemetrics')
+                patch_landscape <- .Call('ccl_8', filter_matrix, PACKAGE = 'landscapemetrics')
             }
 
             return(patch_landscape)

diff --git a/R/get_unique_values.R b/R/get_unique_values.R
@@ -76,7 +76,7 @@ get_unique_values.RasterStack <- function(x){
         x <- get_unique_values_int(x@data@values)
         if (!is.list(x)) {
             xx <- vector(length = ncol(x), mode = 'list')
-            for (i in 1:ncol(x)) {
+            for (i in seq_len(ncol(x))) {
                 xx[[i]] <- x[,i]
             }
             x <- xx

diff --git a/R/list_lsm.R b/R/list_lsm.R
@@ -46,9 +46,10 @@ list_lsm <- function(level = NULL,
 
     lsm_abbreviations_names_modified <- landscapemetrics::lsm_abbreviations_names
 
-    lsm_abbreviations_names_modified$metric_new <- sapply(strsplit(lsm_abbreviations_names_modified$metric,
-                                                                   split = "_"),
-                                                          function(x) x[1])
+    lsm_abbreviations_names_modified$metric_new <- vapply(X = strsplit(lsm_abbreviations_names_modified$metric,
+                                                                       split = "_"),
+                                                          FUN = function(x) x[1],
+                                                          FUN.VALUE = character(1))
 
     if(!is.null(what)) {
 

diff --git a/R/lsm_c_clumpy.R b/R/lsm_c_clumpy.R
@@ -141,7 +141,7 @@ lsm_c_clumpy_calc <- function(landscape, resolution = NULL){
     prop_class <- prop_class$value / 100
 
     # calculate clumpy
-    clumpy <- sapply(seq_along(g_i), function(row_ind) {
+    clumpy <- vapply(seq_along(g_i), FUN = function(row_ind) {
 
         # set to NA if mathematical not possible
         if (is.nan(g_i[row_ind]) || is.na(g_i[row_ind]) || prop_class[row_ind] == 1) {
@@ -155,11 +155,11 @@ lsm_c_clumpy_calc <- function(landscape, resolution = NULL){
         else {
             clumpy <- (g_i[row_ind] - prop_class[row_ind]) / (1 - prop_class[row_ind])
         }
-    })
+    }, FUN.VALUE = numeric(1))
 
     tibble::tibble(
         level = "class",
-        class = as.integer(names(clumpy)),
+        class = as.integer(names(g_i)),
         id = as.integer(NA),
         metric = "clumpy",
         value = as.double(clumpy)

diff --git a/R/lsm_c_pladj.R b/R/lsm_c_pladj.R
@@ -107,12 +107,12 @@ lsm_c_pladj_calc <- function(landscape) {
     tb <- rcpp_get_coocurrence_matrix(landscape_padded,
                                       directions = as.matrix(4))
 
-    pladj <- sapply(X = seq_len(nrow(tb)), FUN = function(x) {
+    pladj <- vapply(X = seq_len(nrow(tb)), FUN = function(x) {
         like_adjacencies <- tb[x, x]
         total_adjacencies <- sum(tb[x, ])
 
         like_adjacencies / total_adjacencies * 100
-    })
+    }, FUN.VALUE = numeric(1))
 
     pladj <- pladj[-1]
     names <- row.names(tb)[-1]

diff --git a/R/lsm_p_circle.R b/R/lsm_p_circle.R
@@ -124,7 +124,7 @@ lsm_p_circle_calc <- function(landscape, directions,
         points <- raster_to_points(landscape)
 
         # get resolution
-        resolution = raster::res(landscape)
+        resolution <- raster::res(landscape)
 
         # convert to matrix
         landscape <- raster::as.matrix(landscape)

diff --git a/R/sample_lsm.R b/R/sample_lsm.R
@@ -86,7 +86,7 @@ sample_lsm.RasterStack <- function(landscape,
 
     layer_id <- rep(x = seq_len(raster::nlayers(landscape)), each = nrow(points))
 
-    for(current_layer in 1:nrow(result)) {
+    for(current_layer in seq_len(nrow(result))) {
         result$metrics[[current_layer]]$layer <- layer_id[current_layer]
     }
 
@@ -122,7 +122,7 @@ sample_lsm.RasterBrick <- function(landscape,
 
     layer_id <- rep(x = seq_len(raster::nlayers(landscape)), each = nrow(points))
 
-    for(current_layer in 1:nrow(result)) {
+    for(current_layer in seq_len(nrow(result))) {
         result$metrics[[current_layer]]$layer <- layer_id[current_layer]
     }
 
@@ -158,7 +158,7 @@ sample_lsm.list <- function(landscape,
 
     layer_id <- rep(x = seq_along(landscape), each = nrow(points))
 
-    for(current_layer in 1:nrow(result)) {
+    for(current_layer in seq_len(nrow(result))) {
         result$metrics[[current_layer]]$layer <- layer_id[current_layer]
     }
 

diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp
@@ -204,8 +204,8 @@ static const R_CallMethodDef CallEntries[] = {
     {"_landscapemetrics_rcpp_get_offdiagonal_vector", (DL_FUNC) &_landscapemetrics_rcpp_get_offdiagonal_vector, 2},
     {"_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},
-    {"ccl_4", (DL_FUNC) &ccl_4, 1},
-    {"ccl_8", (DL_FUNC) &ccl_8, 1},
+    {"ccl_4",                                              (DL_FUNC) &ccl_4,                                              1},
+    {"ccl_8",                                              (DL_FUNC) &ccl_8,                                              1},
     {NULL, NULL, 0}
 };
 

diff --git a/tests/testthat/test-calculate-lsm.R b/tests/testthat/test-calculate-lsm.R
@@ -49,11 +49,12 @@ test_that("calculate_lsm can take level argument", {
 
 
 test_that("calculate_lsm can take metric argument", {
+
     specific_metrics <- calculate_lsm(landscape, metric = "area")
 
-    metrics <- sapply(strsplit(specific_metrics$metric,
-                    split = "_"),
-           function(x) x[1])
+    metrics <- vapply(strsplit(specific_metrics$metric,
+                               split = "_"), FUN = function(x) x[1],
+                      FUN.VALUE = character(1))
 
     expect_true(all(metrics == "area"))
 
@@ -65,9 +66,9 @@ test_that("calculate_lsm can take metric argument", {
 test_that("calculate_lsm can take name argument", {
     specific_metrics <- calculate_lsm(landscape, name = "core area")
 
-    metrics <- sapply(strsplit(specific_metrics$metric,
-                               split = "_"),
-                      function(x) x[1])
+    metrics <- vapply(strsplit(specific_metrics$metric,
+                               split = "_"), FUN = function(x) x[1],
+                      FUN.VALUE = character(1))
 
     expect_true(all(metrics == "core"))
 

diff --git a/tests/testthat/test-show-cores.R b/tests/testthat/test-show-cores.R
@@ -18,9 +18,15 @@ test_that("show_cores returns a plot for class = global", {
 })
 
 test_that("show_patches returns a plot for each list entry", {
-    expect_true(all(sapply(cores_landscape_stack, FUN = function(x) class(x)[2]) == "ggplot"))
-    expect_true(all(sapply(cores_landscape_brick, FUN = function(x) class(x)[2]) == "ggplot"))
-    expect_true(all(sapply(cores_landscape_list, FUN = function(x) class(x)[2]) == "ggplot"))
+    expect_true(all(vapply(cores_landscape_stack,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
+    expect_true(all(vapply(cores_landscape_brick,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
+    expect_true(all(vapply(cores_landscape_list,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
 })
 
 test_that("show_patches returns error if class is not present", {

diff --git a/tests/testthat/test-show-patches.R b/tests/testthat/test-show-patches.R
@@ -14,9 +14,15 @@ test_that("show_patches returns a plot", {
 })
 
 test_that("show_patches returns a plot for each list entry", {
-    expect_true(all(sapply(patches_landscape_stack, FUN = function(x) class(x)[2]) == "ggplot"))
-    expect_true(all(sapply(patches_landscape_brick, FUN = function(x) class(x)[2]) == "ggplot"))
-    expect_true(all(sapply(patches_landscape_list, FUN = function(x) class(x)[2]) == "ggplot"))
+    expect_true(all(vapply(patches_landscape_stack,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
+    expect_true(all(vapply(patches_landscape_brick,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
+    expect_true(all(vapply(patches_landscape_list,
+                           FUN = function(x) class(x)[2],
+                           FUN.VALUE = character(1)) == "ggplot"))
 })
 
 test_that("show_patches returns warnings and errors", {