Skip to content

Commit

Permalink
Merge 4c0b509 into 81e46b5
Browse files Browse the repository at this point in the history
  • Loading branch information
@nfultz
nfultz committed Feb 13, 2018
2 parents 81e46b5 + 4c0b509 commit 87ebad1
Show file tree
Hide file tree
Showing 64 changed files with 1,264 additions and 767 deletions.
22 changes: 11 additions & 11 deletions DESCRIPTION
View file
Expand Up @@ -6,20 +6,20 @@ Authors@R: c(person("Graeme", "Blair", email = "graeme.blair@ucla.edu", role = c
person("Jasper", "Cooper", email = "jjc2247@columbia.edu", role = c("aut")),
person("Alexander", "Coppock", email = "alex.coppock@yale.edu", role = c("aut")),
person("Macartan", "Humphreys", email = "macartan@gmail.com", role = c("aut")),
person("Neal", "Fultz", email="nfultz@gmail.com", role = c("ctb")))
Description: Tools for characterizing, diagnosing, and pre-registering research
designs. This software provides a way for scholars to characterize research
designs formally, and then to learn about their designs before conducting the
study. This includes creating mock data and diagnosing the properties of the
design. Finalized designs can be straightforwardly pre-registered with the
package.
person("Neal", "Fultz", email = "nfultz@gmail.com", role = c("aut")))
Description: DeclareDesign is statistical software that makes it easier for researchers
to characterize and learn about the properties of research designs before implementation.
Ex ante declaration and diagnosis of designs can help researchers clarify the strengths
and limitations of their designs and to improve their properties. It can make it easier
for readers to evaluate a research strategy prior to implementation and without access
to results. It can also make it easier for designs to be shared, replicated, and critiqued.
Depends:
R (>= 3.3.0)
R (>= 3.3.0),
randomizr (>= 0.8.0),
fabricatr (>= 0.3.0),
estimatr (>= 0.2.0)
Imports:
rlang,
randomizr (>= 0.8.0),
fabricatr (>= 0.2.0),
estimatr (>= 0.2.0),
doParallel,
foreach,
doRNG,
Expand Down
11 changes: 7 additions & 4 deletions NAMESPACE
View file
Expand Up @@ -4,9 +4,11 @@ S3method(print,design)
S3method(print,diagnosis)
S3method(print,summary.design)
S3method(print,summary.diagnosis)
S3method(str,design_step)
S3method(summary,design)
S3method(summary,diagnosis)
export(cite_design)
export(conduct_design)
export(declare_assignment)
export(declare_citation)
export(declare_design)
Expand All @@ -19,18 +21,18 @@ export(declare_reveal)
export(declare_sampling)
export(delete_step)
export(diagnose_design)
export(download_design)
export(download_template)
export(draw_data)
export(execute_design)
export(execution_st)
export(fill_out)
export(get_diagnosands)
export(get_estimands)
export(get_estimates)
export(get_simulations)
export(insert_step)
export(quick_design)
export(redesign)
export(replace_step)
export(reveal_outcomes)
export(tidy_estimator)
importFrom(doParallel,registerDoParallel)
importFrom(doRNG,"%dorng%")
importFrom(estimatr,difference_in_means)
Expand Down Expand Up @@ -58,6 +60,7 @@ importFrom(rlang,eval_tidy)
importFrom(rlang,expr_text)
importFrom(rlang,f_rhs)
importFrom(rlang,is_formula)
importFrom(rlang,is_lang)
importFrom(rlang,is_quosure)
importFrom(rlang,lang_args)
importFrom(rlang,lang_fn)
Expand Down
24 changes: 1 addition & 23 deletions R/DeclareDesign.R
View file
Expand Up @@ -8,7 +8,6 @@
#' @name DeclareDesign
NULL

load <- c("fabricatr", "estimatr", "randomizr")

.onLoad <- function(libname, pkgname) {
repos = getOption("repos")
Expand All @@ -17,25 +16,4 @@ load <- c("fabricatr", "estimatr", "randomizr")
invisible(repos)
}

.onAttach <- function(...) {
needed <- load[!is_attached(load)]

if (length(needed) == 0)
return()

packageStartupMessage(paste0("Loading DeclareDesign: ", needed, collapse = "\n"))
suppressPackageStartupMessages(lapply(
needed,
library,
character.only = TRUE,
warn.conflicts = FALSE
))

##declaredesign_conflicts()
}

