Merge pull request #61 from DeclareDesign/get_design_code

Call capture.output() instead of getSrcref() to read design code

.travis.yml

@@ -13,6 +13,7 @@ env:
   - secure: vgaDWtCNkBANvIyhfL0/x4O3+s4NgcsIp0hKZmbRh3lo5uUl0bmvureGclBmeM3LEK+ER8K3uzdzCrfjARYU016EM4Q0g2RS4Q+jMO4bUJgAtqODeiPBc8cHHUD2wFU9MRWwRm/U1e/NnjprgN35OAPBjuLh3xswN1AwoYVFXF61F4/hMcs9GzPGqwWFY4AxxmaCGYAaR93VchA8aSZdzc4LdcUfVs8jU/UxM7CHS+r8w/rjZx+vtEmm3vSn7RI60OBevq7N/FM4xRasn0KxgnaUrvRjrbwIHHSzUZ/siIfJPtpfPooQo5RjYc7qoGHiwF4m21Ave9A7P3Ugq3FZKzpyOtJ2Sk2vd4Rr0uFWk/uJWJXHlOgwSCRpzK/dT7omdstyvCxbSfWXUEBdx59LWX5arB1S4+ivshXiMsxC6BDfCk3fy0f/2J4Whz0PFj4Zd5HXAzTLDTLy7+t0XXeeHhX4nsNkYqCwnuYzfm4Y89cmmGp7ZutuEkzowtSzdc7ov4miBfFRxNPPODHmgmclMwPCzL94aQyQirQ4GYmIxPu/9SlN5wieeclISDb6Tf/sis0dlBMwyu6FSvNtQwOok+vOeC2H3qLbsuAonw+h9CGF0UckdJgU9RiIzw6b17Ad6OhE2aQvSC7mfoj272PFIj1QYgpED4s08eKPJnAQAtI=
 r_github_packages:
 - DeclareDesign/DDtools
+- DeclareDesign/DeclareDesign
 after_success:
 - Rscript -e DDtools::after_build
 r_packages:

NAMESPACE

@@ -5,6 +5,7 @@ export(block_cluster_two_arm_designer)
 export(cluster_sampling_designer)
 export(construct_design_code)
 export(crossover_designer)
+export(find_triple_bracket)
 export(get_design_code)
 export(match.call.defaults)
 export(mediation_analysis_designer)

R/helpers.R

@@ -4,22 +4,46 @@
 #' @export
 #'
 get_design_code <- function(design){
-  attr(design, "code")
+  out <- attr(design, "code")
+  # out <- gsub("\\{|\\}", "", out)
+  # out <- gsub("\\\"#|\\\"\\}", "\n#", out)
+  out
 }
 
 #' @export
-construct_design_code <- function(designer, args){
-  # get the code for the design 
-  txt <- as.character(getSrcref(designer))
+find_triple_bracket <- function(f){
 
-  open <- grep("[{]{3}", txt)
-  close <- grep("[}]{3}", txt)
+  pred <- function(expr, depth=3) {
+    (depth == 0) || (
+      length(expr) > 1 &&
+        expr[[1]] == as.symbol('{') &&
+        Recall(expr[[2]], depth - 1)
+    )
+  }
 
-  if(length(open) != 1) stop("could not find opening tag in ", substitute(designer))
-  if(length(close) != 1) stop("could not find opening tag in ", substitute(designer))
+  clean <- function(ch, n=length(ch)-1) ch[2:n]
 
-  txt <- txt[seq(open + 1, close - 1)]
+  ret <- Filter(pred, body(f))
 
+  if(length(ret) == 0) "" else clean(deparse(ret[[1]][[2]][[2]]))
+
+}
+
+#' @export
+construct_design_code <- function(designer, args){
+  # get the code for the design 
+  txt <- as.character(getSrcref(designer))
+  if(length(txt)==0){
+    txt <- find_triple_bracket(designer)
+  }else{
+    open <- grep("[{]{3}", txt)
+    close <- grep("[}]{3}", txt)
+
+    if(length(open) != 1) stop("could not find opening tag in ", substitute(designer))
+    if(length(close) != 1) stop("could not find opening tag in ", substitute(designer))
+    txt <- txt[seq(open + 1, close - 1)]
+  }
+
   indentation <- strsplit(txt[1], "")[[1]]
   indentation <- indentation[cumprod(indentation == " ") == 1]
   indentation <- paste0("^", paste(indentation, collapse=""))

tests/testthat/test_designers.R

@@ -29,7 +29,7 @@ for(designer in designers){
   testthat::test_that(
     desc = paste0(designer,"'s default design runs."),
     code = {
-      expect_is(diagnose_design(one_design,sims = 5,bootstrap = F)$diagnosands,"data.frame")
+      expect_is(diagnose_design(one_design,sims = 5,bootstrap_sims = F)$diagnosands,"data.frame")
     })
 
   testthat::test_that(
@@ -44,6 +44,12 @@ for(designer in designers){
       expect_true(any(grepl("declare_design|/",design_attr$code)))
     })
 
+  testthat::test_that(
+    desc = paste0(designer, "'s default design code runs without errors"),
+    code = {
+      expect_error(eval(parse(text = get_design_code(one_design))), NA)
+    })
+
   testthat::test_that(
     desc = paste0("Code inside ",designer, " runs and creates an appropriately named design object."),
     code = {