diff --git a/.travis.yml b/.travis.yml index 59c9b42e..510fa793 100644 --- a/.travis.yml +++ b/.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: diff --git a/NAMESPACE b/NAMESPACE index 6c4768f6..5caf1b2f 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/helpers.R b/R/helpers.R index 7c96cc65..d1ad9103 100644 --- a/R/helpers.R +++ b/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="")) diff --git a/tests/testthat/test_designers.R b/tests/testthat/test_designers.R index 2b381957..2c507203 100644 --- a/tests/testthat/test_designers.R +++ b/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 = {