is_attached <- function(x) {
paste0("package:", x) %in% search()
}

globalVariables(c("Z", "Y", "est", "estimand", "p", "ci_upper", "ci_lower", "my_estimator"))
utils::globalVariables(c("Y", "Z"))
41 changes: 32 additions & 9 deletions R/aaa.R
View file
Expand Up @@ -44,12 +44,9 @@ currydata <- function(FUN, dots, addDataArg=TRUE,strictDataParam=TRUE) {
}
}

default_declaration_validation_callback <- function(decl, dots) decl

#' @importFrom rlang enquo
declaration_template <- function(..., handler, label=NULL){
#message("Declared")
d <- enquo(handler);

dots <- quos(...,label=!!label)
this <- attributes(sys.function())
Expand All @@ -61,18 +58,31 @@ declaration_template <- function(..., handler, label=NULL){



ret <- structure(currydata(handler, dots, strictDataParam=this$strictDataParam),
ret <- build_step(currydata(handler, dots, strictDataParam=this$strictDataParam),
handler=handler,
dots=dots,
label=label,
step_type=this$step_type,
causal_type=this$causal_type,
call=match.call() )
call=match.call())

if(is.function(this$validation)) ret <- this$validation(ret, handler, dots, label)
if(has_validation_fn(handler)) ret <- validate(handler, ret, dots, label)

ret
}

make_declarations <- function(default_handler, step_type, causal_type='dgp', default_label, validation=NULL, strictDataParam=TRUE) {
build_step <- function(curried_fn, handler, dots, label, step_type, causal_type, call){
structure(curried_fn,
handler=handler,
dots=dots,
label=label,
step_type=step_type,
causal_type=causal_type,
call=call,
class=c("design_step", "function"))
}

make_declarations <- function(default_handler, step_type, causal_type='dgp', default_label, strictDataParam=TRUE) {

declaration <- declaration_template

Expand All @@ -81,14 +91,27 @@ make_declarations <- function(default_handler, step_type, causal_type='dgp', def
if(!missing(default_label)) formals(declaration)$label <- default_label

structure(declaration,
class=c('Declared', 'function'),
class=c('declaration', 'function'),
step_type=step_type,
causal_type=causal_type,
validation=validation,
strictDataParam=strictDataParam)
}

########################################################################

validation_fn <- function(f){
attr(f, "validation_fn")
}

`validation_fn<-` <- with_validation_fn <- function(x, value) {
attr(x, "validation_fn") <- value
x
}

has_validation_fn <- function(f){
is.function(validation_fn(f))
}

validate <- function(handler, ret, dots, label) {
validation_fn(handler)(ret, dots, label)
}
52 changes: 34 additions & 18 deletions R/declare_assignment.R
View file
Expand Up @@ -63,28 +63,12 @@ declare_assignment <- make_declarations(assignment_function_default, "assignment
#' @importFrom rlang quos !!! lang_modify eval_tidy quo f_rhs
#' @importFrom randomizr conduct_ra obtain_condition_probabilities
assignment_function_default <-
function(data, ..., assignment_variable_name = Z) {
function(data, ..., assignment_variable_name = Z, reveal="auto") {
## draw assignment

options <- quos(...)

if (any(names(options) %in% c("block_var"))) {
if (class(f_rhs(options[["block_var"]])) == "character") {
stop("Please provide the bare (unquoted) block variable name to block_var.")
}
}
if (any(names(options) %in% c("clust_var"))) {
if (class(f_rhs(options[["clust_var"]])) == "character") {
stop("Please provide the bare (unquoted) cluster variable name to clust_var.")
}
}

assignment_variable_name <- substitute(assignment_variable_name)
if (!is.null(assignment_variable_name)) {
assignment_variable_name <- reveal_nse_helper(assignment_variable_name)
} else {
stop("Please provide a name for the assignment variable as assignment_variable_name.")
}
assignment_variable_name <- reveal_nse_helper(enquo(assignment_variable_name))

ra_call <- quo(conduct_ra(!!! options))
ra_call <- lang_modify(ra_call, N = nrow(data))
Expand All @@ -99,6 +83,38 @@ assignment_function_default <-
data[, paste0(assignment_variable_name, "_cond_prob")] <-
eval_tidy(prob_call, data = data)

outcome <- attr(data, "outcome_variable_name")
if(reveal == "auto"
&& is.character(outcome) &&
assignment_variable_name == attr(data, "assignment_variable_name")) {
data <- reveal_outcomes(data, !!outcome, !!assignment_variable_name)
}

return(data)

}

validation_fn(assignment_function_default) <- function(ret, dots, label){

if ("blocks" %in% names(dots)) {
if (class(f_rhs(dots[["blocks"]])) == "character") {
declare_time_error("Must provide the bare (unquoted) block variable name to blocks.", ret)
}
}

if ("clusters" %in% names(dots)) {
if (class(f_rhs(dots[["clusters"]])) == "character") {
declare_time_error("Must provide the bare (unquoted) cluster variable name to clusters.", ret)
}
}

if("assignment_variable_name" %in% names(dots)){
if (class(f_rhs(dots[["assignment_variable_name"]])) == "NULL") {
declare_time_error("Must provide assignment_variable_name.", ret)
}
}

ret
}


44 changes: 23 additions & 21 deletions R/declare_design.R
View file
Expand Up @@ -17,7 +17,7 @@
# f(mtcars)

#' @importFrom rlang quos lang_fn lang_modify eval_tidy
callquos_to_step <- function(step_call) {
callquos_to_step <- function(step_call, label="") {
## this function allows you to put any R expression
## such a dplyr::mutate partial call
## into the causal order, i.e.
Expand All @@ -43,17 +43,18 @@ callquos_to_step <- function(step_call) {

dots <- quos(!!data_name := data, !!!dots)

quo <- quo(currydata(fun, !!!dots))
#quo <- quo(currydata(fun, !!!dots))

curried <- currydata(fun, dots)

# curried <- eval_tidy(quo)

build_step(curried, handler=fun, dots=dots, label, step_type="wrapped", causal_type="dgp", call=step_call)

structure(curried,
call = step_call[[2]],
step_type = "wrapped",
causal_type="dgp")
# structure(curried,
# call = step_call[[2]],
# step_type = "wrapped",
# causal_type="dgp")

}

Expand Down Expand Up @@ -129,28 +130,23 @@ callquos_to_step <- function(step_call) {
declare_design <- function(...) {

qs <- quos(...)
qs <- maybe_add_labels(qs)
qnames <- names(qs)

ret <- structure(list(), class="design")
ret <- structure(vector("list", length(qs)), call=match.call(), class="design")

names(ret)[qnames != ""] <- qnames[qnames != ""]

if(getOption("DD.debug.declare_design", FALSE)) browser()

for(i in seq_along(qs)) {


#wrap step is nasty, converts partial call to curried function
ret[[i]] <- tryCatch(
eval_tidy(qs[[i]]),
error = function(e) callquos_to_step(qs[[i]])
error = function(e) callquos_to_step(qs[[i]], qnames[[i]])
)

if(qnames[[i]] != "") {
attr(ret[[i]], "label") <- qnames[[i]]
names(ret)[i] <- qnames[[i]]
}



}

# Special case for initializing with a data.frame
Expand Down Expand Up @@ -232,17 +228,20 @@ get_modified_variables <- function(last_df = NULL, current_df) {
#'
#' summary(design)
#' @export
summary.design <- function(design) {
#' @importFrom rlang is_lang
summary.design <- function(object, ...) {

design <- object

title = NULL
authors = NULL
description = NULL
citation = NULL #cite_design(design)

get_formula_from_step <- function(step){
call <- attributes(step)$call
type <- attributes(step)$step_type
if (!is.null(call) & !is.null(type) & type != "wrapped") {
call <- attr(step, "call")
type <- attr(step, "step_type")
if (is_lang(call) && is.character(type) && type != "wrapped") {
formulae <- Filter(is_formula, lang_args(call))
if (length(formulae) == 1) {
return(formulae[[1]])
Expand Down Expand Up @@ -321,17 +320,20 @@ summary.design <- function(design) {
citation <- design[[i]]()
if(!is.character(citation)) {
title = citation$title
authors = citation$authors
authors = citation$author
description = citation$note
}
calls[[i]] <- quote(metadata)
}
}

function_types <- lapply(design, attr, "step_type")

structure(
list(variables_added = variables_added,
quantities_added = quantities_added,
variables_modified = variables_modified,
function_types = function_types,
N = N,
call = calls,
formulae = formulae,
Expand Down

0 comments on commit 87ebad1

Please sign in to comment.