Merge pull request #136 from DeclareDesign/cran-prep

Cran prep

R/block_cluster_two_arm_designer.R

@@ -36,7 +36,6 @@
 #' 
 #'
 
-
 block_cluster_two_arm_designer <- function(N_blocks = 20,
                                            N_clusters_in_block = 100,
                                            N_i_in_cluster = 20,
@@ -50,12 +49,12 @@ block_cluster_two_arm_designer <- function(N_blocks = 20,
                                            treatment_mean = control_mean + ate,
                                            rho = 1){  
   N <- u_0 <- Y_Z_1 <- Y_Z_0 <- blocks <- clusters <- NULL
-  if(sd_block<0) stop("sd_block must be non-negative")
-  if(sd_cluster<0) stop("sd_cluster must be non-negative")
-  if(sd_i_0<0) stop("sd_i_0 must be non-negative")
-  if(sd_i_1<0) stop("sd_i_1 must be non-negative")
-  if(prob<0 || prob>1) stop("prob must be in [0,1]")
-  if(rho<0 || rho>1) stop("prob must be in [0,1]")
+  if(sd_block < 0) stop("sd_block must be non-negative")
+  if(sd_cluster < 0) stop("sd_cluster must be non-negative")
+  if(sd_i_0 < 0) stop("sd_i_0 must be non-negative")
+  if(sd_i_1 < 0) stop("sd_i_1 must be non-negative")
+  if(prob< 0 || prob > 1) stop("prob must be in [0,1]")
+  if(rho< 0 || rho > 1) stop("prob must be in [0,1]")
   {{{    
     # M: Model
     population <- declare_population(
@@ -75,6 +74,7 @@ block_cluster_two_arm_designer <- function(N_blocks = 20,
     pos <- declare_potential_outcomes(
       Y ~ (1 - Z) * (control_mean    + u_0*sd_i_0 + u_b + u_c) + 
         Z *       (treatment_mean  + u_1*sd_i_1 + u_b + u_c) )
+    reveal <- declare_reveal()
 
     # I: Inquiry
     estimand <- declare_estimand(ATE = mean(Y_Z_1 - Y_Z_0))
@@ -88,14 +88,14 @@ block_cluster_two_arm_designer <- function(N_blocks = 20,
     estimator <- declare_estimator(
       Y ~ Z,
       estimand = estimand,
-      model = difference_in_means,
-      blocks = blocks,
+      model = lm_robust,
+      fixed_effects = ~ blocks,
       clusters = clusters
     )
 
     # Design
     block_cluster_two_arm_design <-  population + pos + estimand + assignment + 
-      declare_reveal() + estimator
+      reveal + estimator
   }}}
 
   attr(block_cluster_two_arm_design, "code") <- 

R/crossover_designer.R

@@ -10,7 +10,7 @@
 #' @param a A number. Treatment effect of interest.
 #' @param b A number. Treatment effect of crossed randomization.
 #' @param crossover A number. Size of crossover effect.
-#' @param rho A number in [0,1]. Correlation in errors of outcomes A and B.
+#' @param rho A number in [-1,1]. Correlation in errors of outcomes A and B.
 #' @return A crossover design.
 #' @author \href{https://declaredesign.org/}{DeclareDesign Team}
 #' @concept experiment
@@ -29,6 +29,8 @@ crossover_designer <- function(N = 100,
                                rho = .2) 
 {
   u_a <- u_b <- YA <- Z <- YB <- YA_Z_T2 <- YA_Z_T1 <- NULL
+  if(rho < -1 || rho > 1) stop("rho must be in [-1,1]")
+  if(N < 2) stop("N must be at least 2")
   {{{
     # M: Model
     population <- declare_population(

R/mediation_analysis_designer.R

@@ -17,8 +17,6 @@
 #' # Generate a mediation analysis design using default arguments:
 #' mediation_analysis_design <- mediation_analysis_designer()
 #'
-
-
 mediation_analysis_designer <- function(N = 100,
                                         a = .5,
                                         b = .5,

R/pretest_posttest_designer.R

@@ -26,7 +26,7 @@ pretest_posttest_designer <- function(N = 100,
 {
   u_t1 <- Y_t2_Z_1 <- Y_t2_Z_0 <- Z <- R <- Y_t1 <- Y_t2 <- NULL
   if(rho < 0 | rho > 1) stop("'rho' must be a value from 0 to 1")
-  if(attrition_rate < 0 | attrition_rate > 1) stop("'attrition_rate' must be a value from 0 to 1")
+  if(attrition_rate < 0 || attrition_rate > 1) stop("'attrition_rate' must be a value from 0 to 1")
   {{{
     # M: Model
     population <- declare_population(

R/randomized_response_designer.R

@@ -25,7 +25,10 @@ randomized_response_designer <- function(N = 1000,
                                          prevalence_rate = .1,
                                          withholding_rate = .5
 ){
-  sensitive_trait <- withholder <- Y <- Z <- NULL
+  sensitive_trait <- withholder <- Y <- Z <- bias <- NULL
+  if(prob_forced_yes < 0 || prob_forced_yes > 1)stop("prob_forced_yes must be in [0,1]")
+  if(prevalence_rate < 0 || prevalence_rate > 1)stop("prevalence_rate must be in [0,1]")
+  if(withholding_rate < 0 || withholding_rate > 1)stop("withholding_rate must be in [0,1]")
   {{{
     # M: Model
     population <- declare_population(
@@ -53,14 +56,14 @@ randomized_response_designer <- function(N = 1000,
       handler = tidy_estimator(
         function(data) with(
           data,
-          data.frame(est = (mean(Y) - prob_forced_yes) / (1 - prob_forced_yes)))),
+          data.frame(estimate = (mean(Y) - prob_forced_yes) / (1 - prob_forced_yes)))),
       estimand = estimand,
       label = "Forced Randomized Response"
     )
     estimator_direct_question <- declare_estimator(
       handler = tidy_estimator(function(data) with(
         data,
-        data.frame(est = mean(direct_answer)))),
+        data.frame(estimate = mean(direct_answer)))),
       estimand = estimand,
       label = "Direct Question"
     )
@@ -73,6 +76,13 @@ randomized_response_designer <- function(N = 1000,
       declare_reveal(Y, Z) +
       estimator_randomized_response +
       estimator_direct_question
+
+    randomized_response_design <- set_diagnosands(
+      design = randomized_response_design,
+      diagnosands = declare_diagnosands(
+        select = bias
+      ))
+
   }}}
   attr(randomized_response_design, "code") <- 
     construct_design_code(randomized_response_designer, match.call.defaults())

R/regression_discontinuity_designer.R

@@ -25,6 +25,8 @@ regression_discontinuity_designer <- function(
   poly_order = 4
 ){
   X <- noise <- Y <- NULL
+  if(! (cutoff < 1 & cutoff > 0)) stop("cutoff must be in (0,1)")
+  if(poly_order < 1) stop("poly_order must be greater than 0.")
   {{{
     # M: Model
     control <- function(X) {

R/simple_factorial_designer.R

@@ -103,11 +103,13 @@ simple_factorial_designer <- function(N = 100,
     estimator_1 <- declare_estimator(Y ~ A + B,
                                      model = lm_robust,
                                      term = c("A", "B"),
-                                     estimand = c("ate_A", "ate_B"), label = "No_Interaction")
+                                     estimand = c("ate_A", "ate_B"), 
+                                     label = "No_Interaction")
     estimator_2 <- declare_estimator(Y ~ A + B + A:B,
                                      model = lm_robust,
                                      term = "A:B", 
-                                     estimand = "interaction", label = "Interaction")
+                                     estimand = "interaction", 
+                                     label = "Interaction")
 
     # Design
     simple_factorial_design <- population + pos + 
@@ -127,13 +129,19 @@ simple_factorial_designer <- function(N = 100,
 }
 
 
-attr(simple_factorial_designer, "shiny_arguments") <- list(N = c(16, 32, 64), w_A = c(0, .5), mean_A0B1 = 0:1, mean_A1B0 = 0:1, mean_A1B1 = -1:3) 
+attr(simple_factorial_designer, "shiny_arguments") <- list(
+  N = c(16, 32, 64), w_A = c(0, .5), 
+  mean_A0B1 = 0:1, 
+  mean_A1B0 = 0:1, 
+  mean_A1B1 = -1:3) 
 
 attr(simple_factorial_designer, "tips") <-
   list(
     N = "Sample size",
     w_A = "Weight on B=1 condition for effect of A estimand",
-    mean_A0B1 = "Mean outcome for A=0, B=1"
+    mean_A1B0 = "Mean outcome for A=1, B=0",
+    mean_A0B1 = "Mean outcome for A=0, B=1",
+    mean_A1B1 = "Mean outcome for A=1, B=1"
   )
 
 attr(simple_factorial_designer, "description") <- "

R/simple_spillover_designer.R

@@ -33,17 +33,19 @@ simple_spillover_designer <- function(N_groups = 80,
                                       gamma = 2)
 {
   N <- n <- G <- zeros <- Z <- NULL
+  if(sd < 0) stop("sd must be non-negative")
+  if(N_i_group < 1 || N_groups < 1) stop("N_i_group and N_groups must be greater than 1")
   {{{
     # M: Model
     population <- declare_population(G = add_level(N = N_groups, n = N_i_group), 
-                              i = add_level(N = n, zeros = 0, ones =1))
+                              i = add_level(N = n, zeros = 0, ones = 1))
 
     dgp <- function(i, Z, G, n) (sum(Z[G == G[i]])/n[i])^gamma + rnorm(1)*sd
 
     # I: Inquiry
     estimand <- declare_estimand(Treat_1 = mean(
       sapply(1:length(G), function(i) {
-        Z_i <- (1:length(G))==i
+        Z_i <- (1:length(G)) == i
         dgp(i,Z_i,G, n) - dgp(i, zeros, G, n)})
     ), label = "estimand")
 

R/two_arm_attrition_designer.R

@@ -50,11 +50,13 @@ two_arm_attrition_designer <- function(N = 100,
                                        rho = 0
 ){
   u_R <- R_Z_1 <- R_Z_0 <- Y_Z_0 <- Y_Z_1 <- R <- Y <- NULL
+  if(rho < 0 || rho > 1) stop("rho must be in [0,1]")
   {{{
     # M: Model
     population   <- declare_population(N   = N, 
                                        u_R = rnorm(N), 
-                                       u_Y = rnorm(N, mean = rho * u_R, sd = sqrt(1 - rho^2)))
+                                       u_Y = rnorm(N, mean = rho * u_R, 
+                                                   sd = sqrt(1 - rho^2)))
     pos_R <- declare_potential_outcomes(R ~ (a_R + b_R*Z > u_R))
     pos_Y <- declare_potential_outcomes(Y ~ (a_Y + b_Y*Z > u_Y))
 

README.Rmd

@@ -1,28 +1,34 @@
 ---
 output:
   github_document
-title: "DesignLibrary"
+title: "DesignLibrary: A Library of Common Research Designs"
 ---
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 
-
-
 [![Travis-CI Build Status](https://travis-ci.org/DeclareDesign/DesignLibrary.svg?branch=master)](https://travis-ci.org/DeclareDesign/DesignLibrary)
 [![Coverage Status](https://coveralls.io/repos/github/DeclareDesign/DesignLibrary/badge.svg?branch=master)](https://coveralls.io/github/DeclareDesign/DesignLibrary?branch=master)
 
-Our design library characterizes designs informally and in code using the MIDA framework.
+**DesignLibrary** provides a library of functions that return designs built using the package **DeclareDesign**. In one line of code users can specify the parameters of individual designs and diagnose their properties. The designers can also be used to compare performance of a given design across a range of combinations of parameters, such as effect size, sample size, assignment probabilities and more.
 
----
+[Check out the online version of the library here](https://declaredesign.org/library/).
 
+---
 
 ## Installing the design library
 
-Installing the development version of **DesignLibrary** in `R`:
+To install the latest stable release of **DesignLibrary**, please ensure that you are running version 3.4 or later of R and run the following code:
 
-```{r,eval=FALSE}
-devtools::install_github("DeclareDesign/DesignLibrary", keep_source = TRUE)
+```{r, eval=F}
+install.packages("DesignLibrary")
 ```
 
+If you would like to use the latest development release of **DesignLibrary**, please ensure that you are running version 3.4 or later of R and run the following code:
 
+```{r, eval=F}
+devtools::install_github("DeclareDesign/DesignLibrary", keep_source = TRUE)
+```
+
+---
 
+This project is generously supported by a grant from the [Laura and John Arnold Foundation](http://www.arnoldfoundation.org) and seed funding from [Evidence in Governance and Politics (EGAP)](http://egap.org).

README.md

@@ -1,18 +1,30 @@
-DesignLibrary
+DesignLibrary: A Library of Common Research Designs
 ================
 
 <!-- README.md is generated from README.Rmd. Please edit that file -->
 [![Travis-CI Build Status](https://travis-ci.org/DeclareDesign/DesignLibrary.svg?branch=master)](https://travis-ci.org/DeclareDesign/DesignLibrary) [![Coverage Status](https://coveralls.io/repos/github/DeclareDesign/DesignLibrary/badge.svg?branch=master)](https://coveralls.io/github/DeclareDesign/DesignLibrary?branch=master)
 
-Our design library characterizes designs informally and in code using the MIDA framework.
+**DesignLibrary** provides a library of functions that return designs built using the package **DeclareDesign**. In one line of code users can specify the parameters of individual designs and diagnose their properties. The designers can also be used to compare performance of a given design across a range of combinations of parameters, such as effect size, sample size, assignment probabilities and more.
+
+[Check out the online version of the library here](https://declaredesign.org/library/).
 
 ------------------------------------------------------------------------
 
 Installing the design library
 -----------------------------
 
-Installing the latest version of **DesignLibrary** in `R`:
+To install the latest stable release of **DesignLibrary**, please ensure that you are running version 3.4 or later of R and run the following code:
+
+``` r
+install.packages("DesignLibrary")
+```
+
+If you would like to use the latest development release of **DesignLibrary**, please ensure that you are running version 3.4 or later of R and run the following code:
 
 ``` r
 devtools::install_github("DeclareDesign/DesignLibrary", keep_source = TRUE)
 ```
+
+------------------------------------------------------------------------
+
+This project is generously supported by a grant from the [Laura and John Arnold Foundation](http://www.arnoldfoundation.org) and seed funding from [Evidence in Governance and Politics (EGAP)](http://egap.org).

cran-comments.md

@@ -0,0 +1,17 @@
+## Test environments
+* local OS X install, R 3.5.1
+* ubuntu 14.04.5 LTS (on travis-ci), R 3.5.0
+* win-builder (devel and release)
+
+## R CMD check results
+
+0 errors | 0 warnings | 0 notes
+
+* This is a new release.
+
+## Reverse dependencies
+
+This is a new release, so there are no reverse dependencies.
+
+---
+

tests/testthat/test_designers.R

@@ -5,8 +5,6 @@ context(desc = "Testing that designers in the library work as they should")
 functions <- ls("package:DesignLibrary")
 designers <- functions[grepl("_designer\\b",functions)]
 
-# designers <- designers[-which(designers == "multi_arm_designer")]
-
 for(designer in designers){
 
   the_designer <- get(x = designer)
@@ -60,6 +58,7 @@ for(designer in designers){
   if(has_shiny){
 
     shiny_arguments <- designer_attr$shiny_arguments
+    shiny_tips <- designer_attr$tips
 
     testthat::test_that(
       desc = paste0("Any shiny_arguments in the attributes of ",designer," should all be in the its formals."),
@@ -69,7 +68,13 @@ for(designer in designers){
         ) 
       }
     )
-
+    testthat::test_that(
+      desc = paste0("Any shiny_arguments in the attributes of ",designer," have associated tips."),
+      code = {
+        expect_length(setdiff(names(shiny_arguments),names(shiny_tips)),0)
+        expect_length(setdiff(names(shiny_tips),names(shiny_arguments)),0)
+      }
+    )
   }
 }
 
@@ -108,11 +113,41 @@ test_that(desc = "mediation_analysis_designer errors when it should",
             expect_error(mediation_analysis_designer(rho = 10))
           })
 
+test_that(desc = "simple_spillover_designer errors when it should",
+          code = {
+            expect_error(simple_spillover_designer(sd = -10))
+            expect_error(simple_spillover_designer(N_i_group = -10))
+          })
+
+test_that(desc = "regression_discontinuity_designer errors when it should",
+          code = {
+            expect_error(regression_discontinuity_designer(cutoff = -10))
+            expect_error(regression_discontinuity_designer(poly_order = -10))
+          })
+
+test_that(desc = "randomized_response_designer errors when it should",
+          code = {
+            expect_error(randomized_response_designer(prob_forced_yes = -10))
+            expect_error(randomized_response_designer(prevalence_rate = -10))
+            expect_error(randomized_response_designer(withholding_rate = -10))
+          })
+
 test_that(desc = "block_cluster_two_arm_designer errors when it should",
           code = {
             expect_error(block_cluster_two_arm_designer(rho = 10))
           })
 
+test_that(desc = "crossover_designer errors when it should",
+          code = {
+            expect_error(crossover_designer(rho = 10))
+            expect_error(crossover_designer(N = -10))
+          })
+
+test_that(desc = "two_arm_attrition_designer errors when it should",
+          code = {
+            expect_error(two_arm_attrition_designer(rho = 10))
+          })
+
 test_that(desc = "pretest_posttest_designer errors when it should",
           code = {
             expect_error(pretest_posttest_designer(rho = 10))