v1.1.0: switch to data.table backend for handling data frames, export…

… stdev_transform function

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: colorednoise
 Type: Package
 Title: Simulate Temporally Autocorrelated Populations
-Version: 1.0.5
-Date: 2019-09-26
+Version: 1.1.0
+Date: 2020-08-03
 Authors@R: c(
     person("Julia", "Pilowsky", email = "[email protected]", 
     role = c("aut", "cre"), comment = c(ORCID = "0000-0002-6376-2585")
@@ -14,12 +14,11 @@ License: GPL-3
 Depends: R (>= 3.3.0)
 Imports:
   stats (>= 3.3.2),
-  dplyr (>= 0.7.3),
   purrr (>= 0.2.3),
-  tibble (>= 2.0.0),
-  tidyr (>= 1.0.0)
+  Rcpp (>= 1.0.5),
+  data.table (>= 1.12.8)
 LinkingTo: Rcpp, RcppArmadillo
-RoxygenNote: 6.1.1
+RoxygenNote: 7.1.1
 Encoding: UTF-8
 LazyData: true
 BugReports: http://github.com/japilo/colorednoise/issues

NAMESPACE

@@ -7,14 +7,13 @@ export(colored_noise)
 export(cor2cov)
 export(matrix_model)
 export(multi_rnorm)
+export(stdev_transform)
 export(unstructured_pop)
-import(dplyr)
+import(data.table, except = transpose)
 import(purrr)
-import(tidyr)
+importFrom(Rcpp,evalCpp)
 importFrom(stats,acf)
 importFrom(stats,na.omit)
 importFrom(stats,plogis)
 importFrom(stats,sd)
-importFrom(tibble,as_tibble)
-importFrom(tibble,tibble)
 useDynLib(colorednoise, .registration = TRUE)

NEWS.md

@@ -1,10 +1,15 @@
+## colorednoise 1.1.0
+
+* New function exported: `stdev_transform`, which adapts standard deviations to different probability distributions.
+* colorednoise now runs on `data.table` instead of `dplyr`, `tibble`, and `tidyr` for faster simulations.
+
 ## colorednoise 1.0.5
 
-* Updated to be compatible with tidyr v1.0.0
+* Updated to be compatible with `tidyr` v1.0.0
 
 ## colorednoise 1.0.4
 
-* Updated to be compatible with tibble v2.0.0
+* Updated to be compatible with `tibble` v2.0.0
 
 ## colorednoise 1.0.3
 

R/RcppExports.R

@@ -68,18 +68,41 @@ cor2cov <- function(sigma, corrMatrix) {
 #' @param covMatrix A valid covariance matrix. The number of rows/columns must match the length of the mu, sigma, and phi vectors.
 #' @return A matrix with as many rows as timesteps and as many columns as mu/sigma/phi values.
 #' @examples
-#' cov <- matrix(c(0.037, 0.044, -0.048, 0.044, 0.247, -0.008, -0.047, -0.008, 0.074), nrow = 3)
+#' cov <- matrix(c(1, 0.53, 0.73, 0.53, 1, 0.44, 0.73, 0.44, 1), nrow = 3)
 #' test <- colored_multi_rnorm(100, c(0, 3, 5), c(1, 0.5, 1), c(0.5, -0.3, 0), cov)
 #' var(test)
-#' library(dplyr)
-#' test %>% as.data.frame() %>% summarize_all(.funs = c("mean", "sd", "autocorrelation"))
+#' library(data.table)
+#' as.data.table(test)[, .(V1_mean = mean(V1), V2_mean = mean(V2), V3_mean = mean(V3),
+#' V1_sd = sd(V1), V2_sd = sd(V2), V3_sd = sd(V3),
+#' V1_autocorrelation = autocorrelation(V1), V2_autocorrelation = autocorrelation(V2),
+#' V3_autocorrelation = autocorrelation(V3))]
 #' @export
 colored_multi_rnorm <- function(timesteps, mean, sd, phi, covMatrix) {
     .Call(`_colorednoise_colored_multi_rnorm`, timesteps, mean, sd, phi, covMatrix)
 }
 
-variancefix <- function(mu, sigma, dist) {
-    .Call(`_colorednoise_variancefix`, mu, sigma, dist)
+#' Translate Standard Deviation from the Natural Scale to the Log or Logit Scale
+#'
+#' This function changes a given standard deviation so that when a vector of samples is drawn from the given distribution,
+#' the original standard deviation will be recovered once it is back-transformed from the log or logit scale. In effect,
+#' the function "translates" a standard deviation from the natural scale to the log or logit scale for the purposes of
+#' random draws from a probability distribution.
+#' @param mu The mean of the distribution on the natural scale.
+#' @param sigma The standard devation of the distribution on the natural scale.
+#' @param dist The distribution to which the standard deviation should be transformed.
+#' @return The standard deviation translated to the log or logit scale.
+#' @examples
+#' mean <- 10
+#' stdev <- 2
+#' mean_trans <- log(mean)
+#' stdev_trans <- stdev_transform(mean, stdev, "log")
+#' draws <- rnorm(50, mean_trans, stdev_trans)
+#' natural_scale <- exp(draws)
+#' mean(draws)
+#' sd(draws)
+#' @export
+stdev_transform <- function(mu, sigma, dist) {
+    .Call(`_colorednoise_stdev_transform`, mu, sigma, dist)
 }
 
 #' Simulated Time Series of an Unstructured Temporally Autocorrelated Population

R/colorednoise.R

@@ -8,13 +8,12 @@
 #' @name colorednoise
 #' @useDynLib colorednoise, .registration = TRUE
 #' @import purrr
-#' @import dplyr
+#' @importFrom Rcpp evalCpp
+#' @rawNamespace import(data.table, except = transpose)
 #' @importFrom stats sd acf na.omit plogis
-#' @importFrom tibble tibble as_tibble
-#' @import tidyr
 NULL
 
 ## quiets concerns of R CMD check re: the .'s that appear in
 ## pipelines
 if (getRversion() >= "2.15.1") utils::globalVariables(c(".", "mean.trans",
-    "sd.trans", "noise", "timestep", "dist", "zero"))
+    "sd.trans", "noise", "timestep", "dist", "zero", "ref"))

R/simulate_populations.R

@@ -57,8 +57,8 @@ autocorr_sim <- function(timesteps, start, survPhi, fecundPhi, survMean,
         }
     }
     # Unnests the list and adds estimates of survival and fertility
-    sims <- labeled_sims %>% flatten() %>% map(~mutate(., est_surv = survivors/population,
-        est_fecund = newborns/survivors))
+    sims <- labeled_sims %>% flatten() %>% map(setDT) %>%
+      map(~.[, `:=`(est_surv = survivors/population, est_fecund = newborns/survivors)])
     return(sims)
 }
 
