Merge pull request #14 from pratikunterwegs/develop

handle dots in before_after and remove dependencies

DESCRIPTION

@@ -14,25 +14,18 @@ LazyData: true
 URL: https://github.com/pratikunterwegs/atlastools
 BugReports: https://github.com/pratikunterwegs/atlastools/issues
 Imports:
-    dplyr,
-    purrr,
-    tibble,
     sf,
     glue,
     data.table,
-    rlang,
     stats,
-    zoo,
     assertthat,
     stringr,
     fasttime,
     RMySQL,
     bit64
-RoxygenNote: 7.1.0
+RoxygenNote: 7.1.1
 Suggests:
-    magrittr,
     testthat (>= 2.1.0),
-    tidyr,
     ggplot2,
     scales,
     knitr,

R/fun_distance_bw_patch.R

@@ -29,22 +29,20 @@ atl_patch_dist <- function(data,
                       msg = "bw_patch_dist: some data assumptions are not met")
 
   # get distance returning zero if single point or NA by default
-  dist <- dplyr::case_when(nrow(data) > 1 ~ {
+  if (nrow(data) > 1) {
     # get x and y
     x1 <- data[[x1]][seq_len(nrow(data) - 1)]
     x2 <- data[[x2]][2:nrow(data)]
     y1 <- data[[y1]][seq_len(nrow(data) - 1)]
     y2 <- data[[y2]][2:nrow(data)]
     # get dist
-    c(NA, sqrt((x1 - x2) ^ 2 + (y1 - y2) ^ 2))
-    },
-    nrow(data) == 1 ~ {
-      0.0
-    },
-    TRUE ~ {
-      as.numeric(NA)
-    }
-  )
+    dist <- c(NA, sqrt((x1 - x2) ^ 2 + (y1 - y2) ^ 2))
+
+  } else if (nrow(data == 1)) {
+    dist <- 0.0
+  } else {
+    dist <- NA_real_
+  }
 
   return(dist)
 }

R/fun_get_patch_data.R

@@ -1,12 +1,13 @@
 #' Get residence patch data.
 #'
-#' @param patch_data A tibble with a nested list column of the raw data
-#' underlying each patch.
+#' @param patch_data A data.frame with a nested list column of the raw data
+#' underlying each patch. Since data.frames don't support nested columns,
+#' will actually be a data.table or similar extension.
 #' @param which_data Which data to return, the raw data underlying the patch,
 #' or a spatial features object with only the patch summary.
 #' @param buffer_radius Spatial buffer radius (in metres) around points when
 #' requesting sf based polygons.
-#' @return An object of type \code{sf} or \code{tibble} depending on
+#' @return An object of type \code{sf} or \code{data.table} depending on
 #' which data is requested.
 #' @import data.table
 #' @export
@@ -44,7 +45,7 @@ atl_patch_summary <- function(patch_data,
     patch_data$patchdata <- NULL
 
     # make spatial polygons
-    polygons <- purrr::reduce(patch_data$polygons, c)
+    polygons <- Reduce(c, patch_data$polygons)
     # temp remove
     patch_data[, polygons := NULL]
     # unlist all the list columns

R/fun_plot_before_after.R

@@ -3,16 +3,16 @@
 #'
 #' @param data The data passed to the pre-preprocessing function.
 #' @param fun The pre-processing function that operates on data.
-#' @param ... Arguments to the pre-processing function.
 #' @param x The X coordinate.
 #' @param y The Y coordinate.
+#' @param args Arguments passed as a list to the pre-processing function.
 #'
 #' @return Nothing. Makes a plot.
 #' @export
 atl_before_after <- function(data,
-                             x = "x",
-                             y = "y",
-                             fun, ...) {
+                             fun, 
+                             x = "x", y = "y",
+                             args = list()) {
   # check data
   assertthat::assert_that(is.data.frame(data),
                           msg = "before_after: input is not a dataframe")
@@ -24,8 +24,8 @@ atl_before_after <- function(data,
 
   # apply function to data COPY
   data_copy <- data.table::copy(data)
-  data_copy <- fun(data_copy, x = "x", y = "y", ...)
-
+  data_copy <- do.call(fun, c(list(data = data), args))
+  
   # check function output
   assertthat::assert_that(is.data.frame(data_copy),
     msg = "before_after: processing result is not a data.frame")

tests/testdata/make_testData.r

@@ -2,7 +2,7 @@
 
 resTimeLimit <- 4
 
-testrevdata <- tibble::tibble(id = 4e3,
+testrevdata <- data.table::CJ(id = 4e3,
 	tide_number = 1e3,
 	x = rep(c(seq(0, 5e3, 1e3),
 	          seq(5e3, 0, -1e3)), each = 100) +
@@ -18,6 +18,6 @@ testrevdata <- tibble::tibble(id = 4e3,
 	                     (11 * 60 * 2)) * 100)
 
 # write to file for testing
-readr::write_csv(testrevdata, "tests/testdata/test_revdata.csv")
+data.table::fwrite(testrevdata, "tests/testdata/test_revdata.csv")
 
 # ends here

tests/testthat/test_patch_distance.R

@@ -2,8 +2,8 @@ context("between patch distance function")
 testthat::test_that("simple distance works", {
 
   # make test positions
-  testdf <- tibble::tibble(a_start = seq(10, 100, 10),
-                           a_end = a_start + 2,
+  testdf <- data.table::data.table(a_start = seq(10, 100, 10),
+                           a_end = seq(10, 100, 10) + 2,
                            b_start = 1, b_end = 1)
   # run function
   testoutput <- atlastools::atl_patch_dist(testdf,
@@ -22,7 +22,7 @@ testthat::test_that("simple distance works", {
   # test that the vector class is numeric or double
   testthat::expect_type(testoutput, "double")
 
-  # test that the distances except first are 1 in this case
+  # test that the distances except first are 8 in this case
   testthat::expect_identical(testoutput, c(NA, rep(8.0, 9)),
                              info = "the distance calculation is wrong")
 

tests/testthat/test_plot_compare.R

@@ -12,8 +12,10 @@ testthat::test_that("data can be plotted", {
                              fun = atlastools::atl_median_smooth,
                              x = "x",
                              y = "y",
-                             time = "time",
-                             moving_window = 3)
+                             args = list(time = "time",
+                                         x = "x",
+                                         y = "y",
+                                         moving_window = 3))
         )
     })
  })

vignettes/removing_reflections.Rmd

@@ -16,8 +16,7 @@ vignette: >
 ## Load libraries
 
 ```{r warning=FALSE, message=FALSE}
-library(tidyr)
-library(dplyr)
+library(data.table)
 library(ggplot2)
 ```
 
@@ -31,8 +30,8 @@ displacement_distance <- c(10 ^ seq(0, 4, 0.1))
 speed_cutoffs <- seq(0, 100, 5)
 
 # use formula for algorithm defeat
-data <- crossing(displacement_distance, speed_cutoffs) %>% 
-  mutate(time_to_defeat = displacement_distance / speed_cutoffs)
+data <- CJ(displacement_distance, speed_cutoffs)[, 
+  time_to_defeat := displacement_distance / speed_cutoffs]
 ```
 
 ```{r fig.cap="Figure showing the time (in minutes) required to beat the 'next reasonable speed' method, for various combinations of the reflection distance from the real positions, _D_ and the speed cutoff, _v_. Area in black represent combinations that fail"}