@@ -117,10 +117,10 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
     colNames = NULL, matrixStructure = NULL, repeatElements = NULL,
     survivalOverflow = "scale") {
     stages <- length(initialPop)
-    # Regularize all valid data inputs to the same format
+    # Regularize all valid data input to the same format
     if (is.data.frame(data) == T) {
         if (is.null(colNames) == F) {
-            data <- data[, colNames] %>% rename(!(!(!colNames)))
+            data <- data %>% setDT() %>% setnames(old = colNames, new = names(colNames))
         }
         if (all(names(data) == c("mean", "sd", "autocorrelation")) ==
             F) {
@@ -135,7 +135,7 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
         if (all(data$sd > 0) == F) {
             stop("Invalid values in SD column")
         }
-        dat <- data %>% as_tibble()
+        dat <- setDT(data)
     } else if (is.list(data) == T) {
         if (length(data) > 3) {
             stop("List data should only have 3 elements")
@@ -149,7 +149,7 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
         if (length(unique(map_int(data, length)))>1) {
           stop("Matrices are not equal dimensions")
         }
-        dat <- tibble(mean = as.vector(t(data[[1]])), sd = as.vector(t(data[[2]])),
+        dat <- data.table(mean = as.vector(t(data[[1]])), sd = as.vector(t(data[[2]])),
             autocorrelation = as.vector(t(data[[3]])))
     } else {
         stop("Invalid data type. Must be a list of three matrices or a data frame with three columns.")
@@ -166,31 +166,35 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
     if (is.null(repeatElements) == T) {
       repeatElements <- matrix(seq(1:stages^2), ncol = stages, byrow = T)
     }
-    dat <- dat %>% mutate(dist = dists, zero = mean==0&sd==0,
-                          ref = as.vector(t(repeatElements)))
+    dat <- dat[, `:=`(dist = dists, zero = mean == 0 & sd == 0, ref = as.vector(t(repeatElements)))]
     repeats <- repeatElements == matrix(seq(1:stages^2), ncol = stages, byrow = T)
     # Create version of data that can be used to generate colored noise
-    inputs <- dat %>% slice(which(t(repeats))) %>% filter(zero == F) %>%
-      rowwise() %>% mutate(
-        mean.trans = ifelse(mean == 0, 0, invoke(dist, list(mean))),
-        sd.trans = ifelse(sd == 0, 0, variancefix(mean, sd, dist))
-      )
+    unique <- dat[which(t(repeats))][zero == F]
+    unique$mean.trans <- map_dbl(c(1:nrow(unique)), function(x) {
+      if(dat[x,]$mean == 0) {0} else {
+        invoke(dat[x,]$dist, list(dat[x,]$mean))
+        }
+    })
+    unique$sd.trans <- map_dbl(c(1:nrow(unique)), function(x) {
+      if(dat[x,]$sd == 0) {0} else {
+        stdev_transform(dat[x,]$mean, dat[x,]$sd, dat[x,]$dist)
+      }
+    })
     if (is.null(covMatrix) == T) {
-      covMatrix <- cor2cov(inputs$sd, diag(nrow(inputs)))
+      covMatrix <- cor2cov(unique$sd, diag(nrow(unique)))
     }
     # Create colored noise, discard if invalid matrix
     if(survivalOverflow == "redraw") {
       repeat {
-        inputs$noise <- colored_multi_rnorm(timesteps, inputs$mean.trans, inputs$sd.trans,
-                                            inputs$autocorrelation, covMatrix) %>% split(col(.))
-        result <- left_join(dat, inputs, by = c("mean", "sd", "autocorrelation", "dist", "zero", "ref"))
+        unique$noise <- colored_multi_rnorm(timesteps, unique$mean.trans, unique$sd.trans,
+                                            unique$autocorrelation, covMatrix) %>% split(col(.))
+        result <- dat[unique, on = .(mean, sd, autocorrelation, dist, zero, ref), allow.cartesian = TRUE]
         result$noise[dat$zero==T] <- rep(list(rep.int(0, timesteps)), sum(dat$zero==T))
         # checking for >1 probability
-        result <- result %>% rowwise() %>% mutate(
-          natural.noise = ifelse(zero == T, list(noise),
-                                 ifelse(dist == "log", list(exp(noise)),
-                                        list(plogis(noise))))
-        )
+        result$natural.noise <- map(c(1:nrow(result)), function(x) {
+          if (result[x,]$zero) {result[x,]$noise} else if (result[x,]$dist=="log") {
+            exp(result[x,]$noise[[1]])} else {plogis(result[x,]$noise[[1]])}
+          })
         matrices <- map(1:timesteps, function(x) {
           matrix(map_dbl(result$natural.noise, x), byrow = T, ncol = stages)
         })
@@ -201,15 +205,15 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
         }
       }
     } else if(survivalOverflow == "scale") {
-      inputs$noise <- colored_multi_rnorm(timesteps, inputs$mean.trans, inputs$sd.trans,
-                                          inputs$autocorrelation, covMatrix) %>% split(col(.))
-      result <- left_join(dat, inputs, by = c("mean", "sd", "autocorrelation", "dist", "zero", "ref"))
+      unique$noise <- colored_multi_rnorm(timesteps, unique$mean.trans, unique$sd.trans,
+                                          unique$autocorrelation, covMatrix) %>% split(col(.))
+      result <- dat[unique, on = .(mean, sd, autocorrelation, dist, zero, ref), allow.cartesian = TRUE]
       result$noise[dat$zero==T] <- rep(list(rep.int(0, timesteps)), sum(dat$zero==T))
       # checking for >1 probability
-      result <- result %>% rowwise() %>% mutate(
-        natural.noise = ifelse(zero == T, list(noise),
-                               ifelse(dist == "log", list(exp(noise)),
-                                      list(plogis(noise)))))
+      result$natural.noise <- map(c(1:nrow(result)), function(x) {
+        if (result[x,]$zero) {result[x,]$noise} else if (result[x,]$dist=="log") {
+          exp(result[x,]$noise[[1]])} else {plogis(result[x,]$noise[[1]])}
+      })
       matrices <- map(1:timesteps, function(x) {
         matrix(map_dbl(result$natural.noise, x), byrow = T, ncol = stages)
       })
@@ -226,7 +230,9 @@ matrix_model <- function(data, initialPop, timesteps, covMatrix = NULL,
       }
     } else {stop("survivalOverflow must be set to 'redraw' or 'scale'")}
     pop <- projection(initialPop, matrices)
-    pop %>% map(as_tibble, .name_repair = ~ c(paste0("stage", 1:stages))) %>%
-      bind_rows() %>% group_by(timestep = row_number()) %>% nest(data = -timestep) %>%
-      mutate(total = map_dbl(data, sum)) %>% unnest(data)
+    # CONVERT TO DATA.TABLE
+    output <- pop %>% map(as.data.table) %>% rbindlist() %>%
+      .[, `:=`(total = rowSums(.SD), timestep = seq_len(.N))] %>% setcolorder("timestep")
+    names(output) <- c("timestep", map_chr(1:stages, ~paste0("stage", .)), "total")
+    return(output)
 }

README.Rmd

@@ -11,13 +11,15 @@ knitr::opts_chunk$set(
   fig.path = "man/figures/README-"
 )
 library(ggplot2)
+library(Rcpp)
 ```
 
-# colorednoise <img src='man/figures/logo.png' align="right" height="125" />
+# colorednoise <img src='man/figures/hex.png' align="right" height="125" />
 [![Travis_build_status](https://travis-ci.org/japilo/colorednoise.svg?branch=master)](https://travis-ci.org/japilo/colorednoise)
 [![CRAN_version](https://www.r-pkg.org/badges/version/colorednoise)](https://cran.r-project.org/package=colorednoise)
 [![Coverage Status](https://img.shields.io/codecov/c/github/japilo/colorednoise/master.svg)](https://codecov.io/github/japilo/colorednoise?branch=master)
 [![Download_count](https://cranlogs.r-pkg.org/badges/grand-total/colorednoise)](https://CRAN.R-project.org/package=colorednoise)
+[![Paper_doi](https://img.shields.io/badge/doi-10.1111/oik.06438-orange.svg)](https://doi.org/10.1111/oik.06438)
 
 ## Overview
 

README.md

@@ -1,13 +1,14 @@
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 
-# colorednoise <img src='man/figures/logo.png' align="right" height="125" />
+# colorednoise <img src='man/figures/hex.png' align="right" height="125" />
 
 [![Travis\_build\_status](https://travis-ci.org/japilo/colorednoise.svg?branch=master)](https://travis-ci.org/japilo/colorednoise)
 [![CRAN\_version](https://www.r-pkg.org/badges/version/colorednoise)](https://cran.r-project.org/package=colorednoise)
 [![Coverage
 Status](https://img.shields.io/codecov/c/github/japilo/colorednoise/master.svg)](https://codecov.io/github/japilo/colorednoise?branch=master)
 [![Download\_count](https://cranlogs.r-pkg.org/badges/grand-total/colorednoise)](https://CRAN.R-project.org/package=colorednoise)
+[![Paper\_doi](https://img.shields.io/badge/doi-10.1111/oik.06438-orange.svg)](https://doi.org/10.1111/oik.06438)
 
 ## Overview
 

cran-comments.md

@@ -1,7 +1,7 @@
 ## Test environments
-* local OS X install, R 3.6
-* Ubuntu 16.04 (on travis-ci), R 3.5, 3.6, devel
-* win-builder, R devel
+* local Windows 10 install, R 4.0
+* Ubuntu 16.04 (on travis-ci), R 3.6, 4.0, devel
+* macOS 10.13 (on travis-ci), R 3.6, 4.0, devel
 
 ## R CMD check results