From b6219fddeb914827b5d81280e79223f0803f012f Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 2 Nov 2017 15:31:03 -0700 Subject: [PATCH 01/47] Complete documentation of fabricate.R so it makes sense to me. --- R/fabricate.R | 121 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 92 insertions(+), 29 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 1cd97db..b831f16 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -55,57 +55,76 @@ fabricate <- N, ID_label, ...) { + + # Each level argument passed to fabricate will be stored in options + # as an unevaluated language call. options <- quos(...) + # Let's check if we have nothing but level calls. all_levels <- check_all_levels(options) + # We've got data, but it's not a data frame if (!missing(data) && !"data.frame" %in% class(data)) { + # It's not at least 2d if(is.null(dim(data))) { stop( "User provided data must be a data frame. Provided data was low dimensional." ) } + # We got something that thinks it is data, but it wasn't explicitly given as data if(!"data" %in% names(sys.call())) { stop( "The data argument must be a data object. The argument call, ", deparse(substitute(data)), ", was not a data object (e.g. a data.frame, tibble, sf object, or convertible matrix)." ) } + # Let's see if we can make it a data frame tryCatch({ data = as.data.frame(data) }, error=function(e) { + # We can't make it a data frame -- this should probably never happen, + # since it relies on something with a dim attribute not converting to + # a data frame. stop( "User provided data could not convert to a data frame." ) }) } - - # check if all the options are level calls + # They were all level calls, so we need to build the level one by one if (all_levels) { for (i in seq_along(options)) { - # Pop the data from the previous level in the current call - # Do this if there existing data to start with or - # and beginning with the second level + # If we have been passed data or if we are in at least the second level + # pass the existing data frame to the variable data_internal_ + # as an argument to the level generation call. if (i > 1 | !missing(data)) { options[[i]] <- lang_modify(options[[i]], data_internal_ = data) } - # Also do a sweet switcheroo with the level names + # Adds the variable ID_label_ to the quosure at the current level + # equal to the value of names(options)[i] -- the "variable" we're assigning + # the level to options[[i]] <- lang_modify(options[[i]], ID_label_ = names(options)[i]) - # update the current data + # Execute the current level call in the context of all the data it can see. data <- eval_tidy(options[[i]]) - } + # Return the final, assembled data. return(data) } else { + # No level calls, this is single-level data + + # No user provided data if(missing(data)) data <- NULL + # No user provided N if(missing(N)) N <- NULL + # No user provided ID_label if(missing(ID_label)) ID_label <- NULL + # Building ID label from what the user provided + # It's a language symbol -- if so, use the symbol, not the value if(is.symbol(substitute(ID_label))) { ID_label <- substitute(ID_label) if (!is.null(ID_label)) { @@ -116,7 +135,7 @@ fabricate <- # Vector of length n>1, error stop("Provided ID_label must be a character vector of length 1 or variable name.") } else if(is.vector(ID_label) & is.numeric(ID_label[1])) { - # Numeric ID_label + # Numeric ID_label -- this is OK but variable names can't be numeric warning("Provided ID_label is numeric and will be prefixed with the character \"X\"") ID_label <- as.character(ID_label) } else if(is.vector(ID_label) & is.character(ID_label[1])) { @@ -128,6 +147,7 @@ fabricate <- } } + # We have our data, N, ID_label, whether there's an ID label, and pass through any other quosure stuff fabricate_data_single_level( data = data, N = N, @@ -146,12 +166,17 @@ fabricate_data_single_level <- function(data = NULL, ..., existing_ID = FALSE, options=quos(...)) { + # The user provided nothing of what we want. if (is.null(data) == is.null(N)) { stop("Please supply either a data.frame or N and not both.") } + # They provided an N if (!is.null(N)) { + # The N is not a single integer but we're at the top level + # We know we're at the top level because fabricate_data_single_level is only called if we are if (length(N) != 1) { + # Error message explaining to the user where they messed up stop( "At the top level, ", ifelse(!is.null(ID_label), @@ -159,15 +184,18 @@ fabricate_data_single_level <- function(data = NULL, ""), "you must provide a single number to N" ) - } else if(is.numeric(N) & any(!N%%1 == 0)) { + } else if(is.numeric(N) & any(!N%%1 == 0 | N<=0)) { + # N has to be an integer above 0 stop( - "The provided N must be an integer number. Provided N was of type ", + "The provided N must be an integer number greater than 0. Provided N was of type ", typeof(N) ) } + # N is not numeric if(!is.numeric(N)) { tryCatch({ + # Let's try to force it to be numeric. N = as.numeric(N) }, error=function(e) { stop( @@ -176,74 +204,109 @@ fabricate_data_single_level <- function(data = NULL, }) } + # Set up a data frame that's blank data <- data.frame() + # There's no existing ID column because we're generating all the data. existing_ID <- FALSE } else if(!is.null(data)){ + # The user gave us data, so we have an N, it's the number of rows N <- nrow(data) } + # If there's no ID column, we'll generate one now if (!existing_ID) { + # If they didn't specify an ID label for the ID column, we just give it the name ID if(is.null(ID_label)) ID_label <- "ID" data <- genID(data, ID_label, N) } - + # Let's fab the data. fab(data, options) } -# make IDs that are nicely padded genID <- function(data, ID, N=nrow(data)){ + # Left-Pad ID variable with zeroes fmt <- paste0("%0", nchar(N), "d") + # Add it to the data frame. data[1:N, ID] <- sprintf(fmt, 1:N) data } fab <- function(data, args) { + # This was explicitly provided above but ends up getting to be implicit because we + # created the ID column with nrow(data) N. N <- nrow(data) + + # Convert the provisional DF to a list so that we can access it in the environment + # of running the formulae for the next variable + data_list = as.list(data) + + if(is.null(names(args)) || any(names(args) == "")) { + stop("All variables specified at this level should have names.") + } + + # Apparently we allow overwriting the data? + #if(any(duplicated(names(args)))) { + # stop("All variables specified at this level should be unique.") + #} + + print("Begin fab") + print(args) + for (i in names(args)) { - if(i == "") next #Unnamed args are meaningless? - - # this was changed to move costly data.frame operations inside the loop - # because previously, if you did rnorm(N) in a level - # it literally did a vector of length N, rather than doing - # it for all of the values of the level above it, i.e. if this - # this is the second level and N = 2, it made a vector of length 2 - # even though there were 5 units in the higher level so there should - # have been a vector of 5*2 = 10 - # NB: this is still not super safe; if the expression returns a thing - # of length not exactly to N it's just going to repeat it as it does - # data.frame(data_list). Usually this shouldn't be a problem but we may - # want a warning or error - data_list <- as.list(data) + # Debug to get a grip on what's going on here + print(paste0("Generating data named ", i)) + print(args[[i]]) + + # i is the variable name + # args[[i]] is the formula for this variable + # data_list contains the current working environment + + # Add a variable called N so that things have access; then evaluate the current + # formula, adding it to the environment. Store it in the working data frame data_list[[i]] <- eval_tidy(args[[i]], append(data_list, list(N=N))) - #TODO Factor this out of loop? It's expensive - data <- data.frame(data_list, stringsAsFactors = FALSE, row.names=NULL) + # If we have two arguments with exactly the same name, this will nuke the first + # in the list, allowing the next one to be accessible the next time we get to it. args[[i]] <- NULL } + data <- data.frame(data_list, stringsAsFactors = FALSE, row.names=NULL) + + # Return to the complete data frame return(data) } + check_all_levels <- function(options){ + print(options) + # Passing the options quosures + # There were no levels at all if (length(options) == 0) return(FALSE) + # get_expr returns the expression for an item in a quosure + # is_lang checks if it's a function is_function <- sapply(options, function(i) { is_lang(get_expr(i)) }) + # lang_name gets function name from a quosure + # compare this to level to see if it's a level is_level <- "level" == sapply(options[is_function], lang_name) ## function names + # Return false if we have no level calls if(length(is_level) == 0) return(FALSE) + # If some calls are levels and some aren't, we're unhappy if (any(is_level) != all(is_level)) { stop( "Arguments passed to ... must either all be calls to level() or have no calls to level()." ) } + # Confirm they're all levels is_level[1] && length(is_level) == length(options) } From 42855e266cba5b3e5c0a1539430f8d4dd72f12d5 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 3 Nov 2017 15:47:24 -0700 Subject: [PATCH 02/47] Detailed documentation of existing level function. --- R/level.R | 34 ++++++++++++++++------------------ 1 file changed, 16 insertions(+), 18 deletions(-) diff --git a/R/level.R b/R/level.R index 0153ed1..751e96e 100644 --- a/R/level.R +++ b/R/level.R @@ -9,11 +9,11 @@ level <- function(N = NULL, ...) { - # handle data that is sent from higher levels of the hierarchy - # this is done internally through data_internal_, which is passed through - # the ...; users can send data to any level through data, but is handled - # differently + # The dots take all the arguments at the current level, as well as + # the provisional working data frame, which is injected at a higher level dots <- quos(...) + + # If we were passed a working data frame, let's move it into our current level if ("data_internal_" %in% names(dots)) { data_internal_ <- eval_tidy(dots[["data_internal_"]]) dots[["data_internal_"]] <- NULL @@ -21,6 +21,8 @@ level <- data_internal_ <- NULL } + # If we were passed an ID for this level (and if not, something went wrong) + # pass it through transparently if ("ID_label_" %in% names(dots)) { ID_label <- eval_tidy(dots[["ID_label_"]]) dots[["ID_label_"]] <- NULL @@ -29,45 +31,41 @@ level <- } if (is.null(data_internal_)) { - - ## if data is not provided to fabricate, this part handles the case - ## of the top level, where data must be created for the first time + # We're at a top level case with no provided data return(fabricate_data_single_level(N=N, ID_label=ID_label, options=dots)) - } else { - # at the second level, after data is created, or at the top level if data is provided - # to fabricate, there are two case: + # We're at a second level case, or a top-level case with provided data. Two things to proceed: # 1. ID_label does not yet exist, in which case we create the level defined by ID_label by expanding dataset based on N # 2. ID label already exists, in which case we add variables to an existing level - # if there is no ID variable, expand the dataset based on the commands in N + # If we are getting a new ID label, it's a new level. if (!ID_label %in% colnames(data_internal_)) { + # Evaluate how many N we need N <- eval(substitute(N), envir = data_internal_) + # Expand the working data frame using ID_label data_internal_ <- expand_data_by_ID(data = data_internal_, ID_label = ID_label, N = N) - # now that data_internal_ is the right size, pass to "mutate", i.e., simulate data + # Having expanded and added the ID, we can fab the rest of the variables return(fabricate_data_single_level(data_internal_, NULL, ID_label, options=dots)) } else { - # otherwise assume you are adding variables to an existing level - # defined by the level ID variable that exists in the data_internal_ + # The level already exists, we are adding variables to it. - # get the set of variable names that are unique within the level you are adding vars to - # so the new vars can be a function of existing ones + # Subset the working data frame to data that matters by the level we care about level_variables <- get_unique_variables_by_level(data = data_internal_, ID_label = ID_label) - - # construct a dataset with only those variables at this level data <- unique(data_internal_[, unique(c(ID_label, level_variables)), drop = FALSE]) + # Now, fabricate the new variables at this level data <- fabricate_data_single_level(data, NULL, ID_label, existing_ID = TRUE, options=dots) + # Now, merge the new data frame into the old one to recover the variables we previously dropped return(merge( data_internal_[, colnames(data_internal_)[!(colnames(data_internal_) %in% level_variables)], drop = FALSE], From ee91b2b17e47b35619258e8583bceb34e8e5b41f Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 3 Nov 2017 15:48:43 -0700 Subject: [PATCH 03/47] Beginning of fabricate rewrite (this will break a build, expect builds to fail.) --- R/fabricate_rewrite.R | 271 ++++++++++++++++++++++++++++++++++ R/fabricate_rewrite_helpers.R | 162 ++++++++++++++++++++ 2 files changed, 433 insertions(+) create mode 100644 R/fabricate_rewrite.R create mode 100644 R/fabricate_rewrite_helpers.R diff --git a/R/fabricate_rewrite.R b/R/fabricate_rewrite.R new file mode 100644 index 0000000..9e2d9d4 --- /dev/null +++ b/R/fabricate_rewrite.R @@ -0,0 +1,271 @@ +#' Fabricate data +#' +#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +#' +#' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). +#' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. +#' @param ID_label (optional) variable name for ID variable, i.e. citizen_ID +#' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples. +#' +#' @return data.frame +#' +#' @examples +#' +#' # Draw a single-level dataset with no covariates +#' df <- fabricate(N = 100) +#' head(df) +#' +#' # Draw a single-level dataset with a covariate +#' df <- fabricate( +#' N = 100, +#' height_ft = runif(N, 3.5, 8) +#' ) +#' head(df) +#' +#' # Start with existing data +#' df <- fabricate( +#' data = df, +#' new_variable = rnorm(N) +#' ) +#' +#' # Draw a two-level hierarchical dataset +#' # containing cities within regions +#' df <- fabricate( +#' regions = level(N = 5), +#' cities = level(N = 2, pollution = rnorm(N, mean = 5))) +#' head(df) +#' +#' # Start with existing data and add variables to hierarchical data +#' # note: do not provide N when adding variables to an existing level +#' df <- fabricate( +#' data = df, +#' regions = level(watershed = sample(c(0, 1), N, replace = TRUE)), +#' cities = level(runoff = rnorm(N)) +#' ) +#' +#' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args is_lang get_expr +#' +#' @export +fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) +{ + # Store all data generation arguments in a quosure for future evaluation + # A quosure contains unevaluated formulae and function calls. + data_arguments = quos(...) + + # Fabricatr expects either a single-level function call + # or a series of level calls. You can't mix and match. + # This helper function will be TRUE if calls are all levels, FALSE + # if there are no calls or they are not levels. + all_levels = check_all_levels(data_arguments) + + # User must provide exactly one of: + # 1) One or more level calls (with or without importing their own data) + # 2) Import their own data and do not involve level calls + # 3) Provide an N without importing their own data + if(sum((!is.null(data) & !missing(data) & !all_levels), + (!is.null(N) & !missing(N)), + all_levels) != 1) { + stop( + "Fabricate can be called in one of three ways: \n 1) Provide one or more level calls, with or without existing data \n 2) Provide existing data and add new variables without adding a level \n 3) Provide an \"N\" and add new variables" + ) + } + + # User provided level calls + if(all_levels) { + # Ensure the user provided a name for each level call. + if(is.null(names(data_arguments)) | any(names(data_arguments) == "")) { + stop("You must provide a name for each level you create.") + } + + # Create a blank working environment. + working_environment = list() + + # User provided data, if any, should be preloaded into working environment + if(!is.null(data) & !missing(data)) { + working_environment[["imported_data_"]] = data + } + + # Each of data_arguments is a level call + for(i in seq_along(data_arguments)) { + # Add two variables to the argument of the current level call + # one to pass the working environment so far + # one to pass the ID_label the user intends for the level + data_arguments[[i]] = lang_modify(data_arguments[[i]], + working_environment_ = working_environment, + ID_label = names(data_arguments)[i]) + + # Execute the level build and pass it back to the current working environment. + working_environment = eval_tidy(data_arguments[[i]]) + } + + print(working_environment) + + # Return the results from the working environment + return(report_results(working_environment)) + } + + # Single level + # Sanity check and/or construct an ID label for the new data. + ID_label = handle_id(ID_label, data) + + # User passed N, not data. + if(is.null(data) | missing(data)) { + # Is the N argument passed here sane? Let's check + handle_n(N, add_level = TRUE) + + # Creating a working environment + data_arguments[["working_environment_"]] = list() + + return( + report_results( + add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) + ) + ) + } + + # User passed data + N = nrow(data) + data_arguments[["working_environment_"]] = list(imported_data_ = data) + + return( + report_results( + add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) + ) + ) +} + +add_level = function(N = NULL, ID_label = NULL, + working_environment_ = NULL, + ..., + data_arguments=quos(...)) { + + # Copy the working environment out of the data_arguments quosure and into the root. + if("working_environment_" %in% names(data_arguments)) { + working_environment_ = data_arguments[["working_environment_"]] + data_arguments[["working_environment_"]] = NULL + } + + # Copy ID_label out of the data_arguments quosure and into the root + if("ID_label" %in% names(data_arguments)) { + ID_label = data_arguments[["ID_label_"]] + data_arguments[["ID_label"]] = NULL + } + + # Check to make sure the N here is sane + handle_n(N, add_level=TRUE) + + + # User is adding a new level, but already has a working data frame. + # Shelf the working data frame and move on + if("data_frame_output_" %in% names(working_environment_)) { + # Construct the shelved version + package_df = list(data_frame_output_ = working_environment_[["data_frame_output_"]], + level_ids_ = working_environment_[["level_ids_"]], + variable_names_ = names(working_environment_[["data_frame_output_"]])) + + # Append it to the existing shelf + if("shelved_df" %in% names(working_environment_)) { + working_environment_[["shelved_df"]] = append(working_environment_[["shelved_df"]], package_df) + } else { + # Create a shelf just for this + working_environment_[["shelved_df"]][[1]] = package_df + } + + # Clear the current work-space. + working_environment_[["data_frame_output_"]] = + working_environment_[["level_ids_"]] = + working_environment_[["variable_names_"]] = NULL + } + + # User is adding a new level, but we need to sneak in the imported data first. + # When this is done, trash the imported data, because the working data frame contains it. + if("imported_data_" %in% names(working_environment_)) { + working_data_list = as.list(working_environment_[["imported_data_"]]) + working_environment_[["imported_data_"]] = NULL + } else { + working_data_list = list() + } + + # Staple in an ID column onto the data list. + if(!is.null(ID_label) && (is.null(names(working_data_list)) || !ID_label %in% names(working_data_list))) { + # First, add the column to the working data frame + working_data_list[[ID_label]] = generate_id_pad(N) + + # Next, add the ID_label to the level ids tracker + if("level_ids_" %in% names(working_environment_)) { + working_environment_[["level_ids_"]] = append(working_environment_[["level_ids_"]], ID_label) + } else { + working_environment_[["level_ids_"]][1] = ID_label + } + } + + # Loop through each of the variable generating arguments + for(i in names(data_arguments)) { + # Evaluate the formula in an environment consisting of: + # 1) The current working data list + # 2) A list that tells everyone what N means in this context. + working_data_list[[i]] = eval_tidy(data_arguments[[i]], + append(working_data_list, list(N=N))) + + # Write the variable name to the list of variable names + if("variable_names_" %in% names(working_environment_)) { + working_environment_[["variable_names_"]] = append(working_environment_[["variable_names_"]], i) + } else { + working_environment_[["variable_names_"]][1] = i + } + + # Nuke the current data argument -- if we have the same variable name created twice, + # this is OK, because it'll only nuke the current one. + data_arguments[[i]] = NULL + } + + # Before handing back data, ensure it's actually rectangular + for(i in seq_along(working_data_list)) { + if(length(working_data_list[[i]]) == 1) { + # Variable is a constant -- repeat it N times + working_data_list[[i]] = rep(working_data_list[[i]], N) + } else if(length(working_data_list[[i]]) != N) { + # Variable is not of length N. Oops. + stop("Variable lengths must all be equal to N.") + } + } + + working_environment_[["data_frame_output_"]] = data.frame(working_data_list, + stringsAsFactors=FALSE, + row.names=NULL) + + return(working_environment_) +} + +nest_level = function(N = NULL, ID_label = NULL, + working_environment_ = NULL, + ..., + data_arguments=quos(...)) { + + # Copy the working environment out of the data_arguments quosure and into the root. + if("working_environment_" %in% names(data_arguments)) { + working_environment_ = data_arguments[["working_environment_"]] + data_arguments[["working_environment_"]] = NULL + } + + # Copy ID_label out of the data_arguments quosure and into the root + if("ID_label" %in% names(data_arguments)) { + ID_label = data_arguments[["ID_label_"]] + data_arguments[["ID_label"]] = NULL + } + + # Check to make sure the N here is sane + handle_n(N, add_level=TRUE) + +} + +modify_level = function(N = NULL, ID_label = NULL, ...) { +} + +level = function(N = NULL, ID_label = NULL, ...) { + +} + +report_results = function(working_environment) { + return(working_environment[["data_frame_output_"]]) +} diff --git a/R/fabricate_rewrite_helpers.R b/R/fabricate_rewrite_helpers.R new file mode 100644 index 0000000..93179ed --- /dev/null +++ b/R/fabricate_rewrite_helpers.R @@ -0,0 +1,162 @@ +handle_id = function(ID_label, data=NULL) { + # User passed a non-symbol non-null ID_label + if(!is.null(ID_label)) { + if(is.vector(ID_label) & length(ID_label) > 1) { + # Vector of length n>1, error + stop("Provided ID_label must be a character vector of length 1 or variable name.") + } else if(is.vector(ID_label) & is.numeric(ID_label[1])) { + # Numeric ID_label -- this is OK but variable names can't be numeric + warning("Provided ID_label is numeric and will be prefixed with the character \"X\"") + ID_label <- as.character(ID_label) + } else if(is.vector(ID_label) & is.character(ID_label[1])) { + # Valid ID_label + ID_label <- as.character(ID_label) + } else if(!is.null(dim(ID_label))) { + # Higher dimensional ID_label + stop("Provided ID_label must be a character vector or variable name, not a data frame or matrix.") + } + } + + # At the end of all this, we still don't have an ID label + if(is.null(ID_label)) { + if(is.null(data) | missing(data)) { + ID_label = "ID" + } else { + # We need to come up with an ID, but there's some data, so we're not sure + tries = 0 + # "ID" isn't taken + if (!"ID" %in% names(data)) { + ID_label = "ID" + } else { + # "ID" is taken, so we're going to try some backups + while(tries < 5) { + tries = tries + 1 + candidate_label = paste0("fab_ID_", tries) + # This backup is available + if(!candidate_label %in% names(data)) { + ID_label = candidate_label + break + } + } + + # We tried all our backup IDs and still couldn't find a valid ID + if(tries >= 5 & is.null(ID_label)) { + stop( + "No ID label specified for level and supply of default ID_labels -- ID, fab_ID_1, fab_ID_2, fab_ID_3, fab_ID_4, fab_ID_5 -- all used for data columns. Please specify an ID_label for this level." + ) + } + } + } + } + + # Return the resulting ID_label + return(ID_label) +} + +handle_n = function(N, add_level=TRUE) { + # Error handling for user-supplied N + + # If they provided an N + if(!is.null(N)) { + # If this is an add_level operation, N must be a single number + if(add_level) { + if(length(N) > 1) { + stop( + "When adding a new level, the specified N must be a single number." + ) + } + } else { + # If this is not an add_level operation, there are other options + } + + # If any N is non-numeric or non-integer or negative or zero, fail. + if(is.numeric(N) & any(N%%1 | N<=0)) { + stop( + "Provided N must be a single positive integer." + ) + } + + # Coerce to numeric or fail + if(!is.numeric(N)) { + tryCatch({ + N = as.numeric(N) + }, error=function(e) { + stop( + "Provided values for N must be integer numbers" + ) + }) + } + } +} + +handle_data = function(data) { + if(!is.null(data) & !missing(data) & !"data.frame" %in% class(data)) { + # User provided data, but it's not 2D + if(is.null(dim(data))) { + stop( + "User provided data must be a data frame. Provided data was low dimensional." + ) + } + + # User provided data, but it's not a data frame, and they didn't provide it explicitly, + # so this is probably a mess-up with an implicit argument + if(!"data" %in% names(sys.call())) { + stop( + "The data argument must be a data object. The argument call, ", deparse(substitute(data)), ", was not a data object (e.g. a data.frame, tibble, sf object, or convertible matrix)." + ) + } + + # Convert user data to a data frame + tryCatch({ + data = as.data.frame(data) + }, error=function(e) { + # We can't make it a data frame -- this should probably never happen, + # since it relies on something with a dim attribute not converting to + # a data frame. + stop( + "User provided data could not convert to a data frame." + ) + }) + } + return(data) +} + +check_all_levels <- function(options){ + # Passing the options quosures + # There were no levels, or indeed arguments, at all + if (length(options) == 0) return(FALSE) + + # get_expr returns the expression for an item in a quosure + # is_lang checks if it's a function + is_function <- sapply(options, function(i) { + is_lang(get_expr(i)) + }) + + # lang_name gets function name from a quosure + func_names = sapply(options[is_function], lang_name) + + # Check to see if the function names are one of the valid level operations + is_level = sapply(func_names, function(i) { i %in% c("level", "add_level", "nest_level", "modify_level") }) + + # Return false if we have no level calls + if(length(is_level) == 0) return(FALSE) + + # If some calls are levels and some aren't, we're unhappy + if (any(is_level) != all(is_level)) { + stop( + "Arguments passed to ... must either all be calls to level() or have no calls to level()." + ) + } + + # Confirm they're all levels + is_level[1] && length(is_level) == length(options) +} + + +generate_id_pad <- function(N){ + # Left-Pad ID variable with zeroes + format_left_padded <- paste0("%0", nchar(N), "d") + + # Add it to the data frame. + return(sprintf(format_left_padded, 1:N)) +} From 40b1c85c820e568337256773e25ccbd6df882eb2 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 7 Nov 2017 15:39:12 -0800 Subject: [PATCH 04/47] nest_level and stub modify_level functionality. This build will generate a warning. --- NAMESPACE | 4 + R/fabricate_rewrite.R | 184 +++++++++++++++++++++++++--------- R/fabricate_rewrite_helpers.R | 82 ++++++++++++++- man/fabricate_revised.Rd | 58 +++++++++++ 4 files changed, 277 insertions(+), 51 deletions(-) create mode 100644 man/fabricate_revised.Rd diff --git a/NAMESPACE b/NAMESPACE index ec2b419..b9b4df5 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,10 +1,14 @@ # Generated by roxygen2: do not edit by hand export(ALL) +export(add_level_new) export(draw_binary) export(draw_discrete) export(fabricate) +export(fabricate_revised) export(level) +export(modify_level_new) +export(nest_level_new) export(resample_data) importFrom(rlang,eval_tidy) importFrom(rlang,get_expr) diff --git a/R/fabricate_rewrite.R b/R/fabricate_rewrite.R index 9e2d9d4..db96dcb 100644 --- a/R/fabricate_rewrite.R +++ b/R/fabricate_rewrite.R @@ -1,6 +1,6 @@ #' Fabricate data #' -#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +#' \code{fabricate_revised} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. #' #' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). #' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. @@ -12,41 +12,41 @@ #' @examples #' #' # Draw a single-level dataset with no covariates -#' df <- fabricate(N = 100) +#' df <- fabricate_revised(N = 100) #' head(df) #' #' # Draw a single-level dataset with a covariate -#' df <- fabricate( +#' df <- fabricate_revised( #' N = 100, #' height_ft = runif(N, 3.5, 8) #' ) #' head(df) #' #' # Start with existing data -#' df <- fabricate( +#' df <- fabricate_revised( #' data = df, #' new_variable = rnorm(N) #' ) #' #' # Draw a two-level hierarchical dataset #' # containing cities within regions -#' df <- fabricate( -#' regions = level(N = 5), -#' cities = level(N = 2, pollution = rnorm(N, mean = 5))) +#' df <- fabricate_revised( +#' regions = add_level_new(N = 5), +#' cities = nest_level_new(N = 2, pollution = rnorm(N, mean = 5))) #' head(df) #' #' # Start with existing data and add variables to hierarchical data #' # note: do not provide N when adding variables to an existing level -#' df <- fabricate( +#' df <- fabricate_revised( #' data = df, -#' regions = level(watershed = sample(c(0, 1), N, replace = TRUE)), -#' cities = level(runoff = rnorm(N)) +#' regions = modify_level_new(watershed = sample(c(0, 1), N, replace = TRUE)), +#' cities = modify_level_new(runoff = rnorm(N)) #' ) #' #' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args is_lang get_expr #' #' @export -fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) +fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) { # Store all data generation arguments in a quosure for future evaluation # A quosure contains unevaluated formulae and function calls. @@ -56,7 +56,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # or a series of level calls. You can't mix and match. # This helper function will be TRUE if calls are all levels, FALSE # if there are no calls or they are not levels. - all_levels = check_all_levels(data_arguments) + all_levels = check_all_levels_new(data_arguments) # User must provide exactly one of: # 1) One or more level calls (with or without importing their own data) @@ -98,43 +98,47 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) working_environment = eval_tidy(data_arguments[[i]]) } - print(working_environment) - # Return the results from the working environment return(report_results(working_environment)) } - # Single level + # Single level -- maybe the user provided an ID_label, maybe they didn't. # Sanity check and/or construct an ID label for the new data. ID_label = handle_id(ID_label, data) - # User passed N, not data. + # User did not pass data -- they passed N if(is.null(data) | missing(data)) { # Is the N argument passed here sane? Let's check handle_n(N, add_level = TRUE) - # Creating a working environment + # Creating a working environment that's empty (user passed no data) data_arguments[["working_environment_"]] = list() + # Run the level adder, report the results, and return return( report_results( - add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) + add_level_new(N = N, ID_label = ID_label, data_arguments = data_arguments) ) ) } - # User passed data + # User passed data, not N + # First, let's dynamically get N from the number of rows N = nrow(data) + + # Now, let's load the data into our working environment data_arguments[["working_environment_"]] = list(imported_data_ = data) + # Run the level adder, report the results, and return return( report_results( - add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) + add_level_new(N = N, ID_label = ID_label, data_arguments = data_arguments) ) ) } -add_level = function(N = NULL, ID_label = NULL, +#' @export +add_level_new = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments=quos(...)) { @@ -154,7 +158,6 @@ add_level = function(N = NULL, ID_label = NULL, # Check to make sure the N here is sane handle_n(N, add_level=TRUE) - # User is adding a new level, but already has a working data frame. # Shelf the working data frame and move on if("data_frame_output_" %in% names(working_environment_)) { @@ -168,7 +171,7 @@ add_level = function(N = NULL, ID_label = NULL, working_environment_[["shelved_df"]] = append(working_environment_[["shelved_df"]], package_df) } else { # Create a shelf just for this - working_environment_[["shelved_df"]][[1]] = package_df + working_environment_[["shelved_df"]] = list(package_df) } # Clear the current work-space. @@ -180,8 +183,12 @@ add_level = function(N = NULL, ID_label = NULL, # User is adding a new level, but we need to sneak in the imported data first. # When this is done, trash the imported data, because the working data frame contains it. if("imported_data_" %in% names(working_environment_)) { + num_obs_imported = nrow(working_environment_[["imported_data_"]]) working_data_list = as.list(working_environment_[["imported_data_"]]) working_environment_[["imported_data_"]] = NULL + if(is.null(N)) { + N = num_obs_imported + } } else { working_data_list = list() } @@ -192,11 +199,8 @@ add_level = function(N = NULL, ID_label = NULL, working_data_list[[ID_label]] = generate_id_pad(N) # Next, add the ID_label to the level ids tracker - if("level_ids_" %in% names(working_environment_)) { - working_environment_[["level_ids_"]] = append(working_environment_[["level_ids_"]], ID_label) - } else { - working_environment_[["level_ids_"]][1] = ID_label - } + working_environment_ = add_level_id(working_environment_, ID_label) + working_environment_ = add_variable_name(working_environment_, ID_label) } # Loop through each of the variable generating arguments @@ -204,15 +208,12 @@ add_level = function(N = NULL, ID_label = NULL, # Evaluate the formula in an environment consisting of: # 1) The current working data list # 2) A list that tells everyone what N means in this context. + print(N) working_data_list[[i]] = eval_tidy(data_arguments[[i]], append(working_data_list, list(N=N))) # Write the variable name to the list of variable names - if("variable_names_" %in% names(working_environment_)) { - working_environment_[["variable_names_"]] = append(working_environment_[["variable_names_"]], i) - } else { - working_environment_[["variable_names_"]][1] = i - } + working_environment_ = add_variable_name(working_environment_, i) # Nuke the current data argument -- if we have the same variable name created twice, # this is OK, because it'll only nuke the current one. @@ -220,15 +221,7 @@ add_level = function(N = NULL, ID_label = NULL, } # Before handing back data, ensure it's actually rectangular - for(i in seq_along(working_data_list)) { - if(length(working_data_list[[i]]) == 1) { - # Variable is a constant -- repeat it N times - working_data_list[[i]] = rep(working_data_list[[i]], N) - } else if(length(working_data_list[[i]]) != N) { - # Variable is not of length N. Oops. - stop("Variable lengths must all be equal to N.") - } - } + working_data_list = check_rectangular(working_data_list, N) working_environment_[["data_frame_output_"]] = data.frame(working_data_list, stringsAsFactors=FALSE, @@ -237,7 +230,8 @@ add_level = function(N = NULL, ID_label = NULL, return(working_environment_) } -nest_level = function(N = NULL, ID_label = NULL, +#' @export +nest_level_new = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments=quos(...)) { @@ -254,18 +248,114 @@ nest_level = function(N = NULL, ID_label = NULL, data_arguments[["ID_label"]] = NULL } + # Check to make sure we have a data frame to nest on. + if(is.null(dim(working_environment_[["data_frame_output_"]]))) { + stop("You can't nest a level if there is no level to nest inside") + } + # Check to make sure the N here is sane - handle_n(N, add_level=TRUE) + # Pass the working environment because N might not be a singleton here + handle_n(N, add_level=FALSE, working_environment = working_environment_) -} + # We need to expand the size of the current working data frame by copying it + # Let's start by getting the size of the current working data frame + past_level_N = nrow(working_environment_[["data_frame_output_"]]) + # And now make an index set 1:past_level_N + indices = seq_len(past_level_N) + + # We're now going to modify the index set to take into account the expansion + # If N is a single number, then we repeat each index N times + # If N is of length past_level_N, then we repeat each index N_i times. + # For r's rep, the each / times arguments have odd behaviour that necessitates this approach + if(length(N)==1) rep_indices = rep(indices, each=N) + else rep_indices = rep(indices, times=N) + + # current_N = N # This would store the intended N value for the level + # Update N to the new length. + N = length(rep_indices) + + # Expand the data frame by duplicating the indices and then coerce the data frame + # to a list -- we do this to basically make variables accessible in the namespace. + working_data_list = as.list(working_environment_[["data_frame_output_"]][rep_indices, , drop=FALSE]) + + ### Everything after here is non-unique to nest_level versus add_level -- need to think about how to + ### refactor this out. + + # Staple in an ID column onto the data list. + if(!is.null(ID_label) && (is.null(names(working_data_list)) || !ID_label %in% names(working_data_list))) { + # First, add the column to the working data frame + working_data_list[[ID_label]] = generate_id_pad(N) + + working_environment_ = add_level_id(working_environment_, ID_label) + working_environment_ = add_variable_name(working_environment_, ID_label) + } + + # Loop through each of the variable generating arguments + for(i in names(data_arguments)) { + # Evaluate the formula in an environment consisting of: + # 1) The current working data list + # 2) A list that tells everyone what N means in this context. + working_data_list[[i]] = eval_tidy(data_arguments[[i]], + append(working_data_list, list(N=N))) + + # Write the variable name to the list of variable names + working_environment_ = add_variable_name(working_environment_, i) -modify_level = function(N = NULL, ID_label = NULL, ...) { + # Nuke the current data argument -- if we have the same variable name created twice, + # this is OK, because it'll only nuke the current one. + data_arguments[[i]] = NULL + } + + # Before handing back data, ensure it's actually rectangular + working_data_list = check_rectangular(working_data_list, N) + + # Overwrite the working data frame. + working_environment_[["data_frame_output_"]] = data.frame(working_data_list, + stringsAsFactors=FALSE, + row.names=NULL) + + return(working_environment_) } -level = function(N = NULL, ID_label = NULL, ...) { +#' @export +modify_level_new = function(N = NULL, + ID_label = NULL, + ..., + data_arguments=quos(...)) { + # Copy the working environment out of the data_arguments quosure and into the root. + if("working_environment_" %in% names(data_arguments)) { + working_environment_ = data_arguments[["working_environment_"]] + data_arguments[["working_environment_"]] = NULL + } + + # Copy ID_label out of the data_arguments quosure and into the root + if("ID_label" %in% names(data_arguments)) { + ID_label = data_arguments[["ID_label_"]] + data_arguments[["ID_label"]] = NULL + } + + # Need to supply an ID_label, otherwise we have no idea what to modify. + if(is.null(ID_label)) { + stop("You can't modify a level without a known level ID variable.") + } + + # Error handling -- what if the user doesn't provide a level to modify? + if(!ID_label %in% working_environment_[["level_ids_"]]) { + # Stopping because right now we don't actually know what the levels are, + # since user could provide data instead of building it. + # stop("Level you're modifying is not a level in the working environment.") + } + + # Stub, this doesn't do anything yet + return(working_environment_) +} +# Overload the level command +level_new = function(N = NULL, ID_label = NULL, ...) { + # Stub, this doesn't do anything yet } +# Dummy helper function that just extracts the working data frame from the environment. report_results = function(working_environment) { return(working_environment[["data_frame_output_"]]) } diff --git a/R/fabricate_rewrite_helpers.R b/R/fabricate_rewrite_helpers.R index 93179ed..d99e6c6 100644 --- a/R/fabricate_rewrite_helpers.R +++ b/R/fabricate_rewrite_helpers.R @@ -1,3 +1,5 @@ +# Checks if an ID label is sane, warns or errors if not. +# Generates an ID label if there isn't one provided. handle_id = function(ID_label, data=NULL) { # User passed a non-symbol non-null ID_label if(!is.null(ID_label)) { @@ -53,7 +55,8 @@ handle_id = function(ID_label, data=NULL) { return(ID_label) } -handle_n = function(N, add_level=TRUE) { +# Checks if a supplied N is sane for the context it's in +handle_n = function(N, add_level=TRUE, working_environment=NULL) { # Error handling for user-supplied N # If they provided an N @@ -66,7 +69,31 @@ handle_n = function(N, add_level=TRUE) { ) } } else { + if(length(N) > 1) { + # User specified more than one N; presumably this is one N for each level of the + # last level variable + + # What's the last level variable? + name_of_last_level = working_environment[["level_ids_"]][length( + working_environment[["level_ids_"]])] + + # What are the unique values? + unique_values_of_last_level = unique( + working_environment[["data_frame_output_"]][[name_of_last_level]] + ) + + if(length(N) != length(unique_values_of_last_level)) { + stop( + "N must be either a single number or a vector of length ", + length(unique_values_of_last_level), + " (one value for each possible level of ", + name_of_last_level, + ")" + ) + } + } # If this is not an add_level operation, there are other options + } # If any N is non-numeric or non-integer or negative or zero, fail. @@ -89,6 +116,8 @@ handle_n = function(N, add_level=TRUE) { } } +# Checks if the user-provided data is sane +# errors if not. handle_data = function(data) { if(!is.null(data) & !missing(data) & !"data.frame" %in% class(data)) { # User provided data, but it's not 2D @@ -121,7 +150,9 @@ handle_data = function(data) { return(data) } -check_all_levels <- function(options){ +# Function to check if every argument in a quosure options +# is a level call. +check_all_levels_new <- function(options){ # Passing the options quosures # There were no levels, or indeed arguments, at all if (length(options) == 0) return(FALSE) @@ -136,7 +167,10 @@ check_all_levels <- function(options){ func_names = sapply(options[is_function], lang_name) # Check to see if the function names are one of the valid level operations - is_level = sapply(func_names, function(i) { i %in% c("level", "add_level", "nest_level", "modify_level") }) + is_level = sapply(func_names, function(i) { i %in% c("level", + "add_level_new", + "nest_level_new", + "modify_level_new") }) # Return false if we have no level calls if(length(is_level) == 0) return(FALSE) @@ -144,7 +178,7 @@ check_all_levels <- function(options){ # If some calls are levels and some aren't, we're unhappy if (any(is_level) != all(is_level)) { stop( - "Arguments passed to ... must either all be calls to level() or have no calls to level()." + "Arguments passed to ... must either all be calls to create or modify levels, or else none of them must be." ) } @@ -153,6 +187,7 @@ check_all_levels <- function(options){ } +# Generates IDs from 1:N with zero left padding for visual display. generate_id_pad <- function(N){ # Left-Pad ID variable with zeroes format_left_padded <- paste0("%0", nchar(N), "d") @@ -160,3 +195,42 @@ generate_id_pad <- function(N){ # Add it to the data frame. return(sprintf(format_left_padded, 1:N)) } + +# Try to overwrite R's recycling of vector operations to ensure the initial +# data is rectangular -- needs an N to ensure that constants do get recycled. +check_rectangular = function(working_data_list, N) { + for(i in seq_along(working_data_list)) { + if(length(working_data_list[[i]]) == 1) { + # Variable is a constant -- repeat it N times + working_data_list[[i]] = rep(working_data_list[[i]], N) + } else if(length(working_data_list[[i]]) != N) { + # Variable is not of length N. Oops. + stop("Variable lengths must all be equal to N.") + } + } + return(working_data_list) +} + +# Add a level ID to a working environment +add_level_id = function(working_environment_, ID_label) { + # Add or create level ID list + if("level_ids_" %in% names(working_environment_)) { + working_environment_[["level_ids_"]] = append(working_environment_[["level_ids_"]], ID_label) + } else { + working_environment_[["level_ids_"]] = c(ID_label) + } + + return(working_environment_) +} + +# Add a variable name to a working environment +add_variable_name = function(working_environment_, variable_name) { + # Add or create variable name list. + if("variable_names_" %in% names(working_environment_)) { + working_environment_[["variable_names_"]] = append(working_environment_[["variable_names_"]], variable_name) + } else { + working_environment_[["variable_names_"]] = c(variable_name) + } + + return(working_environment_) +} diff --git a/man/fabricate_revised.Rd b/man/fabricate_revised.Rd new file mode 100644 index 0000000..d450281 --- /dev/null +++ b/man/fabricate_revised.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fabricate_rewrite.R +\name{fabricate_revised} +\alias{fabricate_revised} +\title{Fabricate data} +\usage{ +fabricate_revised(data = NULL, N = NULL, ID_label = NULL, ...) +} +\arguments{ +\item{data}{(optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} + +\item{N}{(optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset.} + +\item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} + +\item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples.} +} +\value{ +data.frame +} +\description{ +\code{fabricate_revised} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +} +\examples{ + +# Draw a single-level dataset with no covariates +df <- fabricate_revised(N = 100) +head(df) + +# Draw a single-level dataset with a covariate +df <- fabricate_revised( + N = 100, + height_ft = runif(N, 3.5, 8) +) +head(df) + +# Start with existing data +df <- fabricate_revised( + data = df, + new_variable = rnorm(N) +) + +# Draw a two-level hierarchical dataset +# containing cities within regions +df <- fabricate_revised( + regions = add_level_new(N = 5), + cities = nest_level_new(N = 2, pollution = rnorm(N, mean = 5))) +head(df) + +# Start with existing data and add variables to hierarchical data +# note: do not provide N when adding variables to an existing level +df <- fabricate_revised( + data = df, + regions = modify_level_new(watershed = sample(c(0, 1), N, replace = TRUE)), + cities = modify_level_new(runoff = rnorm(N)) +) + +} From 073935cfe18b4a1b0e53bd0490d961b720a22c75 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 9 Nov 2017 17:05:22 -0800 Subject: [PATCH 05/47] Major speed improvement on modify level calls in the original codebase, will implement similar strategy in the refactor in next few commits. This will generate a warning or error on the build. --- R/level.R | 14 ++++++-- R/utilities.R | 91 ++++++++++++++++++++++++++++++++++++++++++++++----- 2 files changed, 94 insertions(+), 11 deletions(-) diff --git a/R/level.R b/R/level.R index 751e96e..4569133 100644 --- a/R/level.R +++ b/R/level.R @@ -55,14 +55,24 @@ level <- } else { # The level already exists, we are adding variables to it. + # Which variables could we possibly care about in this level call? + unique_variables_to_write_to = unname(unlist(get_symbols_from_quosure(dots))) + # Subset the working data frame to data that matters by the level we care about + # based on the level call we have. level_variables <- - get_unique_variables_by_level(data = data_internal_, ID_label = ID_label) + get_unique_variables_by_level(data = data_internal_, + ID_label = ID_label, + superset=unique_variables_to_write_to) + + merged_set = unique(c(ID_label, level_variables)) + data <- - unique(data_internal_[, unique(c(ID_label, level_variables)), + unique(data_internal_[, merged_set[merged_set != ""], drop = FALSE]) # Now, fabricate the new variables at this level + data <- fabricate_data_single_level(data, NULL, ID_label, existing_ID = TRUE, options=dots) # Now, merge the new data frame into the old one to recover the variables we previously dropped diff --git a/R/utilities.R b/R/utilities.R index 3f6e5f4..1e25b83 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -1,12 +1,85 @@ -get_unique_variables_by_level <- function(data, ID_label) { - ## identify variables that do not vary within ID_label - ## maybe there is a faster way to do this? - level_variables <- - sapply(colnames(data)[!colnames(data) %in% ID_label], function(i) - max(tapply(data[, i], list(data[, ID_label]), - function(x) - length(unique(x)))) == 1) - return(names(level_variables)[level_variables]) +get_symbols_from_expression = function(l_arg) { + # We have some sort of language expression in R, let's extract + # the symbols it's going to refer to + + if(is.symbol(l_arg)) { + # If it's a symbol, return the symbol + return(unname(l_arg)) + } else if(is.language(l_arg)) { + # If it's a language call, then we need to unpack some more + # Extract the language from the language call + recurse = lang_args(l_arg) + # Iterate through each part of the language, recursively calling this function + # Results are a list, so unlist and unname to flatten + temp = unname(unlist(lapply(recurse, function(i) { process_lang_args(i) }))) + return(temp) + } else { + # It's something else? This might happen if the base level call + # is numeric or whatever. We are only interested in variable nanes. + } +} + +get_symbols_from_quosure = function(quosure) { + # Given a quosure, what symbols will that quosure attempt to read when it + # is evaluated? + meta_results = lapply(quosure, function(i) { + # For each term in the quosure, get the language call out of the term: + expression = get_expr(i) + # Get the arguments out of that language call + thing = lang_args(expression) + # Now, for each argument try to extract the symbols + results = lapply(thing, function(x) { get_symbols_from_expression(x) }) + + # We are going to unlist, convert to characters (this is necessary to coerce + # results into a vector), and then remove duplicates + return(unique( + as.character( + unlist( + results)))) + }) + + return(meta_results) +} + +get_unique_variables_by_level <- function(data, ID_label, superset=NULL) { + # Superset contains a vector of character strings that contain variables + # the modify level call is going to write. Some of these may be columns + # in the data frame, others might not be. If superset is specified, + # then we definitely only want to check those variables + if(!is.null(superset)) { + names_to_check = intersect(colnames(data), superset) + } else { + names_to_check = colnames(data)[-which(colnames(data)==ID_label)] + } + + # It turns out the call isn't going to use any variables at all! + if(!length(names_to_check)) { return("") } + + # Iterate through each column of interest + # Per column, split that column's data into a list. The split indices come from the level indicator. + # Now, run a function which checks the unique length of each tranch + # Unlist the result to get a vector of TRUE or FALSE for each tranch of the list. + # If all tranches are TRUE, then the column has unique values based on the level's level. + # Take the results per column, unlist those, strip the names (if any) from the variables. + # Now extract the column names for the columns for which this was true. Return as a vector. + + # Performance is around 22% faster than existing code for small dataset + level_variables = names_to_check[ + unname(unlist(lapply(names_to_check, + function(i) { + all(unlist( + lapply( + split(data[, i], data[, ID_label]), + function(x) { + length(unique(x))==1 + } + ) + )) + } + ) + )) + ] + return(level_variables) } expand_data_by_ID <- function(data, ID_label, N) { From 35d465d82a1ad0705abbb26437007816a8f5aca5 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Mon, 13 Nov 2017 14:04:49 -0800 Subject: [PATCH 06/47] Implemented modify_level_new and improved speed of several steps. This build should generate a warning. --- R/fabricate.R | 14 ---- R/fabricate_rewrite.R | 189 +++++++++++++++++++++++++++++++++++++----- R/level.R | 10 ++- R/utilities.R | 8 +- 4 files changed, 183 insertions(+), 38 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index b831f16..a71925e 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -245,19 +245,7 @@ fab <- function(data, args) { stop("All variables specified at this level should have names.") } - # Apparently we allow overwriting the data? - #if(any(duplicated(names(args)))) { - # stop("All variables specified at this level should be unique.") - #} - - print("Begin fab") - print(args) - for (i in names(args)) { - # Debug to get a grip on what's going on here - print(paste0("Generating data named ", i)) - print(args[[i]]) - # i is the variable name # args[[i]] is the formula for this variable # data_list contains the current working environment @@ -280,8 +268,6 @@ fab <- function(data, args) { check_all_levels <- function(options){ - print(options) - # Passing the options quosures # There were no levels at all if (length(options) == 0) return(FALSE) diff --git a/R/fabricate_rewrite.R b/R/fabricate_rewrite.R index db96dcb..5442fd0 100644 --- a/R/fabricate_rewrite.R +++ b/R/fabricate_rewrite.R @@ -102,12 +102,12 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) return(report_results(working_environment)) } - # Single level -- maybe the user provided an ID_label, maybe they didn't. - # Sanity check and/or construct an ID label for the new data. - ID_label = handle_id(ID_label, data) - # User did not pass data -- they passed N if(is.null(data) | missing(data)) { + # Single level -- maybe the user provided an ID_label, maybe they didn't. + # Sanity check and/or construct an ID label for the new data. + ID_label = handle_id(ID_label, data) + # Is the N argument passed here sane? Let's check handle_n(N, add_level = TRUE) @@ -185,7 +185,9 @@ add_level_new = function(N = NULL, ID_label = NULL, if("imported_data_" %in% names(working_environment_)) { num_obs_imported = nrow(working_environment_[["imported_data_"]]) working_data_list = as.list(working_environment_[["imported_data_"]]) + working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) working_environment_[["imported_data_"]] = NULL + # User didn't specify an N, so get it from the current data. if(is.null(N)) { N = num_obs_imported } @@ -194,13 +196,18 @@ add_level_new = function(N = NULL, ID_label = NULL, } # Staple in an ID column onto the data list. - if(!is.null(ID_label) && (is.null(names(working_data_list)) || !ID_label %in% names(working_data_list))) { - # First, add the column to the working data frame - working_data_list[[ID_label]] = generate_id_pad(N) - - # Next, add the ID_label to the level ids tracker - working_environment_ = add_level_id(working_environment_, ID_label) - working_environment_ = add_variable_name(working_environment_, ID_label) + if(!is.null(ID_label)) { + if(is.null(names(working_data_list)) || !ID_label %in% names(working_data_list)) { + # First, add the column to the working data frame + working_data_list[[ID_label]] = generate_id_pad(N) + + # Next, add the ID_label to the level ids tracker + working_environment_ = add_level_id(working_environment_, ID_label) + working_environment_ = add_variable_name(working_environment_, ID_label) + } else { + # If the ID label was specified but already exists; + working_environment_ = add_level_id(working_environment_, ID_label) + } } # Loop through each of the variable generating arguments @@ -208,7 +215,6 @@ add_level_new = function(N = NULL, ID_label = NULL, # Evaluate the formula in an environment consisting of: # 1) The current working data list # 2) A list that tells everyone what N means in this context. - print(N) working_data_list[[i]] = eval_tidy(data_arguments[[i]], append(working_data_list, list(N=N))) @@ -250,7 +256,14 @@ nest_level_new = function(N = NULL, ID_label = NULL, # Check to make sure we have a data frame to nest on. if(is.null(dim(working_environment_[["data_frame_output_"]]))) { - stop("You can't nest a level if there is no level to nest inside") + if("imported_data_" %in% names(working_environment_)) { + working_environment_[["data_frame_output_"]] = working_environment_[["imported_data_"]] + working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) + working_environment_[["imported_data_"]] = NULL + } else { + stop("You can't nest a level if there is no level to nest inside") + } + } # Check to make sure the N here is sane @@ -318,10 +331,13 @@ nest_level_new = function(N = NULL, ID_label = NULL, } #' @export +#' modify_level_new = function(N = NULL, ID_label = NULL, + working_environment_ = NULL, ..., data_arguments=quos(...)) { + # Copy the working environment out of the data_arguments quosure and into the root. if("working_environment_" %in% names(data_arguments)) { working_environment_ = data_arguments[["working_environment_"]] @@ -335,18 +351,151 @@ modify_level_new = function(N = NULL, } # Need to supply an ID_label, otherwise we have no idea what to modify. + # You actually can, though! It'd just be per unit if(is.null(ID_label)) { - stop("You can't modify a level without a known level ID variable.") + stop("You can't modify a level without a known level ID variable. If you are adding nested data, please use add_level") } - # Error handling -- what if the user doesn't provide a level to modify? - if(!ID_label %in% working_environment_[["level_ids_"]]) { - # Stopping because right now we don't actually know what the levels are, - # since user could provide data instead of building it. - # stop("Level you're modifying is not a level in the working environment.") + # First, establish that if we have no working data frame, we can't continue + if(is.null(dim(working_environment_[["data_frame_output_"]]))) { + if("imported_data_" %in% names(working_environment_)) { + working_environment_[["data_frame_output_"]] = working_environment_[["imported_data_"]] + working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) + working_environment_[["imported_data_"]] = NULL + } else { + stop("You can't modify a level if there is no working data frame to modify: you must either load pre-existing data or generate some data before modifying.") + } } - # Stub, this doesn't do anything yet + # There are two possibilities. One is that we are modifying the lowest level of data. + # In which case, we simply add variables, like if someone called add_level with a dataset. + # To check if that's the world we're in, check if we have any duplicates in the ID label: + if(!anyDuplicated(working_environment_[["data_frame_output_"]][[ID_label]])) { + # There is no subsetting going on, but modify_level was used anyway. + N = nrow(working_environment_[["data_frame_output_"]]) + + # Coerce the working data frame into a list + working_data_list = as.list(working_environment_[["data_frame_output_"]]) + + # Now loop over the variable creation. + for(i in names(data_arguments)) { + # Evaluate the formula in an environment consisting of: + # 1) The current working data list + # 2) A list that tells everyone what N means in this context. + # Store it in the current environment + working_data_list[[i]] = eval_tidy(data_arguments[[i]], + append(working_data_list, list(N=N))) + + # Write the variable name to the list of variable names + working_environment_ = add_variable_name(working_environment_, i) + + # Nuke the current data argument -- if we have the same variable name created twice, + # this is OK, because it'll only nuke the current one. + data_arguments[[i]] = NULL + } + + # Before handing back data, ensure it's actually rectangular + working_data_list = check_rectangular(working_data_list, N) + + # Overwrite the working data frame. + working_environment_[["data_frame_output_"]] = data.frame(working_data_list, + stringsAsFactors=FALSE, + row.names=NULL) + + # Return results + return(working_environment_) + } + + # If we're here, then at least some subsetting is used in the modify call + # first, subset to unique observations, then generate new data, then re-expand. + # To do this, we need a mapping between observations and unique observations. + # First, get the unique values of the level: + unique_values_of_level = unique(working_environment_[["data_frame_output_"]][[ID_label]]) + + # Pre-allocate the mapping vector + index_maps = numeric(length(working_environment_[["data_frame_output_"]][[ID_label]])) + # Iterate along the unique values of the level + for(i in seq_along(unique_values_of_level)) { + # Any obs that matches the level matching this i will be a duplicate of this i. + index_maps[ + working_environment_[["data_frame_output_"]][[ID_label]] == unique_values_of_level[i] + ] = i + } + + # Now, which variables are we going to write to (do we need to subset)? + write_variables = unname(unlist(get_symbols_from_quosure(data_arguments))) + # Remove the ID label from the variables we are going to write to. + write_variables = setdiff(write_variables, ID_label) + # Let's also remove anything that doesn't seem to be a valid variable + write_variables = write_variables[write_variables %in% names(working_environment_[["data_frame_output_"]])] + + # Level unique variables: + level_unique_variables = get_unique_variables_by_level( + data = working_environment_[["data_frame_output_"]], + ID_label = ID_label, + superset=write_variables) + + # Error if we try to write using a variable that's not unique to the level. + if(length(level_unique_variables) != length(write_variables) & + length(write_variables) != 0) { + stop("Your modify_level command attempts to generate a new variable at the level \"", ID_label, + "\" but requires reading from the existing variable(s) [", + paste(setdiff(write_variables, level_unique_variables), collapse=", "), + "] which are not defined at the level \"", ID_label, + "\"\n\n To prevent this error, you may modify the data at the level of interest, or change the definition of your new variables.") + } + + # Our subset needs these columns -- the level variable, all the unique variables + # we are going to use to write, and then in case the latter is "", remove that dummy + # obs.: + merged_set = unique(c(ID_label, setdiff(level_unique_variables, ""))) + + # And these rows: + row_indices_keep = !duplicated(working_environment_[["data_frame_output_"]][[ID_label]]) + + # Now subset it: + working_subset = working_environment_[["data_frame_output_"]][row_indices_keep, + merged_set, + drop=FALSE] + + # Set the N variable correctly moving forward: + super_N = nrow(working_environment_[["data_frame_output_"]]) + N = nrow(working_subset) + + # Get the subset into a list: + working_data_list = as.list(working_subset) + # And our original working data frame: + super_working_data_list = as.list(working_environment_[["data_frame_output_"]]) + + # Now loop + for(i in names(data_arguments)) { + # Evaluate the formula in an environment consisting of: + # 1) The current working data list + # 2) A list that tells everyone what N means in this context. + # Store it in the current environment + working_data_list[[i]] = eval_tidy(data_arguments[[i]], + append(working_data_list, list(N=N))) + + # Write the variable name to the list of variable names + working_environment_ = add_variable_name(working_environment_, i) + + # Expand the variable and store it in the actual, expanded environment + super_working_data_list[[i]] = working_data_list[[i]][index_maps] + + # Nuke the current data argument -- if we have the same variable name created twice, + # this is OK, because it'll only nuke the current one. + data_arguments[[i]] = NULL + } + + # Before handing back data, ensure it's actually rectangular + super_working_data_list = check_rectangular(super_working_data_list, super_N) + + # Overwrite the working data frame. + working_environment_[["data_frame_output_"]] = data.frame(super_working_data_list, + stringsAsFactors=FALSE, + row.names=NULL) + + # Return results return(working_environment_) } diff --git a/R/level.R b/R/level.R index 4569133..c0cc37f 100644 --- a/R/level.R +++ b/R/level.R @@ -56,7 +56,10 @@ level <- # The level already exists, we are adding variables to it. # Which variables could we possibly care about in this level call? - unique_variables_to_write_to = unname(unlist(get_symbols_from_quosure(dots))) + unique_variables_to_write_to = unname(unlist(get_symbols_from_quosure(dots))) + # Remove the level variable from consideration -- we know this unique + # conditional on itself by definition + unique_variables_to_write_to = setdiff(unique_variables_to_write_to, ID_label) # Subset the working data frame to data that matters by the level we care about # based on the level call we have. @@ -77,8 +80,9 @@ level <- # Now, merge the new data frame into the old one to recover the variables we previously dropped return(merge( - data_internal_[, colnames(data_internal_)[!(colnames(data_internal_) %in% - level_variables)], drop = FALSE], + data_internal_[, + !(colnames(data_internal_) %in% level_variables), + drop = FALSE], data, by = ID_label, all = TRUE, diff --git a/R/utilities.R b/R/utilities.R index 1e25b83..061411d 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -1,3 +1,6 @@ +#' +#' @importFrom rlang quos lang_args +#' get_symbols_from_expression = function(l_arg) { # We have some sort of language expression in R, let's extract # the symbols it's going to refer to @@ -11,7 +14,7 @@ get_symbols_from_expression = function(l_arg) { recurse = lang_args(l_arg) # Iterate through each part of the language, recursively calling this function # Results are a list, so unlist and unname to flatten - temp = unname(unlist(lapply(recurse, function(i) { process_lang_args(i) }))) + temp = unname(unlist(lapply(recurse, function(i) { get_symbols_from_expression(i) }))) return(temp) } else { # It's something else? This might happen if the base level call @@ -19,6 +22,9 @@ get_symbols_from_expression = function(l_arg) { } } +#' +#' @importFrom rlang quos lang_args get_expr +#' get_symbols_from_quosure = function(quosure) { # Given a quosure, what symbols will that quosure attempt to read when it # is evaluated? From c9e4c52bda323497a880b1212dad596b23a22d13 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 16 Nov 2017 11:31:36 -0800 Subject: [PATCH 07/47] Switched the working environment to an environment for speed gains. Began process of deprecating old files. --- R/fabricate.R | 6 +- R/fabricate_rewrite.R | 117 ++++++++++++++++++---------------- R/fabricate_rewrite_helpers.R | 109 ++++++++++++++++++++++++++++--- R/level.R | 2 +- R/utilities.R | 2 +- 5 files changed, 164 insertions(+), 72 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index a71925e..29534a0 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -1,8 +1,4 @@ - - - - -#' Fabricate data +#' Fabricate data (NOTE: THIS FILE IS DEPRECATED!!!!!!) #' #' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. #' diff --git a/R/fabricate_rewrite.R b/R/fabricate_rewrite.R index 5442fd0..0ac568f 100644 --- a/R/fabricate_rewrite.R +++ b/R/fabricate_rewrite.R @@ -70,6 +70,9 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) ) } + # Create a blank working environment. + working_environment = new.env() + # User provided level calls if(all_levels) { # Ensure the user provided a name for each level call. @@ -77,12 +80,9 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) stop("You must provide a name for each level you create.") } - # Create a blank working environment. - working_environment = list() - # User provided data, if any, should be preloaded into working environment if(!is.null(data) & !missing(data)) { - working_environment[["imported_data_"]] = data + working_environment$imported_data_ = data } # Each of data_arguments is a level call @@ -112,7 +112,7 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) handle_n(N, add_level = TRUE) # Creating a working environment that's empty (user passed no data) - data_arguments[["working_environment_"]] = list() + data_arguments[["working_environment_"]] = working_environment # Run the level adder, report the results, and return return( @@ -127,7 +127,8 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) N = nrow(data) # Now, let's load the data into our working environment - data_arguments[["working_environment_"]] = list(imported_data_ = data) + working_environment$imported_data_ = data + data_arguments[["working_environment_"]] = working_environment # Run the level adder, report the results, and return return( @@ -137,6 +138,7 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) ) } +#' @rdname fabricate_revised #' @export add_level_new = function(N = NULL, ID_label = NULL, working_environment_ = NULL, @@ -162,31 +164,31 @@ add_level_new = function(N = NULL, ID_label = NULL, # Shelf the working data frame and move on if("data_frame_output_" %in% names(working_environment_)) { # Construct the shelved version - package_df = list(data_frame_output_ = working_environment_[["data_frame_output_"]], - level_ids_ = working_environment_[["level_ids_"]], - variable_names_ = names(working_environment_[["data_frame_output_"]])) + package_df = list(data_frame_output_ = working_environment_$data_frame_output_, + level_ids_ = working_environment_$level_ids_, + variable_names_ = names(working_environment_$data_frame_output_)) # Append it to the existing shelf if("shelved_df" %in% names(working_environment_)) { - working_environment_[["shelved_df"]] = append(working_environment_[["shelved_df"]], package_df) + working_environment_$shelved_df = append(working_environment_$shelved_df, package_df) } else { # Create a shelf just for this - working_environment_[["shelved_df"]] = list(package_df) + working_environment_$shelved_df = list(package_df) } # Clear the current work-space. - working_environment_[["data_frame_output_"]] = - working_environment_[["level_ids_"]] = - working_environment_[["variable_names_"]] = NULL + working_environment_$data_frame_output_ = + working_environment_$level_ids_ = + working_environment_$variable_names_ = NULL } # User is adding a new level, but we need to sneak in the imported data first. # When this is done, trash the imported data, because the working data frame contains it. if("imported_data_" %in% names(working_environment_)) { - num_obs_imported = nrow(working_environment_[["imported_data_"]]) - working_data_list = as.list(working_environment_[["imported_data_"]]) - working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) - working_environment_[["imported_data_"]] = NULL + num_obs_imported = nrow(working_environment_$imported_data_) + working_data_list = as.list(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL # User didn't specify an N, so get it from the current data. if(is.null(N)) { N = num_obs_imported @@ -202,11 +204,12 @@ add_level_new = function(N = NULL, ID_label = NULL, working_data_list[[ID_label]] = generate_id_pad(N) # Next, add the ID_label to the level ids tracker - working_environment_ = add_level_id(working_environment_, ID_label) - working_environment_ = add_variable_name(working_environment_, ID_label) + # Why does this not need to return? Because environments are passed by reference + add_level_id(working_environment_, ID_label) + add_variable_name(working_environment_, ID_label) } else { # If the ID label was specified but already exists; - working_environment_ = add_level_id(working_environment_, ID_label) + add_level_id(working_environment_, ID_label) } } @@ -219,7 +222,7 @@ add_level_new = function(N = NULL, ID_label = NULL, append(working_data_list, list(N=N))) # Write the variable name to the list of variable names - working_environment_ = add_variable_name(working_environment_, i) + add_variable_name(working_environment_, i) # Nuke the current data argument -- if we have the same variable name created twice, # this is OK, because it'll only nuke the current one. @@ -229,13 +232,14 @@ add_level_new = function(N = NULL, ID_label = NULL, # Before handing back data, ensure it's actually rectangular working_data_list = check_rectangular(working_data_list, N) - working_environment_[["data_frame_output_"]] = data.frame(working_data_list, - stringsAsFactors=FALSE, - row.names=NULL) + working_environment_$data_frame_output_ = data.frame(working_data_list, + stringsAsFactors=FALSE, + row.names=NULL) return(working_environment_) } +#' @rdname fabricate_revised #' @export nest_level_new = function(N = NULL, ID_label = NULL, working_environment_ = NULL, @@ -255,11 +259,11 @@ nest_level_new = function(N = NULL, ID_label = NULL, } # Check to make sure we have a data frame to nest on. - if(is.null(dim(working_environment_[["data_frame_output_"]]))) { + if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - working_environment_[["data_frame_output_"]] = working_environment_[["imported_data_"]] - working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) - working_environment_[["imported_data_"]] = NULL + working_environment_$data_frame_output_ = working_environment_$imported_data_ + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL } else { stop("You can't nest a level if there is no level to nest inside") } @@ -272,7 +276,7 @@ nest_level_new = function(N = NULL, ID_label = NULL, # We need to expand the size of the current working data frame by copying it # Let's start by getting the size of the current working data frame - past_level_N = nrow(working_environment_[["data_frame_output_"]]) + past_level_N = nrow(working_environment_$data_frame_output_) # And now make an index set 1:past_level_N indices = seq_len(past_level_N) @@ -289,7 +293,7 @@ nest_level_new = function(N = NULL, ID_label = NULL, # Expand the data frame by duplicating the indices and then coerce the data frame # to a list -- we do this to basically make variables accessible in the namespace. - working_data_list = as.list(working_environment_[["data_frame_output_"]][rep_indices, , drop=FALSE]) + working_data_list = as.list(working_environment_$data_frame_output_[rep_indices, , drop=FALSE]) ### Everything after here is non-unique to nest_level versus add_level -- need to think about how to ### refactor this out. @@ -299,8 +303,8 @@ nest_level_new = function(N = NULL, ID_label = NULL, # First, add the column to the working data frame working_data_list[[ID_label]] = generate_id_pad(N) - working_environment_ = add_level_id(working_environment_, ID_label) - working_environment_ = add_variable_name(working_environment_, ID_label) + add_level_id(working_environment_, ID_label) + add_variable_name(working_environment_, ID_label) } # Loop through each of the variable generating arguments @@ -312,7 +316,7 @@ nest_level_new = function(N = NULL, ID_label = NULL, append(working_data_list, list(N=N))) # Write the variable name to the list of variable names - working_environment_ = add_variable_name(working_environment_, i) + add_variable_name(working_environment_, i) # Nuke the current data argument -- if we have the same variable name created twice, # this is OK, because it'll only nuke the current one. @@ -330,6 +334,7 @@ nest_level_new = function(N = NULL, ID_label = NULL, return(working_environment_) } +#' @rdname fabricate_revised #' @export #' modify_level_new = function(N = NULL, @@ -357,11 +362,11 @@ modify_level_new = function(N = NULL, } # First, establish that if we have no working data frame, we can't continue - if(is.null(dim(working_environment_[["data_frame_output_"]]))) { + if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - working_environment_[["data_frame_output_"]] = working_environment_[["imported_data_"]] - working_environment_[["variable_names_"]] = names(working_environment_[["imported_data_"]]) - working_environment_[["imported_data_"]] = NULL + working_environment_$data_frame_output_ = working_environment_$imported_data_ + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL } else { stop("You can't modify a level if there is no working data frame to modify: you must either load pre-existing data or generate some data before modifying.") } @@ -370,12 +375,12 @@ modify_level_new = function(N = NULL, # There are two possibilities. One is that we are modifying the lowest level of data. # In which case, we simply add variables, like if someone called add_level with a dataset. # To check if that's the world we're in, check if we have any duplicates in the ID label: - if(!anyDuplicated(working_environment_[["data_frame_output_"]][[ID_label]])) { + if(!anyDuplicated(working_environment_$data_frame_output_[[ID_label]])) { # There is no subsetting going on, but modify_level was used anyway. - N = nrow(working_environment_[["data_frame_output_"]]) + N = nrow(working_environment_$data_frame_output_) # Coerce the working data frame into a list - working_data_list = as.list(working_environment_[["data_frame_output_"]]) + working_data_list = as.list(working_environment_$data_frame_output_) # Now loop over the variable creation. for(i in names(data_arguments)) { @@ -387,7 +392,7 @@ modify_level_new = function(N = NULL, append(working_data_list, list(N=N))) # Write the variable name to the list of variable names - working_environment_ = add_variable_name(working_environment_, i) + add_variable_name(working_environment_, i) # Nuke the current data argument -- if we have the same variable name created twice, # this is OK, because it'll only nuke the current one. @@ -410,15 +415,15 @@ modify_level_new = function(N = NULL, # first, subset to unique observations, then generate new data, then re-expand. # To do this, we need a mapping between observations and unique observations. # First, get the unique values of the level: - unique_values_of_level = unique(working_environment_[["data_frame_output_"]][[ID_label]]) + unique_values_of_level = unique(working_environment_$data_frame_output_[[ID_label]]) # Pre-allocate the mapping vector - index_maps = numeric(length(working_environment_[["data_frame_output_"]][[ID_label]])) + index_maps = numeric(length(working_environment_$data_frame_output_[[ID_label]])) # Iterate along the unique values of the level for(i in seq_along(unique_values_of_level)) { # Any obs that matches the level matching this i will be a duplicate of this i. index_maps[ - working_environment_[["data_frame_output_"]][[ID_label]] == unique_values_of_level[i] + working_environment_$data_frame_output_[[ID_label]] == unique_values_of_level[i] ] = i } @@ -427,11 +432,11 @@ modify_level_new = function(N = NULL, # Remove the ID label from the variables we are going to write to. write_variables = setdiff(write_variables, ID_label) # Let's also remove anything that doesn't seem to be a valid variable - write_variables = write_variables[write_variables %in% names(working_environment_[["data_frame_output_"]])] + write_variables = write_variables[write_variables %in% names(working_environment_$data_frame_output_)] # Level unique variables: level_unique_variables = get_unique_variables_by_level( - data = working_environment_[["data_frame_output_"]], + data = working_environment_$data_frame_output_, ID_label = ID_label, superset=write_variables) @@ -451,21 +456,21 @@ modify_level_new = function(N = NULL, merged_set = unique(c(ID_label, setdiff(level_unique_variables, ""))) # And these rows: - row_indices_keep = !duplicated(working_environment_[["data_frame_output_"]][[ID_label]]) + row_indices_keep = !duplicated(working_environment_$data_frame_output_[[ID_label]]) # Now subset it: - working_subset = working_environment_[["data_frame_output_"]][row_indices_keep, - merged_set, - drop=FALSE] + working_subset = working_environment_$data_frame_output_[row_indices_keep, + merged_set, + drop=FALSE] # Set the N variable correctly moving forward: - super_N = nrow(working_environment_[["data_frame_output_"]]) + super_N = nrow(working_environment_$data_frame_output_) N = nrow(working_subset) # Get the subset into a list: working_data_list = as.list(working_subset) # And our original working data frame: - super_working_data_list = as.list(working_environment_[["data_frame_output_"]]) + super_working_data_list = as.list(working_environment_$data_frame_output_) # Now loop for(i in names(data_arguments)) { @@ -477,7 +482,7 @@ modify_level_new = function(N = NULL, append(working_data_list, list(N=N))) # Write the variable name to the list of variable names - working_environment_ = add_variable_name(working_environment_, i) + add_variable_name(working_environment_, i) # Expand the variable and store it in the actual, expanded environment super_working_data_list[[i]] = working_data_list[[i]][index_maps] @@ -491,7 +496,7 @@ modify_level_new = function(N = NULL, super_working_data_list = check_rectangular(super_working_data_list, super_N) # Overwrite the working data frame. - working_environment_[["data_frame_output_"]] = data.frame(super_working_data_list, + working_environment_$data_frame_output_ = data.frame(super_working_data_list, stringsAsFactors=FALSE, row.names=NULL) @@ -506,5 +511,5 @@ level_new = function(N = NULL, ID_label = NULL, ...) { # Dummy helper function that just extracts the working data frame from the environment. report_results = function(working_environment) { - return(working_environment[["data_frame_output_"]]) + return(working_environment$data_frame_output_) } diff --git a/R/fabricate_rewrite_helpers.R b/R/fabricate_rewrite_helpers.R index d99e6c6..1f82e07 100644 --- a/R/fabricate_rewrite_helpers.R +++ b/R/fabricate_rewrite_helpers.R @@ -1,3 +1,94 @@ +#' +#' @importFrom rlang quos lang_args get_expr +#' +get_symbols_from_expression = function(l_arg) { + # We have some sort of language expression in R, let's extract + # the symbols it's going to refer to + + if(is.symbol(l_arg)) { + # If it's a symbol, return the symbol + return(unname(l_arg)) + } else if(is.language(l_arg)) { + # If it's a language call, then we need to unpack some more + # Extract the language from the language call + recurse = lang_args(l_arg) + # Iterate through each part of the language, recursively calling this function + # Results are a list, so unlist and unname to flatten + temp = unname(unlist(lapply(recurse, function(i) { get_symbols_from_expression(i) }))) + return(temp) + } else { + # It's something else? This might happen if the base level call + # is numeric or whatever. We are only interested in variable nanes. + } +} + +#' +#' @importFrom rlang quos lang_args get_expr +#' +get_symbols_from_quosure = function(quosure) { + # Given a quosure, what symbols will that quosure attempt to read when it + # is evaluated? + meta_results = lapply(quosure, function(i) { + # For each term in the quosure, get the language call out of the term: + expression = get_expr(i) + # Get the arguments out of that language call + thing = lang_args(expression) + # Now, for each argument try to extract the symbols + results = lapply(thing, function(x) { get_symbols_from_expression(x) }) + + # We are going to unlist, convert to characters (this is necessary to coerce + # results into a vector), and then remove duplicates + return(unique( + as.character( + unlist( + results)))) + }) + + return(meta_results) +} + +get_unique_variables_by_level <- function(data, ID_label, superset=NULL) { + # Superset contains a vector of character strings that contain variables + # the modify level call is going to write. Some of these may be columns + # in the data frame, others might not be. If superset is specified, + # then we definitely only want to check those variables + if(!is.null(superset)) { + names_to_check = intersect(colnames(data), superset) + } else { + names_to_check = colnames(data)[-which(colnames(data)==ID_label)] + } + + # It turns out the call isn't going to use any variables at all! + if(!length(names_to_check)) { return("") } + + # Iterate through each column of interest + # Per column, split that column's data into a list. The split indices come from the level indicator. + # Now, run a function which checks the unique length of each tranch + # Unlist the result to get a vector of TRUE or FALSE for each tranch of the list. + # If all tranches are TRUE, then the column has unique values based on the level's level. + # Take the results per column, unlist those, strip the names (if any) from the variables. + # Now extract the column names for the columns for which this was true. Return as a vector. + + # Performance is around 22% faster than existing code for small dataset + level_variables = names_to_check[ + unname(unlist(lapply(names_to_check, + function(i) { + all(unlist( + lapply( + split(data[, i], data[, ID_label]), + function(x) { + length(unique(x))==1 + } + ) + )) + } + ) + )) + ] + return(level_variables) +} + + # Checks if an ID label is sane, warns or errors if not. # Generates an ID label if there isn't one provided. handle_id = function(ID_label, data=NULL) { @@ -74,12 +165,11 @@ handle_n = function(N, add_level=TRUE, working_environment=NULL) { # last level variable # What's the last level variable? - name_of_last_level = working_environment[["level_ids_"]][length( - working_environment[["level_ids_"]])] + name_of_last_level = working_environment$level_ids_[length(working_environment$level_ids_)] # What are the unique values? unique_values_of_last_level = unique( - working_environment[["data_frame_output_"]][[name_of_last_level]] + working_environment$data_frame_output_[[name_of_last_level]] ) if(length(N) != length(unique_values_of_last_level)) { @@ -215,22 +305,23 @@ check_rectangular = function(working_data_list, N) { add_level_id = function(working_environment_, ID_label) { # Add or create level ID list if("level_ids_" %in% names(working_environment_)) { - working_environment_[["level_ids_"]] = append(working_environment_[["level_ids_"]], ID_label) + working_environment_$level_ids_ = append(working_environment_$level_ids_, ID_label) } else { - working_environment_[["level_ids_"]] = c(ID_label) + working_environment_$level_ids_ = c(ID_label) } - return(working_environment_) + return() } # Add a variable name to a working environment add_variable_name = function(working_environment_, variable_name) { # Add or create variable name list. if("variable_names_" %in% names(working_environment_)) { - working_environment_[["variable_names_"]] = append(working_environment_[["variable_names_"]], variable_name) + working_environment_$variable_names_ = append(working_environment_$variable_names_, + variable_name) } else { - working_environment_[["variable_names_"]] = c(variable_name) + working_environment_$variable_names_ = c(variable_name) } - return(working_environment_) + return() } diff --git a/R/level.R b/R/level.R index c0cc37f..260cba0 100644 --- a/R/level.R +++ b/R/level.R @@ -1,5 +1,5 @@ -#' Fabricate a Level of Data for Hierarchical Data +#' Fabricate a Level of Data for Hierarchical Data (NOTE: THIS FILE IS DEPRECATED!!!!!!) #' #' @importFrom rlang quos eval_tidy quo lang_modify #' diff --git a/R/utilities.R b/R/utilities.R index 061411d..04ba52a 100644 --- a/R/utilities.R +++ b/R/utilities.R @@ -1,4 +1,4 @@ -#' +#' Helper function (NOTE: THIS FILE IS DEPRECATED!!!!!!) #' @importFrom rlang quos lang_args #' get_symbols_from_expression = function(l_arg) { From 715df58ec00276bba1194b00fae03eba2804d624 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 16 Nov 2017 11:32:33 -0800 Subject: [PATCH 08/47] Renamed files to old- prefix and added to rbuildignore --- .Rbuildignore | 1 + R/{fabricate.R => old-fabricate.R} | 0 R/{level.R => old-level.R} | 0 R/{utilities.R => old-utilities.R} | 0 4 files changed, 1 insertion(+) rename R/{fabricate.R => old-fabricate.R} (100%) rename R/{level.R => old-level.R} (100%) rename R/{utilities.R => old-utilities.R} (100%) diff --git a/.Rbuildignore b/.Rbuildignore index cbf62b6..a75b1e3 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,3 +11,4 @@ _pkgdown.yml cran-comments.md ^NEWS\.md$ ^_pkgdown\.yml$ +R/old-* diff --git a/R/fabricate.R b/R/old-fabricate.R similarity index 100% rename from R/fabricate.R rename to R/old-fabricate.R diff --git a/R/level.R b/R/old-level.R similarity index 100% rename from R/level.R rename to R/old-level.R diff --git a/R/utilities.R b/R/old-utilities.R similarity index 100% rename from R/utilities.R rename to R/old-utilities.R From 4e097d29ca1c4b8aab04909e62b9c72e3afb28d3 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 16 Nov 2017 11:32:59 -0800 Subject: [PATCH 09/47] Renamed new files to final names. --- R/{fabricate_rewrite.R => fabricate.R} | 0 R/{fabricate_rewrite_helpers.R => helper_functions.R} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename R/{fabricate_rewrite.R => fabricate.R} (100%) rename R/{fabricate_rewrite_helpers.R => helper_functions.R} (100%) diff --git a/R/fabricate_rewrite.R b/R/fabricate.R similarity index 100% rename from R/fabricate_rewrite.R rename to R/fabricate.R diff --git a/R/fabricate_rewrite_helpers.R b/R/helper_functions.R similarity index 100% rename from R/fabricate_rewrite_helpers.R rename to R/helper_functions.R From 089adca5091f44e9928d6326db720ea4a12c1744 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 16 Nov 2017 11:34:38 -0800 Subject: [PATCH 10/47] Renamed functions to take over namespace. --- R/fabricate.R | 38 +++++++++++++++++++------------------- R/helper_functions.R | 6 +++--- 2 files changed, 22 insertions(+), 22 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 0ac568f..b10c9c4 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -1,6 +1,6 @@ #' Fabricate data #' -#' \code{fabricate_revised} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. #' #' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). #' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. @@ -12,41 +12,41 @@ #' @examples #' #' # Draw a single-level dataset with no covariates -#' df <- fabricate_revised(N = 100) +#' df <- fabricate(N = 100) #' head(df) #' #' # Draw a single-level dataset with a covariate -#' df <- fabricate_revised( +#' df <- fabricate( #' N = 100, #' height_ft = runif(N, 3.5, 8) #' ) #' head(df) #' #' # Start with existing data -#' df <- fabricate_revised( +#' df <- fabricate( #' data = df, #' new_variable = rnorm(N) #' ) #' #' # Draw a two-level hierarchical dataset #' # containing cities within regions -#' df <- fabricate_revised( -#' regions = add_level_new(N = 5), -#' cities = nest_level_new(N = 2, pollution = rnorm(N, mean = 5))) +#' df <- fabricate( +#' regions = add_level(N = 5), +#' cities = nest_level(N = 2, pollution = rnorm(N, mean = 5))) #' head(df) #' #' # Start with existing data and add variables to hierarchical data #' # note: do not provide N when adding variables to an existing level -#' df <- fabricate_revised( +#' df <- fabricate( #' data = df, -#' regions = modify_level_new(watershed = sample(c(0, 1), N, replace = TRUE)), -#' cities = modify_level_new(runoff = rnorm(N)) +#' regions = modify_level(watershed = sample(c(0, 1), N, replace = TRUE)), +#' cities = modify_level(runoff = rnorm(N)) #' ) #' #' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args is_lang get_expr #' #' @export -fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) +fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) { # Store all data generation arguments in a quosure for future evaluation # A quosure contains unevaluated formulae and function calls. @@ -117,7 +117,7 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) # Run the level adder, report the results, and return return( report_results( - add_level_new(N = N, ID_label = ID_label, data_arguments = data_arguments) + add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) ) ) } @@ -133,14 +133,14 @@ fabricate_revised <- function(data = NULL, N = NULL, ID_label = NULL, ...) # Run the level adder, report the results, and return return( report_results( - add_level_new(N = N, ID_label = ID_label, data_arguments = data_arguments) + add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) ) ) } -#' @rdname fabricate_revised +#' @rdname fabricate #' @export -add_level_new = function(N = NULL, ID_label = NULL, +add_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments=quos(...)) { @@ -239,9 +239,9 @@ add_level_new = function(N = NULL, ID_label = NULL, return(working_environment_) } -#' @rdname fabricate_revised +#' @rdname fabricate #' @export -nest_level_new = function(N = NULL, ID_label = NULL, +nest_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments=quos(...)) { @@ -334,10 +334,10 @@ nest_level_new = function(N = NULL, ID_label = NULL, return(working_environment_) } -#' @rdname fabricate_revised +#' @rdname fabricate #' @export #' -modify_level_new = function(N = NULL, +modify_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., diff --git a/R/helper_functions.R b/R/helper_functions.R index 1f82e07..b4a7cd7 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -258,9 +258,9 @@ check_all_levels_new <- function(options){ # Check to see if the function names are one of the valid level operations is_level = sapply(func_names, function(i) { i %in% c("level", - "add_level_new", - "nest_level_new", - "modify_level_new") }) + "add_level", + "nest_level", + "modify_level") }) # Return false if we have no level calls if(length(is_level) == 0) return(FALSE) From b49a6b1cb2f855a26719040831cd7e48bfc4c8ae Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 12:22:35 -0800 Subject: [PATCH 11/47] Cutoff to new version of fabricate and the level functions, updated unit tests to reflect new names, bugfixes to correct unit tests --- .Rbuildignore | 1 - DESCRIPTION | 3 +- NAMESPACE | 7 +- R/fabricate.R | 65 +++- R/helper_functions.R | 26 +- R/old-fabricate.R | 294 ------------------ R/old-level.R | 96 ------ R/old-utilities.R | 120 ------- R/resample_data.R | 8 +- man/fabricate.Rd | 36 ++- man/fabricate_revised.Rd | 58 ---- man/resample_data.Rd | 8 +- tests/testthat/test-fabrication.R | 60 ++-- tests/testthat/test-hierarchical.R | 12 +- tests/testthat/test-resampling.R | 32 +- .../testthat/test-start-with-existing-data.R | 20 +- tests/testthat/test-variables.R | 4 +- vignettes/getting_started.Rmd | 67 ++-- 18 files changed, 216 insertions(+), 701 deletions(-) delete mode 100644 R/old-fabricate.R delete mode 100644 R/old-level.R delete mode 100644 R/old-utilities.R delete mode 100644 man/fabricate_revised.Rd diff --git a/.Rbuildignore b/.Rbuildignore index a75b1e3..cbf62b6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -11,4 +11,3 @@ _pkgdown.yml cran-comments.md ^NEWS\.md$ ^_pkgdown\.yml$ -R/old-* diff --git a/DESCRIPTION b/DESCRIPTION index aab7bdb..2d7bd06 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,7 +5,8 @@ Version: 1.0.0 Authors@R: c(person("Graeme", "Blair", email = "graeme.blair@ucla.edu", role = c("aut", "cre")), 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("Macartan", "Humphreys", email = "macartan@gmail.com", role = c("aut")), + person("Aaron", "Rudkin", email = "rudkin@ucla.edu", role = c("ctb"))) Description: Helps you imagine your data before you collect it. Hierarchical data structures and correlated data can be easily simulated, either from random number generators or by resampling from existing data sources. diff --git a/NAMESPACE b/NAMESPACE index b9b4df5..bcc79e9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,14 +1,13 @@ # Generated by roxygen2: do not edit by hand export(ALL) -export(add_level_new) +export(add_level) export(draw_binary) export(draw_discrete) export(fabricate) -export(fabricate_revised) export(level) -export(modify_level_new) -export(nest_level_new) +export(modify_level) +export(nest_level) export(resample_data) importFrom(rlang,eval_tidy) importFrom(rlang,get_expr) diff --git a/R/fabricate.R b/R/fabricate.R index b10c9c4..0878030 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -6,6 +6,8 @@ #' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. #' @param ID_label (optional) variable name for ID variable, i.e. citizen_ID #' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples. +#' @param working_environment_ For internal use only, users should not supply this argument. +#' @param data_arguments For internal use only, users should not supply this argument. #' #' @return data.frame #' @@ -56,7 +58,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # or a series of level calls. You can't mix and match. # This helper function will be TRUE if calls are all levels, FALSE # if there are no calls or they are not levels. - all_levels = check_all_levels_new(data_arguments) + all_levels = check_all_levels(data_arguments) # User must provide exactly one of: # 1) One or more level calls (with or without importing their own data) @@ -109,7 +111,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) ID_label = handle_id(ID_label, data) # Is the N argument passed here sane? Let's check - handle_n(N, add_level = TRUE) + N = handle_n(N, add_level = TRUE) # Creating a working environment that's empty (user passed no data) data_arguments[["working_environment_"]] = working_environment @@ -138,6 +140,10 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) ) } +#' Fabricate the Top Level of Data For Hierarchical Data +#' +#' @importFrom rlang quos eval_tidy quo lang_modify +#' #' @rdname fabricate #' @export add_level = function(N = NULL, ID_label = NULL, @@ -158,7 +164,7 @@ add_level = function(N = NULL, ID_label = NULL, } # Check to make sure the N here is sane - handle_n(N, add_level=TRUE) + N = handle_n(N, add_level=TRUE) # User is adding a new level, but already has a working data frame. # Shelf the working data frame and move on @@ -199,6 +205,7 @@ add_level = function(N = NULL, ID_label = NULL, # Staple in an ID column onto the data list. if(!is.null(ID_label)) { + # It's possible the working data frame already has the ID label, if so, don't do anything. if(is.null(names(working_data_list)) || !ID_label %in% names(working_data_list)) { # First, add the column to the working data frame working_data_list[[ID_label]] = generate_id_pad(N) @@ -208,7 +215,7 @@ add_level = function(N = NULL, ID_label = NULL, add_level_id(working_environment_, ID_label) add_variable_name(working_environment_, ID_label) } else { - # If the ID label was specified but already exists; + # If the ID label was specified but already exists, we should still log it as a level ID add_level_id(working_environment_, ID_label) } } @@ -232,13 +239,20 @@ add_level = function(N = NULL, ID_label = NULL, # Before handing back data, ensure it's actually rectangular working_data_list = check_rectangular(working_data_list, N) + # Coerce our working data list into a working data frame working_environment_$data_frame_output_ = data.frame(working_data_list, stringsAsFactors=FALSE, row.names=NULL) + # In general the reference should be unchanged, but for single-level calls + # there won't be a working environment to reference. return(working_environment_) } +#' Fabricate a Level of Hierarchical Data Within Existing Data +#' +#' @importFrom rlang quos eval_tidy quo lang_modify +#' #' @rdname fabricate #' @export nest_level = function(N = NULL, ID_label = NULL, @@ -267,12 +281,11 @@ nest_level = function(N = NULL, ID_label = NULL, } else { stop("You can't nest a level if there is no level to nest inside") } - } # Check to make sure the N here is sane # Pass the working environment because N might not be a singleton here - handle_n(N, add_level=FALSE, working_environment = working_environment_) + N = handle_n(N, add_level=FALSE, working_environment = working_environment_) # We need to expand the size of the current working data frame by copying it # Let's start by getting the size of the current working data frame @@ -287,8 +300,8 @@ nest_level = function(N = NULL, ID_label = NULL, if(length(N)==1) rep_indices = rep(indices, each=N) else rep_indices = rep(indices, times=N) - # current_N = N # This would store the intended N value for the level # Update N to the new length. + inner_N = N N = length(rep_indices) # Expand the data frame by duplicating the indices and then coerce the data frame @@ -315,6 +328,22 @@ nest_level = function(N = NULL, ID_label = NULL, working_data_list[[i]] = eval_tidy(data_arguments[[i]], append(working_data_list, list(N=N))) + # User provided a fixed-length data variable whose length is the length of the inner-most + # level for a given outer level. See example: + # fabricate(countries = add_level(N=20), + # cities = nest_level(N=2, capital=c(TRUE, FALSE))) + # We need to expand this to each setting of the outer level. + # Only evaluate if inner_N is a single number + if(length(inner_N) == 1 && length(working_data_list[[i]]) == inner_N) { + # If there's a non-even multiple that's an indication something is badly wrong with the data here. + if((N/inner_N) %% 1) { + stop("Variable ", i, " has inappropriate length for nested level ", ID_label, ". \n", + " If the nested level has a fixed length, please generate data of the length of either the inner level or the entire data frame. If the nested level has a variable length, please generate data equal to the length of the entire data frame using the N argument.") + } + # Do the repetition + working_data_list[[i]] = rep(working_data_list[[i]], (N/inner_N)) + } + # Write the variable name to the list of variable names add_variable_name(working_environment_, i) @@ -334,9 +363,12 @@ nest_level = function(N = NULL, ID_label = NULL, return(working_environment_) } +#' Modify Existing Hierarchical Data To Add Data At Higher Levels +#' +#' @importFrom rlang quos eval_tidy quo lang_modify +#' #' @rdname fabricate #' @export -#' modify_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, @@ -477,14 +509,16 @@ modify_level = function(N = NULL, # Evaluate the formula in an environment consisting of: # 1) The current working data list # 2) A list that tells everyone what N means in this context. - # Store it in the current environment + # Store it in the currently working data list working_data_list[[i]] = eval_tidy(data_arguments[[i]], append(working_data_list, list(N=N))) # Write the variable name to the list of variable names add_variable_name(working_environment_, i) - # Expand the variable and store it in the actual, expanded environment + # Expand the variable and store it in the actual, expanded working data list + # Why do we keep these in parallel? Because subsequent variables might need the non-expanded + # version to generate new variables. super_working_data_list[[i]] = working_data_list[[i]][index_maps] # Nuke the current data argument -- if we have the same variable name created twice, @@ -504,12 +538,17 @@ modify_level = function(N = NULL, return(working_environment_) } -# Overload the level command -level_new = function(N = NULL, ID_label = NULL, ...) { - # Stub, this doesn't do anything yet +#' +#' @rdname fabricate +#' @export +level = function(N = NULL, ID_label = NULL, ...) { + stop("Level calls are currently deprecated; use add_level, nest_level, and modify_level") + # Stub, this doesn't do anything yet -- may in the future dispatch to the relevant + # levels. } # Dummy helper function that just extracts the working data frame from the environment. +# This exists because we may in the future want to return something that is not a data frame. report_results = function(working_environment) { return(working_environment$data_frame_output_) } diff --git a/R/helper_functions.R b/R/helper_functions.R index b4a7cd7..5ee8cef 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -92,6 +92,13 @@ get_unique_variables_by_level <- function(data, ID_label, superset=NULL) { # Checks if an ID label is sane, warns or errors if not. # Generates an ID label if there isn't one provided. handle_id = function(ID_label, data=NULL) { + # If the user passed a symbol, we should evaluate the symbol forcibly and error if + # they were assuming NSE substitution of an undefined symbol. + tryCatch(force(ID_label), + error = function(e) { + stop("The ID_label provided is a reference to an undefined variable. Please enclose ID_label in quotation marks if you intended to provide ID_label as a character vector.") + }) + # User passed a non-symbol non-null ID_label if(!is.null(ID_label)) { if(is.vector(ID_label) & length(ID_label) > 1) { @@ -150,6 +157,21 @@ handle_id = function(ID_label, data=NULL) { handle_n = function(N, add_level=TRUE, working_environment=NULL) { # Error handling for user-supplied N + # First, evaluate the N in the context of the working environment's working data frame + # Why do we need to do this? Because N could be a function of variables. + if(!is.null(working_environment) & "data_frame_output_" %in% names(working_environment)) { + # Why do we substitute N in parent.frame()? Because if we substitute in the current + # frame, we just get the symbol used for N from the outside functions, which would just be N + # This ensures we get the expression passed to N in the outer function call. + temp_N_expr = substitute(N, parent.frame()) + N = eval_tidy(temp_N_expr, data=working_environment$data_frame_output_) + } + + # User provided an unevaluated function + if(typeof(N) == "closure") { + stop("If you use a function to define N, you must evaluate that function rather than passing it in closure form.") + } + # If they provided an N if(!is.null(N)) { # If this is an add_level operation, N must be a single number @@ -204,6 +226,8 @@ handle_n = function(N, add_level=TRUE, working_environment=NULL) { }) } } + + return(N) } # Checks if the user-provided data is sane @@ -242,7 +266,7 @@ handle_data = function(data) { # Function to check if every argument in a quosure options # is a level call. -check_all_levels_new <- function(options){ +check_all_levels <- function(options){ # Passing the options quosures # There were no levels, or indeed arguments, at all if (length(options) == 0) return(FALSE) diff --git a/R/old-fabricate.R b/R/old-fabricate.R deleted file mode 100644 index 29534a0..0000000 --- a/R/old-fabricate.R +++ /dev/null @@ -1,294 +0,0 @@ -#' Fabricate data (NOTE: THIS FILE IS DEPRECATED!!!!!!) -#' -#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. -#' -#' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). -#' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. -#' @param ID_label (optional) variable name for ID variable, i.e. citizen_ID -#' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples. -#' -#' @return data.frame -#' -#' @examples -#' -#' # Draw a single-level dataset with no covariates -#' df <- fabricate(N = 100) -#' head(df) -#' -#' # Draw a single-level dataset with a covariate -#' df <- fabricate( -#' N = 100, -#' height_ft = runif(N, 3.5, 8) -#' ) -#' head(df) -#' -#' # Start with existing data -#' df <- fabricate( -#' data = df, -#' new_variable = rnorm(N) -#' ) -#' -#' # Draw a two-level hierarchical dataset -#' # containing cities within regions -#' df <- fabricate( -#' regions = level(N = 5), -#' cities = level(N = 2, pollution = rnorm(N, mean = 5))) -#' head(df) -#' -#' # Start with existing data and add variables to hierarchical data -#' # note: do not provide N when adding variables to an existing level -#' df <- fabricate( -#' data = df, -#' regions = level(watershed = sample(c(0, 1), N, replace = TRUE)), -#' cities = level(runoff = rnorm(N)) -#' ) -#' -#' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args is_lang get_expr -#' -#' @export -fabricate <- - function(data, - N, - ID_label, - ...) { - - # Each level argument passed to fabricate will be stored in options - # as an unevaluated language call. - options <- quos(...) - - # Let's check if we have nothing but level calls. - all_levels <- check_all_levels(options) - - # We've got data, but it's not a data frame - if (!missing(data) && !"data.frame" %in% class(data)) { - # It's not at least 2d - if(is.null(dim(data))) { - stop( - "User provided data must be a data frame. Provided data was low dimensional." - ) - } - # We got something that thinks it is data, but it wasn't explicitly given as data - if(!"data" %in% names(sys.call())) { - stop( - "The data argument must be a data object. The argument call, ", deparse(substitute(data)), ", was not a data object (e.g. a data.frame, tibble, sf object, or convertible matrix)." - ) - } - # Let's see if we can make it a data frame - tryCatch({ - data = as.data.frame(data) - }, error=function(e) { - # We can't make it a data frame -- this should probably never happen, - # since it relies on something with a dim attribute not converting to - # a data frame. - stop( - "User provided data could not convert to a data frame." - ) - }) - } - - # They were all level calls, so we need to build the level one by one - if (all_levels) { - for (i in seq_along(options)) { - # If we have been passed data or if we are in at least the second level - # pass the existing data frame to the variable data_internal_ - # as an argument to the level generation call. - if (i > 1 | !missing(data)) { - options[[i]] <- lang_modify(options[[i]], data_internal_ = data) - } - - # Adds the variable ID_label_ to the quosure at the current level - # equal to the value of names(options)[i] -- the "variable" we're assigning - # the level to - options[[i]] <- - lang_modify(options[[i]], ID_label_ = names(options)[i]) - - # Execute the current level call in the context of all the data it can see. - data <- eval_tidy(options[[i]]) - } - - # Return the final, assembled data. - return(data) - - } else { - # No level calls, this is single-level data - - # No user provided data - if(missing(data)) data <- NULL - # No user provided N - if(missing(N)) N <- NULL - # No user provided ID_label - if(missing(ID_label)) ID_label <- NULL - - # Building ID label from what the user provided - # It's a language symbol -- if so, use the symbol, not the value - if(is.symbol(substitute(ID_label))) { - ID_label <- substitute(ID_label) - if (!is.null(ID_label)) { - ID_label <- as.character(ID_label) - } - } else if(!is.null(ID_label)) { - if(is.vector(ID_label) & length(ID_label) > 1) { - # Vector of length n>1, error - stop("Provided ID_label must be a character vector of length 1 or variable name.") - } else if(is.vector(ID_label) & is.numeric(ID_label[1])) { - # Numeric ID_label -- this is OK but variable names can't be numeric - warning("Provided ID_label is numeric and will be prefixed with the character \"X\"") - ID_label <- as.character(ID_label) - } else if(is.vector(ID_label) & is.character(ID_label[1])) { - # Valid ID_label - ID_label <- as.character(ID_label) - } else if(!is.null(dim(ID_label))) { - # Higher dimensional ID_label - stop("Provided ID_label must be a character vector or variable name, not a data frame or matrix.") - } - } - - # We have our data, N, ID_label, whether there's an ID label, and pass through any other quosure stuff - fabricate_data_single_level( - data = data, - N = N, - ID_label = ID_label, - existing_ID = !is.null(data) & is.null(ID_label), - options = options - ) - } - } - - -#' @importFrom rlang quos eval_tidy -fabricate_data_single_level <- function(data = NULL, - N = NULL, - ID_label = NULL, - ..., - existing_ID = FALSE, - options=quos(...)) { - # The user provided nothing of what we want. - if (is.null(data) == is.null(N)) { - stop("Please supply either a data.frame or N and not both.") - } - - # They provided an N - if (!is.null(N)) { - # The N is not a single integer but we're at the top level - # We know we're at the top level because fabricate_data_single_level is only called if we are - if (length(N) != 1) { - # Error message explaining to the user where they messed up - stop( - "At the top level, ", - ifelse(!is.null(ID_label), - paste0(ID_label, ", "), - ""), - "you must provide a single number to N" - ) - } else if(is.numeric(N) & any(!N%%1 == 0 | N<=0)) { - # N has to be an integer above 0 - stop( - "The provided N must be an integer number greater than 0. Provided N was of type ", - typeof(N) - ) - } - - # N is not numeric - if(!is.numeric(N)) { - tryCatch({ - # Let's try to force it to be numeric. - N = as.numeric(N) - }, error=function(e) { - stop( - "The provided value for N must be an integer number." - ) - }) - } - - # Set up a data frame that's blank - data <- data.frame() - # There's no existing ID column because we're generating all the data. - existing_ID <- FALSE - } else if(!is.null(data)){ - # The user gave us data, so we have an N, it's the number of rows - N <- nrow(data) - } - - # If there's no ID column, we'll generate one now - if (!existing_ID) { - # If they didn't specify an ID label for the ID column, we just give it the name ID - if(is.null(ID_label)) ID_label <- "ID" - data <- genID(data, ID_label, N) - } - - # Let's fab the data. - fab(data, options) -} - -genID <- function(data, ID, N=nrow(data)){ - # Left-Pad ID variable with zeroes - fmt <- paste0("%0", nchar(N), "d") - # Add it to the data frame. - data[1:N, ID] <- sprintf(fmt, 1:N) - data -} - -fab <- function(data, args) { - # This was explicitly provided above but ends up getting to be implicit because we - # created the ID column with nrow(data) N. - N <- nrow(data) - - # Convert the provisional DF to a list so that we can access it in the environment - # of running the formulae for the next variable - data_list = as.list(data) - - if(is.null(names(args)) || any(names(args) == "")) { - stop("All variables specified at this level should have names.") - } - - for (i in names(args)) { - # i is the variable name - # args[[i]] is the formula for this variable - # data_list contains the current working environment - - # Add a variable called N so that things have access; then evaluate the current - # formula, adding it to the environment. Store it in the working data frame - data_list[[i]] <- - eval_tidy(args[[i]], append(data_list, list(N=N))) - - # If we have two arguments with exactly the same name, this will nuke the first - # in the list, allowing the next one to be accessible the next time we get to it. - args[[i]] <- NULL - } - - data <- data.frame(data_list, stringsAsFactors = FALSE, row.names=NULL) - - # Return to the complete data frame - return(data) -} - - -check_all_levels <- function(options){ - # Passing the options quosures - # There were no levels at all - if (length(options) == 0) return(FALSE) - - # get_expr returns the expression for an item in a quosure - # is_lang checks if it's a function - is_function <- sapply(options, function(i) { - is_lang(get_expr(i)) - }) - - # lang_name gets function name from a quosure - # compare this to level to see if it's a level - is_level <- "level" == sapply(options[is_function], lang_name) ## function names - - # Return false if we have no level calls - if(length(is_level) == 0) return(FALSE) - - # If some calls are levels and some aren't, we're unhappy - if (any(is_level) != all(is_level)) { - stop( - "Arguments passed to ... must either all be calls to level() or have no calls to level()." - ) - } - - # Confirm they're all levels - is_level[1] && length(is_level) == length(options) -} - diff --git a/R/old-level.R b/R/old-level.R deleted file mode 100644 index 260cba0..0000000 --- a/R/old-level.R +++ /dev/null @@ -1,96 +0,0 @@ - -#' Fabricate a Level of Data for Hierarchical Data (NOTE: THIS FILE IS DEPRECATED!!!!!!) -#' -#' @importFrom rlang quos eval_tidy quo lang_modify -#' -#' @rdname fabricate -#' @export -level <- - function(N = NULL, - ...) { - - # The dots take all the arguments at the current level, as well as - # the provisional working data frame, which is injected at a higher level - dots <- quos(...) - - # If we were passed a working data frame, let's move it into our current level - if ("data_internal_" %in% names(dots)) { - data_internal_ <- eval_tidy(dots[["data_internal_"]]) - dots[["data_internal_"]] <- NULL - } else { - data_internal_ <- NULL - } - - # If we were passed an ID for this level (and if not, something went wrong) - # pass it through transparently - if ("ID_label_" %in% names(dots)) { - ID_label <- eval_tidy(dots[["ID_label_"]]) - dots[["ID_label_"]] <- NULL - } else { - stop("Please provide a name for the level, by specifying `your_level_name = level()` in fabricate.") - } - - if (is.null(data_internal_)) { - # We're at a top level case with no provided data - return(fabricate_data_single_level(N=N, ID_label=ID_label, options=dots)) - } else { - # We're at a second level case, or a top-level case with provided data. Two things to proceed: - # 1. ID_label does not yet exist, in which case we create the level defined by ID_label by expanding dataset based on N - # 2. ID label already exists, in which case we add variables to an existing level - - # If we are getting a new ID label, it's a new level. - if (!ID_label %in% colnames(data_internal_)) { - # Evaluate how many N we need - N <- eval(substitute(N), envir = data_internal_) - - # Expand the working data frame using ID_label - data_internal_ <- - expand_data_by_ID(data = data_internal_, - ID_label = ID_label, - N = N) - - # Having expanded and added the ID, we can fab the rest of the variables - return(fabricate_data_single_level(data_internal_, NULL, ID_label, options=dots)) - - } else { - # The level already exists, we are adding variables to it. - - # Which variables could we possibly care about in this level call? - unique_variables_to_write_to = unname(unlist(get_symbols_from_quosure(dots))) - # Remove the level variable from consideration -- we know this unique - # conditional on itself by definition - unique_variables_to_write_to = setdiff(unique_variables_to_write_to, ID_label) - - # Subset the working data frame to data that matters by the level we care about - # based on the level call we have. - level_variables <- - get_unique_variables_by_level(data = data_internal_, - ID_label = ID_label, - superset=unique_variables_to_write_to) - - merged_set = unique(c(ID_label, level_variables)) - - data <- - unique(data_internal_[, merged_set[merged_set != ""], - drop = FALSE]) - - # Now, fabricate the new variables at this level - - data <- fabricate_data_single_level(data, NULL, ID_label, existing_ID = TRUE, options=dots) - - # Now, merge the new data frame into the old one to recover the variables we previously dropped - return(merge( - data_internal_[, - !(colnames(data_internal_) %in% level_variables), - drop = FALSE], - data, - by = ID_label, - all = TRUE, - sort = FALSE - )) - - } - - } - - } diff --git a/R/old-utilities.R b/R/old-utilities.R deleted file mode 100644 index 04ba52a..0000000 --- a/R/old-utilities.R +++ /dev/null @@ -1,120 +0,0 @@ -#' Helper function (NOTE: THIS FILE IS DEPRECATED!!!!!!) -#' @importFrom rlang quos lang_args -#' -get_symbols_from_expression = function(l_arg) { - # We have some sort of language expression in R, let's extract - # the symbols it's going to refer to - - if(is.symbol(l_arg)) { - # If it's a symbol, return the symbol - return(unname(l_arg)) - } else if(is.language(l_arg)) { - # If it's a language call, then we need to unpack some more - # Extract the language from the language call - recurse = lang_args(l_arg) - # Iterate through each part of the language, recursively calling this function - # Results are a list, so unlist and unname to flatten - temp = unname(unlist(lapply(recurse, function(i) { get_symbols_from_expression(i) }))) - return(temp) - } else { - # It's something else? This might happen if the base level call - # is numeric or whatever. We are only interested in variable nanes. - } -} - -#' -#' @importFrom rlang quos lang_args get_expr -#' -get_symbols_from_quosure = function(quosure) { - # Given a quosure, what symbols will that quosure attempt to read when it - # is evaluated? - meta_results = lapply(quosure, function(i) { - # For each term in the quosure, get the language call out of the term: - expression = get_expr(i) - # Get the arguments out of that language call - thing = lang_args(expression) - # Now, for each argument try to extract the symbols - results = lapply(thing, function(x) { get_symbols_from_expression(x) }) - - # We are going to unlist, convert to characters (this is necessary to coerce - # results into a vector), and then remove duplicates - return(unique( - as.character( - unlist( - results)))) - }) - - return(meta_results) -} - -get_unique_variables_by_level <- function(data, ID_label, superset=NULL) { - # Superset contains a vector of character strings that contain variables - # the modify level call is going to write. Some of these may be columns - # in the data frame, others might not be. If superset is specified, - # then we definitely only want to check those variables - if(!is.null(superset)) { - names_to_check = intersect(colnames(data), superset) - } else { - names_to_check = colnames(data)[-which(colnames(data)==ID_label)] - } - - # It turns out the call isn't going to use any variables at all! - if(!length(names_to_check)) { return("") } - - # Iterate through each column of interest - # Per column, split that column's data into a list. The split indices come from the level indicator. - # Now, run a function which checks the unique length of each tranch - # Unlist the result to get a vector of TRUE or FALSE for each tranch of the list. - # If all tranches are TRUE, then the column has unique values based on the level's level. - # Take the results per column, unlist those, strip the names (if any) from the variables. - # Now extract the column names for the columns for which this was true. Return as a vector. - - # Performance is around 22% faster than existing code for small dataset - level_variables = names_to_check[ - unname(unlist(lapply(names_to_check, - function(i) { - all(unlist( - lapply( - split(data[, i], data[, ID_label]), - function(x) { - length(unique(x))==1 - } - ) - )) - } - ) - )) - ] - return(level_variables) -} - -expand_data_by_ID <- function(data, ID_label, N) { - if (typeof(N) %in% c("integer", "double") && - length(N) == 1) { - data <- data[rep(1:nrow(data), each = N), , drop = FALSE] - } else if (typeof(N) %in% c("integer", "double") && - length(N) > 1) { - # check that the vector that is N is the right length, i.e the length of data_internal_ - if (length(N) != nrow(data)) { - stop( - paste0( - "If you provide a vector to N for level ", - ID_label, - ", it must be the length of the dataset at the level above it ", - "in the hierarchy" - ) - ) - } - data <- data[rep(1:nrow(data), times = N), , drop = FALSE] - } else if (class(N) == "function") { - data <- data[rep(1:nrow(data), times = N()), , drop = FALSE] - } else { - stop( - paste0( - "Please provide level ", - ID_label, - " with N that is a vector, scalar, or function that generates a vector." - ) - ) - } -} diff --git a/R/resample_data.R b/R/resample_data.R index a939e00..5041141 100644 --- a/R/resample_data.R +++ b/R/resample_data.R @@ -18,8 +18,8 @@ #' # N specifies a number of clusters to return #' #' clustered_survey <- fabricate( -#' clusters = level(N=25), -#' cities = level(N=runif(25, 1, 5), population=runif(n = N, min=50000, max=1000000)) +#' clusters = add_level(N=25), +#' cities = nest_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) #' ) #' #' # Specify the name of the cluster variable one of two ways @@ -34,8 +34,8 @@ #' #' my_data <- #' fabricate( -#' cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), -#' citizens = level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) +#' cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), +#' citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) #' ) #' #' # Specify the levels you wish to resample one of two ways: diff --git a/man/fabricate.Rd b/man/fabricate.Rd index 756b5b8..6216f93 100644 --- a/man/fabricate.Rd +++ b/man/fabricate.Rd @@ -1,13 +1,25 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fabricate.R, R/level.R +% Please edit documentation in R/fabricate.R \name{fabricate} \alias{fabricate} +\alias{add_level} +\alias{nest_level} +\alias{modify_level} \alias{level} \title{Fabricate data} \usage{ -fabricate(data, N, ID_label, ...) +fabricate(data = NULL, N = NULL, ID_label = NULL, ...) -level(N = NULL, ...) +add_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., + data_arguments = quos(...)) + +nest_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., + data_arguments = quos(...)) + +modify_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., + data_arguments = quos(...)) + +level(N = NULL, ID_label = NULL, ...) } \arguments{ \item{data}{(optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} @@ -17,6 +29,10 @@ level(N = NULL, ...) \item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} \item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples.} + +\item{working_environment_}{For internal use only, users should not supply this argument.} + +\item{data_arguments}{For internal use only, users should not supply this argument.} } \value{ data.frame @@ -24,7 +40,11 @@ data.frame \description{ \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. -Fabricate a Level of Data for Hierarchical Data +Fabricate the Top Level of Data For Hierarchical Data + +Fabricate a Level of Hierarchical Data Within Existing Data + +Modify Existing Hierarchical Data To Add Data At Higher Levels } \examples{ @@ -48,16 +68,16 @@ df <- fabricate( # Draw a two-level hierarchical dataset # containing cities within regions df <- fabricate( - regions = level(N = 5), - cities = level(N = 2, pollution = rnorm(N, mean = 5))) + regions = add_level(N = 5), + cities = nest_level(N = 2, pollution = rnorm(N, mean = 5))) head(df) # Start with existing data and add variables to hierarchical data # note: do not provide N when adding variables to an existing level df <- fabricate( data = df, - regions = level(watershed = sample(c(0, 1), N, replace = TRUE)), - cities = level(runoff = rnorm(N)) + regions = modify_level(watershed = sample(c(0, 1), N, replace = TRUE)), + cities = modify_level(runoff = rnorm(N)) ) } diff --git a/man/fabricate_revised.Rd b/man/fabricate_revised.Rd deleted file mode 100644 index d450281..0000000 --- a/man/fabricate_revised.Rd +++ /dev/null @@ -1,58 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/fabricate_rewrite.R -\name{fabricate_revised} -\alias{fabricate_revised} -\title{Fabricate data} -\usage{ -fabricate_revised(data = NULL, N = NULL, ID_label = NULL, ...) -} -\arguments{ -\item{data}{(optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} - -\item{N}{(optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset.} - -\item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} - -\item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples.} -} -\value{ -data.frame -} -\description{ -\code{fabricate_revised} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. -} -\examples{ - -# Draw a single-level dataset with no covariates -df <- fabricate_revised(N = 100) -head(df) - -# Draw a single-level dataset with a covariate -df <- fabricate_revised( - N = 100, - height_ft = runif(N, 3.5, 8) -) -head(df) - -# Start with existing data -df <- fabricate_revised( - data = df, - new_variable = rnorm(N) -) - -# Draw a two-level hierarchical dataset -# containing cities within regions -df <- fabricate_revised( - regions = add_level_new(N = 5), - cities = nest_level_new(N = 2, pollution = rnorm(N, mean = 5))) -head(df) - -# Start with existing data and add variables to hierarchical data -# note: do not provide N when adding variables to an existing level -df <- fabricate_revised( - data = df, - regions = modify_level_new(watershed = sample(c(0, 1), N, replace = TRUE)), - cities = modify_level_new(runoff = rnorm(N)) -) - -} diff --git a/man/resample_data.Rd b/man/resample_data.Rd index 3f024e3..46bf0d3 100644 --- a/man/resample_data.Rd +++ b/man/resample_data.Rd @@ -31,8 +31,8 @@ bootsrapped_data # N specifies a number of clusters to return clustered_survey <- fabricate( - clusters = level(N=25), - cities = level(N=runif(25, 1, 5), population=runif(n = N, min=50000, max=1000000)) + clusters = add_level(N=25), + cities = nest_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) ) # Specify the name of the cluster variable one of two ways @@ -47,8 +47,8 @@ cluster_resample_2 my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) # Specify the levels you wish to resample one of two ways: diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index 33b207b..d7729ec 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -26,31 +26,30 @@ test_that("Fabricate", { ID_label = "ID" ) - fabricate(regions = level(N = 5, gdp = rnorm(N))) + fabricate(regions = add_level(N = 5, gdp = rnorm(N))) fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = gdp + 10) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = gdp + 10) ) - fabricate(regions = level(N = 5), - cities = level(N = sample(1:5), subways = rnorm(N, mean = 5))) + fabricate(regions = add_level(N = 5), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5))) fabricate( - regions = level(N = 5, gdp = runif(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = 5)) + regions = add_level(N = 5, gdp = runif(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) ) # User provides matrix, test conversion. fabricate(data = matrix(rep(c(1, 2, 3), 3), byrow=TRUE, ncol=3, nrow=3)) }) -test_that("use a function to choose N of a level", { +test_that("choose N of a level based on data from higher levels", { fabricate( - regions = level(N = 2, gdp = runif(N)), - cities = level( - N = function(x) - return(round(gdp) * 10 + 1), + regions = add_level(N = 2, gdp = runif(N)), + cities = nest_level( + N = round(gdp) * 10 + 1, subways = rnorm(N, mean = 5) ) ) @@ -59,49 +58,40 @@ test_that("use a function to choose N of a level", { test_that("trigger errors", { expect_error(fabricate( - regions = level(), - cities = level(N = sample(1:5), subways = rnorm(N, mean = 5)) + regions = add_level(), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( - regions = level(N = c(1, 2)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = 5)) + regions = add_level(N = c(1, 2)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( - regions = level(N = 2), - cities = level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) + regions = add_level(N = 2), + cities = nest_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( - regions = level(N = 2), - cities = level(N = "N that is a character vector", subways = rnorm(N, mean = 5)) + regions = add_level(N = 2), + cities = nest_level(N = "N that is a character vector", subways = rnorm(N, mean = 5)) )) - region_data <- data.frame(capital = c(1, 0, 0, 0, 0)) - expect_error(fabricatr:::fabricate_data_single_level(data = region_data, N = 5, gdp = runif(N))) - expect_error(fabricate( - regions = level(N = rep(5, 2)), - cities = level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) - )) - - expect_error(fabricatr:::fabricate_data_single_level( - N = c(5, 2), - gdp = runif(N), - ID_label = "my-level" + regions = add_level(N = rep(5, 2)), + cities = nest_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) )) # you must provide name for levels expect_error(fabricate(level(N = 5, gdp = rnorm(N)), - level( + add_level( N = sample(1:5), subways = rnorm(N, mean = gdp) ))) # same for a single level - expect_error(fabricate(level(N = 5, + expect_error(fabricate(add_level(N = 5, gdp = rnorm(N)))) # No N, no data @@ -133,8 +123,8 @@ test_that("trigger errors", { fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label="hello") fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=c("hello")) # Symbol as ID_label - fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=test1) - fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=test3) + expect_error(fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=test1)) + expect_error(fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=test3)) # Unusual test with implicit data argument expect_error(fabricate(N=10, 1:N)) diff --git a/tests/testthat/test-hierarchical.R b/tests/testthat/test-hierarchical.R index efbdf14..98916ba 100644 --- a/tests/testthat/test-hierarchical.R +++ b/tests/testthat/test-hierarchical.R @@ -3,13 +3,13 @@ context("hierarchical") test_that("hierarchical data is created correctly when you have a vector variable that is of length N per level",{ hierarchy <- fabricate( - regions = level(N = 3, gdp = rnorm(N)), - districts = level( + regions = add_level(N = 3, gdp = rnorm(N)), + districts = nest_level( N = 2, var1 = c("recent", "ancient"), var2 = ifelse(var1 == "recent", gdp, 5) ), - cities = level(N = 2, subways = rnorm(N, mean = gdp)) + cities = nest_level(N = 2, subways = rnorm(N, mean = gdp)) ) df_2 <- unique(hierarchy[,c("regions", "var2")]) @@ -25,17 +25,17 @@ df_2 <- unique(hierarchy[,c("regions", "var2")]) test_that("creating variables", { population <- fabricate( - block = level( + block = add_level( N = 5, block_effect = rnorm(N) ), - individuals = level(N = 2, noise = rnorm(N)) + individuals = nest_level(N = 2, noise = rnorm(N)) ) expect_error(fabricate( N = 10, noise = rnorm(N), - block = level( + block = nest_level( N = 5, block_effect = rnorm(N) ) diff --git a/tests/testthat/test-resampling.R b/tests/testthat/test-resampling.R index 8c79340..f55bdbc 100644 --- a/tests/testthat/test-resampling.R +++ b/tests/testthat/test-resampling.R @@ -2,8 +2,8 @@ context("Resampling") test_that("Resampling", { two_levels <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = 5, subways = rnorm(N, mean = gdp)) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = 5, subways = rnorm(N, mean = gdp)) ) # Example with data.table codepath @@ -24,8 +24,8 @@ test_that("Resampling", { test_that("Error handling of Resampling", { two_levels <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resampled_two_levels <- resample_data(two_levels) # Missing N @@ -42,8 +42,8 @@ test_that("Error handling of Resampling", { test_that("Direct resample_single_level", { two_levels <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) null_data = two_levels[two_levels$gdp > 100, ] @@ -58,12 +58,12 @@ test_that("Direct resample_single_level", { test_that("Extremely high volume data creation.", { skip("Slows build substantially.") deep_dive_data = fabricate( - countries = level(N = 100, gdp = rlnorm(N)), - states = level(N = 50, population = rlnorm(N)), - cities = level(N = 50, holiday = runif(N, 1, 365)), - neighborhoods = level(N = 5, stoplights = draw_binary(x=0.5, N)), - houses = level(N = 5, population = runif(N, 1, 5)), - people = level(N = population, sex = ifelse(draw_binary(x=0.5, N), "M", "F")) + countries = add_level(N = 100, gdp = rlnorm(N)), + states = nest_level(N = 50, population = rlnorm(N)), + cities = nest_level(N = 50, holiday = runif(N, 1, 365)), + neighborhoods = nest_level(N = 5, stoplights = draw_binary(x=0.5, N)), + houses = nest_level(N = 5, population = runif(N, 1, 5)), + people = nest_level(N = population, sex = ifelse(draw_binary(x=0.5, N), "M", "F")) ) test_resample = resample_data(deep_dive_data, @@ -73,8 +73,8 @@ test_that("Extremely high volume data creation.", { test_that("Providing ID_labels through names of N.", { two_levels <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resample_data(two_levels, N=c(regions=3, cities=5)) @@ -91,8 +91,8 @@ test_that("Providing ID_labels through names of N.", { test_that("Passthrough resampling.", { two_levels <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resample_data(two_levels, N=c(regions=ALL, cities=3)) diff --git a/tests/testthat/test-start-with-existing-data.R b/tests/testthat/test-start-with-existing-data.R index 858e9fa..aca8f90 100644 --- a/tests/testthat/test-start-with-existing-data.R +++ b/tests/testthat/test-start-with-existing-data.R @@ -4,14 +4,14 @@ test_that("Start with existing multi-level data and add variables",{ user_data <- fabricate( - regions = level(N = 5, gdp = rnorm(N))) + regions = add_level(N = 5, gdp = rnorm(N))) expect_equal(dim(user_data), c(5, 2)) user_data <- fabricate( - regions = level(N = 5, gdp = rnorm(N)), - cities = level(N = sample(1:5), subways = rnorm(N, mean = gdp))) + regions = add_level(N = 5, gdp = rnorm(N)), + cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp))) expect_equal(dim(user_data), c(15, 4)) @@ -19,29 +19,29 @@ test_that("Start with existing multi-level data and add variables",{ user_data_2 <- fabricate(data = user_data, - regions = level(rob = paste0(regions, "r"))) + regions = modify_level(rob = paste0(regions, "r"))) expect_equal(dim(user_data_2), c(15, 5)) ## add a variable at the cities level user_data_3 <- fabricate(data = user_data, - cities = level(rob = paste0(cities, "c"))) + cities = modify_level(rob = paste0(cities, "c"))) expect_equal(dim(user_data_3), c(15, 5)) user_data_4 <- fabricate(data = user_data, - regions = level(rob = paste0(regions, "r")), - cities = level(bob = paste0(cities, "c"))) + regions = modify_level(rob = paste0(regions, "r")), + cities = modify_level(bob = paste0(cities, "c"))) expect_equal(dim(user_data_4), c(15, 6)) user_data_5 <- fabricate(data = user_data, - regions = level(rob = paste0(regions, "r")), - cities = level(bob = paste0(cities, "c")), - neighborhoods = level(N = 10, tmp = rnorm(N))) + regions = modify_level(rob = paste0(regions, "r")), + cities = modify_level(bob = paste0(cities, "c")), + neighborhoods = nest_level(N = 10, tmp = rnorm(N))) expect_equal(dim(user_data_5), c(150, 8)) diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 496deb8..a12a82c 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -2,14 +2,14 @@ context("Variable functions") test_that("Variable functions", { # Single-level data, logit link, inherit or implicit N - fabricate(my_level = level( + fabricate(my_level = add_level( N = 10, Y1 = rnorm(N), Y2 = draw_binary(Y1, link = "logit") )) # Single level, count, inherit or implicit N - fabricate(my_level = level( + fabricate(my_level = add_level( N = 10, Y1 = rnorm(N, 5), Y2 = draw_discrete(Y1, type = "count", k = 3) diff --git a/vignettes/getting_started.Rmd b/vignettes/getting_started.Rmd index f51d747..6c00ff6 100644 --- a/vignettes/getting_started.Rmd +++ b/vignettes/getting_started.Rmd @@ -39,8 +39,8 @@ There are three things to notice about this example: ```{r} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -58,37 +58,43 @@ Now, what if you want to fabricate discrete variables like binary variables or c ## Binary can be called as binary, bernoulli, or binomial ```{r} -fabricate(N = 3, p = c(0, .5, 1), binary = draw_discrete(p)) +fabricate(N = 3, p = c(0, .5, 1), + binary = draw_discrete(p)) ``` ## Binary can be called as binary, bernoulli, or binomial ```{r} -fabricate(N = 3, p = c(0, .5, 1), binary = draw_discrete(p, type = "bernoulli")) +fabricate(N = 3, p = c(0, .5, 1), + binary = draw_discrete(p, type = "bernoulli")) ``` ## Binary with link ```{r} -fabricate(N = 3, x = 10*rnorm(N), binary = draw_discrete(x, type = "bernoulli", link = "probit")) +fabricate(N = 3, x = 10*rnorm(N), + binary = draw_discrete(x, type = "bernoulli", link = "probit")) ``` ## Binomial ```{r} -fabricate(N = 3, p = c(0, .5, 1), binomial = draw_discrete(p, type = "binomial", k = 10)) +fabricate(N = 3, p = c(0, .5, 1), + binomial = draw_discrete(p, type = "binomial", k = 10)) ``` ## Binomial with link ```{r} -fabricate(N = 3, x = 10*rnorm(N), binomial = draw_discrete(x, type = "binomial", k = 10, link = "logit")) +fabricate(N = 3, x = 10*rnorm(N), + binomial = draw_discrete(x, type = "binomial", k = 10, link = "logit")) ``` ## Ordered requires cutoffs ```{r} set.seed(1) -fabricate(N = 3, x = 5*rnorm(N), ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf))) +fabricate(N = 3, x = 5*rnorm(N), + ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf))) ``` This really just cuts the data @@ -96,20 +102,25 @@ This really just cuts the data ## Ordered probit ```{r} set.seed(1) -fabricate(N = 3, x = 5*rnorm(N), ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf), link = "probit")) +fabricate(N = 3, x = 5*rnorm(N), + ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf), link = "probit")) ``` This is actually ordered probit since x is normal. ## Count is poisson ```{r} -fabricate(N = 3, x = c(0,5,100), count = draw_discrete(x, type = "count")) +fabricate(N = 3, x = c(0,5,100), + count = draw_discrete(x, type = "count")) ``` Negative binomial easily added. Currently takes lamda as argument though could easily take a real number or a probability. ## Categorical takes as input a matrix of probabilities (that get normalized if they do not sum to 1) ```{r} -fabricate(N = 6, p1 = runif(N), p2 = runif(N), p3 = runif(N), +fabricate(N = 6, + p1 = runif(N), + p2 = runif(N), + p3 = runif(N), cat = draw_discrete(cbind(p1, p2, p3), type = "categorical")) ``` @@ -148,8 +159,8 @@ The real utility of this function comes when resampling from hierarchical data. ```{r} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) my_data_2 <- resample_data(my_data, N = c(3, 5), ID_labels = c("cities", "citizens")) @@ -170,8 +181,8 @@ When resampling across multiple levels, it may be useful to transparently pass t ```{r} clustered_survey <- fabricate( - clusters = level(N=25), - cities = level(N=10, population=runif(n = N, min=50000, max=1000000)) + clusters = add_level(N=25), + cities = nest_level(N=10, population=runif(n = N, min=50000, max=1000000)) ) cluster_resample <- resample_data(clustered_survey, N = c(clusters=ALL, cities=5)) @@ -188,8 +199,8 @@ You may want to include the mean value of a variable within a group defined by a ```{r} fabricate( - cities = level(N = 2), - citizens = level( + cities = add_level(N = 2), + citizens = nest_level( N = 1:2, income = rnorm(N), income_mean_city = ave(income, cities)) ) ``` @@ -201,8 +212,8 @@ When making hierarchical data, you may not want to have the same number of units ```{r} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = c(2, 4), income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = c(2, 4), income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -212,8 +223,8 @@ You can even have Ns that are determined by a function, enabling a *random* numb ```{r} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = sample(1:6, size = 2, replace = TRUE), income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = sample(1:6, size = 2, replace = TRUE), income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -227,15 +238,15 @@ Suppose you had existing hierarchical data, and you wanted to add variables that my_baseline_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) # add new variables at each level my_data <- fabricate(data = my_baseline_data, - cities = level(density = elevation / 2), - citizens = level(wealth = income - 100)) + cities = modify_level(density = elevation / 2), + citizens = modify_level(wealth = income - 100)) my_data @@ -252,8 +263,8 @@ library(dplyr) my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = c(2, 3), income = round(elevation * rnorm(n = N, mean = 5))) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = nest_level(N = c(2, 3), income = round(elevation * rnorm(n = N, mean = 5))) ) %>% group_by(cities) %>% mutate(pop = n()) @@ -262,6 +273,6 @@ my_data my_data <- data_frame(Y = sample(1:10, 2)) %>% - fabricate(lower_level = level(N = 3, Y2 = Y + rnorm(N))) + fabricate(lower_level = nest_level(N = 3, Y2 = Y + rnorm(N))) my_data ``` From a72ddea7223503a8f36a3ee8b00962c2db899e4e Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 15:49:26 -0800 Subject: [PATCH 12/47] Update to use add_level instead of nest_level, documentation, and test fixes. Also cleaning up documentation --- NAMESPACE | 1 - R/fabricate.R | 86 +++++++++++++------ R/helper_functions.R | 13 +-- R/resample_data.R | 4 +- man/fabricate.Rd | 30 +++---- man/level.Rd | 12 +++ man/resample_data.Rd | 4 +- tests/testthat/test-fabrication.R | 34 ++++---- tests/testthat/test-hierarchical.R | 8 +- tests/testthat/test-resampling.R | 20 ++--- .../testthat/test-start-with-existing-data.R | 4 +- vignettes/getting_started.Rmd | 18 ++-- 12 files changed, 132 insertions(+), 102 deletions(-) create mode 100644 man/level.Rd diff --git a/NAMESPACE b/NAMESPACE index bcc79e9..97663a4 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -7,7 +7,6 @@ export(draw_discrete) export(fabricate) export(level) export(modify_level) -export(nest_level) export(resample_data) importFrom(rlang,eval_tidy) importFrom(rlang,get_expr) diff --git a/R/fabricate.R b/R/fabricate.R index 0878030..9f6e22d 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -1,13 +1,14 @@ #' Fabricate data #' -#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{add_level()} or modify existing hierarchical data using \code{modify_level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. #' #' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). #' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. #' @param ID_label (optional) variable name for ID variable, i.e. citizen_ID -#' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples. -#' @param working_environment_ For internal use only, users should not supply this argument. -#' @param data_arguments For internal use only, users should not supply this argument. +#' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{add_level()} or \code{modify_level()} arguments, which define a level of a multi-level dataset. See examples. +#' @param new_hierarchy Reserved argument for future functionality to add cross-classified data. Not yet implemented. +#' @param working_environment_ Internal argument, not intended for end-user use. +#' @param data_arguments Internal argument, not intended for end-user use. #' #' @return data.frame #' @@ -34,11 +35,12 @@ #' # containing cities within regions #' df <- fabricate( #' regions = add_level(N = 5), -#' cities = nest_level(N = 2, pollution = rnorm(N, mean = 5))) +#' cities = add_level(N = 2, pollution = rnorm(N, mean = 5))) #' head(df) #' #' # Start with existing data and add variables to hierarchical data -#' # note: do not provide N when adding variables to an existing level +#' # at levels which are already present in the existing data. +#' # Note: do not provide N when adding variables to an existing level #' df <- fabricate( #' data = df, #' regions = modify_level(watershed = sample(c(0, 1), N, replace = TRUE)), @@ -92,6 +94,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # Add two variables to the argument of the current level call # one to pass the working environment so far # one to pass the ID_label the user intends for the level + data_arguments[[i]] = lang_modify(data_arguments[[i]], working_environment_ = working_environment, ID_label = names(data_arguments)[i]) @@ -124,6 +127,13 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) ) } + # Confirm data can be a data frame + tryCatch({ + data = data.frame(data) + }, error=function(e) { + stop("User supplied data must be convertible into a data frame.") + }) + # User passed data, not N # First, let's dynamically get N from the number of rows N = nrow(data) @@ -140,8 +150,6 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) ) } -#' Fabricate the Top Level of Data For Hierarchical Data -#' #' @importFrom rlang quos eval_tidy quo lang_modify #' #' @rdname fabricate @@ -149,7 +157,8 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) add_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., - data_arguments=quos(...)) { + data_arguments=quos(...), + new_hierarchy = FALSE) { # Copy the working environment out of the data_arguments quosure and into the root. if("working_environment_" %in% names(data_arguments)) { @@ -163,6 +172,17 @@ add_level = function(N = NULL, ID_label = NULL, data_arguments[["ID_label"]] = NULL } + # Pass-through mapper to nest_level. + # This needs to be done after we read the working environment and + # before we check N or do the shelving procedure. + if(!new_hierarchy & + ("data_frame_output_" %in% names(working_environment_) | + "imported_data_" %in% names(working_environment_))) { + return(nest_level(N=N, ID_label=ID_label, + working_environment_=working_environment_, + data_arguments=data_arguments)) + } + # Check to make sure the N here is sane N = handle_n(N, add_level=TRUE) @@ -191,10 +211,14 @@ add_level = function(N = NULL, ID_label = NULL, # User is adding a new level, but we need to sneak in the imported data first. # When this is done, trash the imported data, because the working data frame contains it. if("imported_data_" %in% names(working_environment_)) { - num_obs_imported = nrow(working_environment_$imported_data_) - working_data_list = as.list(working_environment_$imported_data_) - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL + tryCatch({ + num_obs_imported = nrow(working_environment_$imported_data_) + working_data_list = as.list(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL + }, error = function(e) { + stop("User supplied data must be convertible into a data frame.") + }) # User didn't specify an N, so get it from the current data. if(is.null(N)) { N = num_obs_imported @@ -249,12 +273,9 @@ add_level = function(N = NULL, ID_label = NULL, return(working_environment_) } -#' Fabricate a Level of Hierarchical Data Within Existing Data #' #' @importFrom rlang quos eval_tidy quo lang_modify #' -#' @rdname fabricate -#' @export nest_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., @@ -275,9 +296,14 @@ nest_level = function(N = NULL, ID_label = NULL, # Check to make sure we have a data frame to nest on. if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - working_environment_$data_frame_output_ = working_environment_$imported_data_ - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL + tryCatch({ + working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL + }, error = function(e) { + stop("User supplied data must be convertible into a data frame.") + }) + } else { stop("You can't nest a level if there is no level to nest inside") } @@ -285,7 +311,9 @@ nest_level = function(N = NULL, ID_label = NULL, # Check to make sure the N here is sane # Pass the working environment because N might not be a singleton here - N = handle_n(N, add_level=FALSE, working_environment = working_environment_) + N = handle_n(N, add_level=FALSE, + working_environment = working_environment_, + parent_frame_levels=2) # We need to expand the size of the current working data frame by copying it # Let's start by getting the size of the current working data frame @@ -363,8 +391,6 @@ nest_level = function(N = NULL, ID_label = NULL, return(working_environment_) } -#' Modify Existing Hierarchical Data To Add Data At Higher Levels -#' #' @importFrom rlang quos eval_tidy quo lang_modify #' #' @rdname fabricate @@ -396,9 +422,13 @@ modify_level = function(N = NULL, # First, establish that if we have no working data frame, we can't continue if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - working_environment_$data_frame_output_ = working_environment_$imported_data_ - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL + tryCatch({ + working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL + }, error=function(e) { + stop("User supplied data must be convertible into a data frame.") + }) } else { stop("You can't modify a level if there is no working data frame to modify: you must either load pre-existing data or generate some data before modifying.") } @@ -538,11 +568,11 @@ modify_level = function(N = NULL, return(working_environment_) } -#' -#' @rdname fabricate +#' Deprecated level call function maintained to provide useful error for previous fabricatr code. +#' @keywords internal #' @export level = function(N = NULL, ID_label = NULL, ...) { - stop("Level calls are currently deprecated; use add_level, nest_level, and modify_level") + stop("Level calls are currently deprecated; use add_level and modify_level") # Stub, this doesn't do anything yet -- may in the future dispatch to the relevant # levels. } diff --git a/R/helper_functions.R b/R/helper_functions.R index 5ee8cef..4014675 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -1,6 +1,3 @@ -#' -#' @importFrom rlang quos lang_args get_expr -#' get_symbols_from_expression = function(l_arg) { # We have some sort of language expression in R, let's extract # the symbols it's going to refer to @@ -22,9 +19,6 @@ get_symbols_from_expression = function(l_arg) { } } -#' -#' @importFrom rlang quos lang_args get_expr -#' get_symbols_from_quosure = function(quosure) { # Given a quosure, what symbols will that quosure attempt to read when it # is evaluated? @@ -154,7 +148,8 @@ handle_id = function(ID_label, data=NULL) { } # Checks if a supplied N is sane for the context it's in -handle_n = function(N, add_level=TRUE, working_environment=NULL) { +handle_n = function(N, add_level=TRUE, working_environment=NULL, + parent_frame_levels=1) { # Error handling for user-supplied N # First, evaluate the N in the context of the working environment's working data frame @@ -163,7 +158,7 @@ handle_n = function(N, add_level=TRUE, working_environment=NULL) { # Why do we substitute N in parent.frame()? Because if we substitute in the current # frame, we just get the symbol used for N from the outside functions, which would just be N # This ensures we get the expression passed to N in the outer function call. - temp_N_expr = substitute(N, parent.frame()) + temp_N_expr = substitute(N, parent.frame(parent_frame_levels)) N = eval_tidy(temp_N_expr, data=working_environment$data_frame_output_) } @@ -251,7 +246,7 @@ handle_data = function(data) { # Convert user data to a data frame tryCatch({ - data = as.data.frame(data) + data = data.frame(data) }, error=function(e) { # We can't make it a data frame -- this should probably never happen, # since it relies on something with a dim attribute not converting to diff --git a/R/resample_data.R b/R/resample_data.R index 5041141..51d96bf 100644 --- a/R/resample_data.R +++ b/R/resample_data.R @@ -19,7 +19,7 @@ #' #' clustered_survey <- fabricate( #' clusters = add_level(N=25), -#' cities = nest_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) +#' cities = add_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) #' ) #' #' # Specify the name of the cluster variable one of two ways @@ -35,7 +35,7 @@ #' my_data <- #' fabricate( #' cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), -#' citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) +#' citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) #' ) #' #' # Specify the levels you wish to resample one of two ways: diff --git a/man/fabricate.Rd b/man/fabricate.Rd index 6216f93..c5015cb 100644 --- a/man/fabricate.Rd +++ b/man/fabricate.Rd @@ -3,23 +3,16 @@ \name{fabricate} \alias{fabricate} \alias{add_level} -\alias{nest_level} \alias{modify_level} -\alias{level} \title{Fabricate data} \usage{ fabricate(data = NULL, N = NULL, ID_label = NULL, ...) add_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., - data_arguments = quos(...)) - -nest_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., - data_arguments = quos(...)) + data_arguments = quos(...), new_hierarchy = FALSE) modify_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments = quos(...)) - -level(N = NULL, ID_label = NULL, ...) } \arguments{ \item{data}{(optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} @@ -28,23 +21,19 @@ level(N = NULL, ID_label = NULL, ...) \item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} -\item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{level()} arguments, which define a level of a multi-level dataset. See examples.} +\item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{add_level()} or \code{modify_level()} arguments, which define a level of a multi-level dataset. See examples.} -\item{working_environment_}{For internal use only, users should not supply this argument.} +\item{working_environment_}{Internal argument, not intended for end-user use.} -\item{data_arguments}{For internal use only, users should not supply this argument.} +\item{data_arguments}{Internal argument, not intended for end-user use.} + +\item{new_hierarchy}{Reserved argument for future functionality to add cross-classified data. Not yet implemented.} } \value{ data.frame } \description{ -\code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. - -Fabricate the Top Level of Data For Hierarchical Data - -Fabricate a Level of Hierarchical Data Within Existing Data - -Modify Existing Hierarchical Data To Add Data At Higher Levels +\code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{add_level()} or modify existing hierarchical data using \code{modify_level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. } \examples{ @@ -69,11 +58,12 @@ df <- fabricate( # containing cities within regions df <- fabricate( regions = add_level(N = 5), - cities = nest_level(N = 2, pollution = rnorm(N, mean = 5))) + cities = add_level(N = 2, pollution = rnorm(N, mean = 5))) head(df) # Start with existing data and add variables to hierarchical data -# note: do not provide N when adding variables to an existing level +# at levels which are already present in the existing data. +# Note: do not provide N when adding variables to an existing level df <- fabricate( data = df, regions = modify_level(watershed = sample(c(0, 1), N, replace = TRUE)), diff --git a/man/level.Rd b/man/level.Rd new file mode 100644 index 0000000..e7f861e --- /dev/null +++ b/man/level.Rd @@ -0,0 +1,12 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fabricate.R +\name{level} +\alias{level} +\title{Deprecated level call function maintained to provide useful error for previous fabricatr code.} +\usage{ +level(N = NULL, ID_label = NULL, ...) +} +\description{ +Deprecated level call function maintained to provide useful error for previous fabricatr code. +} +\keyword{internal} diff --git a/man/resample_data.Rd b/man/resample_data.Rd index 46bf0d3..7ebf656 100644 --- a/man/resample_data.Rd +++ b/man/resample_data.Rd @@ -32,7 +32,7 @@ bootsrapped_data clustered_survey <- fabricate( clusters = add_level(N=25), - cities = nest_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) + cities = add_level(N=round(runif(25, 1, 5)), population=runif(n = N, min=50000, max=1000000)) ) # Specify the name of the cluster variable one of two ways @@ -48,7 +48,7 @@ cluster_resample_2 my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) # Specify the levels you wish to resample one of two ways: diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index d7729ec..e0f1cef 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -30,15 +30,15 @@ test_that("Fabricate", { fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = gdp + 10) + cities = add_level(N = sample(1:5), subways = gdp + 10) ) fabricate(regions = add_level(N = 5), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5))) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = 5))) fabricate( regions = add_level(N = 5, gdp = runif(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = 5)) ) # User provides matrix, test conversion. @@ -48,7 +48,7 @@ test_that("Fabricate", { test_that("choose N of a level based on data from higher levels", { fabricate( regions = add_level(N = 2, gdp = runif(N)), - cities = nest_level( + cities = add_level( N = round(gdp) * 10 + 1, subways = rnorm(N, mean = 5) ) @@ -59,27 +59,27 @@ test_that("choose N of a level based on data from higher levels", { test_that("trigger errors", { expect_error(fabricate( regions = add_level(), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( regions = add_level(N = c(1, 2)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = 5)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( regions = add_level(N = 2), - cities = nest_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) + cities = add_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) )) expect_error(fabricate( regions = add_level(N = 2), - cities = nest_level(N = "N that is a character vector", subways = rnorm(N, mean = 5)) + cities = add_level(N = "N that is a character vector", subways = rnorm(N, mean = 5)) )) expect_error(fabricate( regions = add_level(N = rep(5, 2)), - cities = nest_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) + cities = add_level(N = c(5, 5, 5), subways = rnorm(N, mean = 5)) )) # you must provide name for levels @@ -90,10 +90,6 @@ test_that("trigger errors", { subways = rnorm(N, mean = gdp) ))) - # same for a single level - expect_error(fabricate(add_level(N = 5, - gdp = rnorm(N)))) - # No N, no data expect_error(fabricate(test1 = runif(10), test2 = test1 * 3 * runif(10, 1, 2))) @@ -110,8 +106,8 @@ test_that("trigger errors", { # Negative N expect_error(fabricate(N = -1, test1=runif(10))) - # must send a data frame to data - expect_error(user_data <- fabricate(data = c(5))) + # Sending a scalar will coerce to a data.frame + fabricate(data = c(5)) # Vector as ID_label expect_error(fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=c("invalid", "id"))) @@ -129,3 +125,11 @@ test_that("trigger errors", { # Unusual test with implicit data argument expect_error(fabricate(N=10, 1:N)) }) + +test_that("regression broke this test", { + # same for a single level + skip("Regression broke this test -- add_level is being interpreted as a call to data") + + expect_error(fabricate(add_level(N = 5, + gdp = rnorm(N)))) +}) diff --git a/tests/testthat/test-hierarchical.R b/tests/testthat/test-hierarchical.R index 98916ba..fa13265 100644 --- a/tests/testthat/test-hierarchical.R +++ b/tests/testthat/test-hierarchical.R @@ -4,12 +4,12 @@ test_that("hierarchical data is created correctly when you have a vector variabl hierarchy <- fabricate( regions = add_level(N = 3, gdp = rnorm(N)), - districts = nest_level( + districts = add_level( N = 2, var1 = c("recent", "ancient"), var2 = ifelse(var1 == "recent", gdp, 5) ), - cities = nest_level(N = 2, subways = rnorm(N, mean = gdp)) + cities = add_level(N = 2, subways = rnorm(N, mean = gdp)) ) df_2 <- unique(hierarchy[,c("regions", "var2")]) @@ -29,13 +29,13 @@ test_that("creating variables", { N = 5, block_effect = rnorm(N) ), - individuals = nest_level(N = 2, noise = rnorm(N)) + individuals = add_level(N = 2, noise = rnorm(N)) ) expect_error(fabricate( N = 10, noise = rnorm(N), - block = nest_level( + block = add_level( N = 5, block_effect = rnorm(N) ) diff --git a/tests/testthat/test-resampling.R b/tests/testthat/test-resampling.R index f55bdbc..4bbd6d1 100644 --- a/tests/testthat/test-resampling.R +++ b/tests/testthat/test-resampling.R @@ -3,7 +3,7 @@ context("Resampling") test_that("Resampling", { two_levels <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = 5, subways = rnorm(N, mean = gdp)) + cities = add_level(N = 5, subways = rnorm(N, mean = gdp)) ) # Example with data.table codepath @@ -25,7 +25,7 @@ test_that("Resampling", { test_that("Error handling of Resampling", { two_levels <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resampled_two_levels <- resample_data(two_levels) # Missing N @@ -43,7 +43,7 @@ test_that("Error handling of Resampling", { test_that("Direct resample_single_level", { two_levels <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) null_data = two_levels[two_levels$gdp > 100, ] @@ -59,11 +59,11 @@ test_that("Extremely high volume data creation.", { skip("Slows build substantially.") deep_dive_data = fabricate( countries = add_level(N = 100, gdp = rlnorm(N)), - states = nest_level(N = 50, population = rlnorm(N)), - cities = nest_level(N = 50, holiday = runif(N, 1, 365)), - neighborhoods = nest_level(N = 5, stoplights = draw_binary(x=0.5, N)), - houses = nest_level(N = 5, population = runif(N, 1, 5)), - people = nest_level(N = population, sex = ifelse(draw_binary(x=0.5, N), "M", "F")) + states = add_level(N = 50, population = rlnorm(N)), + cities = add_level(N = 50, holiday = runif(N, 1, 365)), + neighborhoods = add_level(N = 5, stoplights = draw_binary(x=0.5, N)), + houses = add_level(N = 5, population = runif(N, 1, 5)), + people = add_level(N = population, sex = ifelse(draw_binary(x=0.5, N), "M", "F")) ) test_resample = resample_data(deep_dive_data, @@ -74,7 +74,7 @@ test_that("Extremely high volume data creation.", { test_that("Providing ID_labels through names of N.", { two_levels <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resample_data(two_levels, N=c(regions=3, cities=5)) @@ -92,7 +92,7 @@ test_that("Providing ID_labels through names of N.", { test_that("Passthrough resampling.", { two_levels <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = gdp)) ) resample_data(two_levels, N=c(regions=ALL, cities=3)) diff --git a/tests/testthat/test-start-with-existing-data.R b/tests/testthat/test-start-with-existing-data.R index aca8f90..2353b34 100644 --- a/tests/testthat/test-start-with-existing-data.R +++ b/tests/testthat/test-start-with-existing-data.R @@ -11,7 +11,7 @@ test_that("Start with existing multi-level data and add variables",{ user_data <- fabricate( regions = add_level(N = 5, gdp = rnorm(N)), - cities = nest_level(N = sample(1:5), subways = rnorm(N, mean = gdp))) + cities = add_level(N = sample(1:5), subways = rnorm(N, mean = gdp))) expect_equal(dim(user_data), c(15, 4)) @@ -41,7 +41,7 @@ test_that("Start with existing multi-level data and add variables",{ fabricate(data = user_data, regions = modify_level(rob = paste0(regions, "r")), cities = modify_level(bob = paste0(cities, "c")), - neighborhoods = nest_level(N = 10, tmp = rnorm(N))) + neighborhoods = add_level(N = 10, tmp = rnorm(N))) expect_equal(dim(user_data_5), c(150, 8)) diff --git a/vignettes/getting_started.Rmd b/vignettes/getting_started.Rmd index 6c00ff6..5a81522 100644 --- a/vignettes/getting_started.Rmd +++ b/vignettes/getting_started.Rmd @@ -40,7 +40,7 @@ There are three things to notice about this example: my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -160,7 +160,7 @@ The real utility of this function comes when resampling from hierarchical data. my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) my_data_2 <- resample_data(my_data, N = c(3, 5), ID_labels = c("cities", "citizens")) @@ -182,7 +182,7 @@ When resampling across multiple levels, it may be useful to transparently pass t ```{r} clustered_survey <- fabricate( clusters = add_level(N=25), - cities = nest_level(N=10, population=runif(n = N, min=50000, max=1000000)) + cities = add_level(N=10, population=runif(n = N, min=50000, max=1000000)) ) cluster_resample <- resample_data(clustered_survey, N = c(clusters=ALL, cities=5)) @@ -200,7 +200,7 @@ You may want to include the mean value of a variable within a group defined by a ```{r} fabricate( cities = add_level(N = 2), - citizens = nest_level( + citizens = add_level( N = 1:2, income = rnorm(N), income_mean_city = ave(income, cities)) ) ``` @@ -213,7 +213,7 @@ When making hierarchical data, you may not want to have the same number of units my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = c(2, 4), income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = c(2, 4), income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -224,7 +224,7 @@ You can even have Ns that are determined by a function, enabling a *random* numb my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = sample(1:6, size = 2, replace = TRUE), income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = sample(1:6, size = 2, replace = TRUE), income = round(elevation * rnorm(n = N, mean = 5))) ) my_data ``` @@ -239,7 +239,7 @@ Suppose you had existing hierarchical data, and you wanted to add variables that my_baseline_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) ) # add new variables at each level @@ -264,7 +264,7 @@ library(dplyr) my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = nest_level(N = c(2, 3), income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = c(2, 3), income = round(elevation * rnorm(n = N, mean = 5))) ) %>% group_by(cities) %>% mutate(pop = n()) @@ -273,6 +273,6 @@ my_data my_data <- data_frame(Y = sample(1:10, 2)) %>% - fabricate(lower_level = nest_level(N = 3, Y2 = Y + rnorm(N))) + fabricate(lower_level = add_level(N = 3, Y2 = Y + rnorm(N))) my_data ``` From 41e40909ea05422d1828aac651555673d3aba92d Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 16:14:09 -0800 Subject: [PATCH 13/47] README.Rmd, update with Getting started example on main Github page. --- README.Rmd | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 50 ++++++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 93 insertions(+), 8 deletions(-) create mode 100644 README.Rmd diff --git a/README.Rmd b/README.Rmd new file mode 100644 index 0000000..a0048cb --- /dev/null +++ b/README.Rmd @@ -0,0 +1,51 @@ +--- +output: + md_document: + variant: markdown_github +--- + + + +```{r, echo = FALSE} +set.seed(19861108) +``` + +# fabricatr: Imagine your data before you collect it + +[![Travis-CI Build Status](https://travis-ci.org/DeclareDesign/fabricatr.svg?branch=master)](https://travis-ci.org/DeclareDesign/fabricatr) +[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/DeclareDesign/fabricatr?branch=master&svg=true)](https://ci.appveyor.com/project/DeclareDesign/fabricatr) +[![Coverage Status](https://coveralls.io/repos/github/DeclareDesign/fabricatr/badge.svg?branch=master)](https://coveralls.io/github/DeclareDesign/fabricatr?branch=master) + +Making decisions about research design and analysis strategies is often difficult before data is collected, because it is hard to imagine the exact form data will take. Instead, researchers typically modify analysis strategies to fit the data. `fabricatr` helps researchers imagine what data will look like before they collect it. Researchers can evaluate alternative analysis strategies, find the best one given how the data will look, and precommit before looking at the realized data. + +*This software is in alpha release. Please contact the authors before using in experiments or published work. Specifications, names, and arguments of functions are subject to change.* + +To install the latest development release of **fabricatr**, please ensure that you are running version 3.3 or later of R and run the following code: + +```{r, eval=F} +install.packages("fabricatr", dependencies = TRUE, + repos = c("http://R.declaredesign.org", "https://cloud.r-project.org")) +``` + +### Getting started + +Once the package is installed, it is easy to generate new data, or modify your own. The below example simulates the United States House of Representatives, where 435 members belong to two parties, and both parties and representatives have characteristics modeled in the data: + +```{r} +library(fabricatr) + +house_candidates = fabricate( + parties = add_level(N=2, + party_ideology = c(0.5, -0.5), + in_power = c(1, 0), + party_incumbents=c(241, 194)), + representatives = add_level(N=party_incumbents, + member_ideology = rnorm(N, party_ideology), + terms_served=draw_discrete(N=N, x=3, type="count"), + female=draw_discrete(N=N, x=0.2, type="bernoulli"))) +head(house_candidates) +``` + +For more information, use the command `?fabricate` in R to explore our documentation or [click here](http://fabricatr.declaredesign.org/articles/getting_started.html) to read our online tutorial. + +This project is generously supported by a grant from the [Laura and John Arnold Foundation](http://www.arnoldfoundation.org) and seed funding from [EGAP](http://egap.org). diff --git a/README.md b/README.md index d041594..f340109 100644 --- a/README.md +++ b/README.md @@ -1,20 +1,54 @@ -# fabricatr: Imagine your data before you collect it + +fabricatr: Imagine your data before you collect it +================================================== -[![Travis-CI Build Status](https://travis-ci.org/DeclareDesign/fabricatr.svg?branch=master)](https://travis-ci.org/DeclareDesign/fabricatr) -[![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/DeclareDesign/fabricatr?branch=master&svg=true)](https://ci.appveyor.com/project/DeclareDesign/fabricatr) -[![Coverage Status](https://coveralls.io/repos/github/DeclareDesign/fabricatr/badge.svg?branch=master)](https://coveralls.io/github/DeclareDesign/fabricatr?branch=master) +[![Travis-CI Build Status](https://travis-ci.org/DeclareDesign/fabricatr.svg?branch=master)](https://travis-ci.org/DeclareDesign/fabricatr) [![AppVeyor Build Status](https://ci.appveyor.com/api/projects/status/github/DeclareDesign/fabricatr?branch=master&svg=true)](https://ci.appveyor.com/project/DeclareDesign/fabricatr) [![Coverage Status](https://coveralls.io/repos/github/DeclareDesign/fabricatr/badge.svg?branch=master)](https://coveralls.io/github/DeclareDesign/fabricatr?branch=master) Making decisions about research design and analysis strategies is often difficult before data is collected, because it is hard to imagine the exact form data will take. Instead, researchers typically modify analysis strategies to fit the data. `fabricatr` helps researchers imagine what data will look like before they collect it. Researchers can evaluate alternative analysis strategies, find the best one given how the data will look, and precommit before looking at the realized data. -This software is in alpha release. +*This software is in alpha release. Please contact the authors before using in experiments or published work. Specifications, names, and arguments of functions are subject to change.* To install the latest development release of **fabricatr**, please ensure that you are running version 3.3 or later of R and run the following code: -``` +``` r install.packages("fabricatr", dependencies = TRUE, repos = c("http://R.declaredesign.org", "https://cloud.r-project.org")) ``` -This project is generously supported by a grant from the [Laura and John Arnold Foundation](http://www.arnoldfoundation.org) and seed funding from [EGAP](http://egap.org). +### Getting started + +Once the package is installed, it is easy to generate new data, or modify your own. The below example simulates the United States House of Representatives, where 435 members belong to two parties, and both parties and representatives have characteristics modeled in the data: -(c) 2015 Graeme Blair, Jasper Cooper, Alexander Coppock, and Macartan Humphreys. All rights reserved. +``` r +library(fabricatr) + +house_candidates = fabricate( + parties = add_level(N=2, + party_ideology = c(0.5, -0.5), + in_power = c(1, 0), + party_incumbents=c(241, 194)), + representatives = add_level(N=party_incumbents, + member_ideology = rnorm(N, party_ideology), + terms_served=draw_discrete(N=N, x=3, type="count"), + female=draw_discrete(N=N, x=0.2, type="bernoulli"))) +head(house_candidates) +``` + + ## parties party_ideology in_power party_incumbents representatives + ## 1 1 0.5 1 241 001 + ## 2 1 0.5 1 241 002 + ## 3 1 0.5 1 241 003 + ## 4 1 0.5 1 241 004 + ## 5 1 0.5 1 241 005 + ## 6 1 0.5 1 241 006 + ## member_ideology terms_served female + ## 1 1.26410289 2 0 + ## 2 0.59186750 2 0 + ## 3 0.04551557 2 1 + ## 4 0.02327683 3 0 + ## 5 1.53852440 6 0 + ## 6 -0.49976146 4 0 + +For more information, use the command `?fabricate` in R to explore our documentation or [click here](http://fabricatr.declaredesign.org/articles/getting_started.html) to read our online tutorial. + +This project is generously supported by a grant from the [Laura and John Arnold Foundation](http://www.arnoldfoundation.org) and seed funding from [EGAP](http://egap.org). From 2416330ba191333d3d92777944905d13ea888870 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 18:04:49 -0800 Subject: [PATCH 14/47] Bugfixes for row names when resampling, bugfix for adding variables to imported data single-level --- R/fabricate.R | 2 +- R/resample_data.R | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 9f6e22d..e153fdf 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -145,7 +145,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # Run the level adder, report the results, and return return( report_results( - add_level(N = N, ID_label = ID_label, data_arguments = data_arguments) + add_level(N = N, ID_label = ID_label, data_arguments = data_arguments, new_hierarchy=TRUE) ) ) } diff --git a/R/resample_data.R b/R/resample_data.R index 51d96bf..755ae32 100644 --- a/R/resample_data.R +++ b/R/resample_data.R @@ -57,7 +57,9 @@ resample_data = function(data, N, ID_labels=NULL) { # Mask internal outer_level and use_dt arguments from view. - .resample_data_internal(data, N, ID_labels) + df = .resample_data_internal(data, N, ID_labels) + rownames(df) = NULL + return(df) } #' Magic number constant to allow users to specify "ALL" for passthrough resampling From 5e6e95ba8c036878ea63a48b04bc61510dc82d40 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 18:05:00 -0800 Subject: [PATCH 15/47] Complete rewrite and expansion of vignette. --- vignettes/getting_started.Rmd | 319 ++++++++++++++++++++++------------ 1 file changed, 204 insertions(+), 115 deletions(-) diff --git a/vignettes/getting_started.Rmd b/vignettes/getting_started.Rmd index 5a81522..1f0c205 100644 --- a/vignettes/getting_started.Rmd +++ b/vignettes/getting_started.Rmd @@ -1,6 +1,6 @@ --- -title: "Getting Started with Fabricatr" -author: "Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys" +title: "Getting Started with Fabricatr and Imagining Your Data Before You Collect It" +author: "Aaron Rudkin" date: "`r Sys.Date()`" output: rmarkdown::html_vignette toc: true @@ -10,15 +10,17 @@ vignette: > %\VignetteEncoding{UTF-8} --- -`fabricatr` is a package designed to help you imagine your data before you collect it. While many solutions exist for creating simulated datasets, `fabricatr` is specifically designed to make the creation of realistic social science datasets easy. In particular, we need to be able to imagine **correlated** data and **hierarchical** data. +`fabricatr` is a package designed to help you imagine your data before you collect it. While many solutions exist for creating simulated datasets, `fabricatr` is specifically designed to make the creation of realistic social science datasets easy. In particular, we need to be able to imagine **correlated** data and **hierarchical** data. `fabricatr` is designed to integrate into a [tidyverse](https://www.tidyverse.org/) workflow, and to allow users to imagine data from scratch or by modifying existing data. +`fabricatr` is a member of the `DeclareDesign` software suite that also includes the `r` packages [randomizr](randomizr.declaredesign.org), [estimatr](estimatr.declaredesign.org), and [Declare Design](declaredesign.org). -`fabricatr` is a member of the `DeclareDesign` software suite that includes the `r` packages [randomizr](randomizr.declaredesign.org), [estimatr](estimatr.declaredesign.org), and [Declare Design](declaredesign.org). `fabricatr` plays well with the [tidyverse](https://www.tidyverse.org/). +# Basics +Using `fabricatr` begins by making a call to the function `fabricate`. `fabricate` can be used to create single-level of hierarchical data. There are three main ways to call `fabricate`: making a single-level dataset by specifying how many observations you would like; making a single-level dataset by importing data and optionally modifying it by creating new variables; and making a hierarchical dataset. -# Basics +# Single-level datasets from scratch -The workhorse function is `fabricate`. You provide a number to `N`, then a series of named functions. A nice feature is that you can use `N` as an argument to any of the functions you supply. Later functions can depend on values defined earlier, making the creation of correlated data easy +Making a single-level dataset begins with providing the argument `N`, a number representing the number of observations you wish to create, followed by a series of variable definitions. Variables can be defined using any function you have access to in R. `fabricatr` provides several simple functions for generating common types of data. These are covered below. Functions that create subsequent variables can rely on previously created variables, which ensures that variables can be correlated with one another: ```{r} library(fabricatr) @@ -26,158 +28,290 @@ my_data <- fabricate(N = 5, Y = runif(N), Y2 = Y*5) my_data ``` +# Single-level datasets using existing data + +Instead of specifying the argument `N`, users can specify the argument `data` to import existing datasets. Once a dataset is imported, subsequent variables have access to `N`, representing the number of observations in the imported data. This makes it easy to augment existing data with simulations based on that data: + +```{r} +# This example makes use of the "quakes" dataset, built into R +# which describes earthquakes off the coast of Fiji. The "mag" +# variable contains the richter magnitude of the earthquakes. + +simulated_quake_data = fabricate(data=quakes, + fatalities = round(pmax(0, rnorm(N, mean=mag)) * 100), + insurance_cost = fatalities * runif(N, 1000000, 2000000)) +head(simulated_quake_data) +``` + +Notice that variable creation calls are able to make reference to both the variables in the imported data set, and newly created variables. Also, function calls can be arbitrarily nested -- the variable fatalities uses several nested function calls. + # Hierarchical data -We can create hierarchical data through use of the `level` function. In the example below, we create 2 cities, each with an elevation. We then create 3 citizens per city, each with an income. +The most powerful use of `fabricatr` is to create hierarchical ("nested") data. In the example below, we create 5 countries, each of which has 10 provinces: + +```{r} +country_data <- + fabricate( + countries = add_level(N = 5, + gdp_per_capita = runif(N, min=10000, max=50000), + life_expectancy = 50 + runif(N, 10, 20) + ((gdp_per_capita > 30000) * 10)), + provinces = add_level(N = 10, + has_natural_resources = draw_discrete(x=0.3, N=N, type="bernoulli"), + has_manufacturing = draw_discrete(x=0.7, N=N, type="bernoulli")) + ) +head(country_data) +``` + +Several things can be observed in this example. First, fabricate knows that your second `add_level` command will be nested under the first level of data. Each level gets its own ID variable, in addition to the variables you create. Second, the meaning of the variable "N" changes. During the `add_level` call for countries, N is 5. During the `add_level` call for provinces, N is 10. And the resulting data, of course, has 50 observations. + +Finally, the province-level variables are created using the `draw_discrete` function. This is a function provided by `fabricatr` to make simulating discrete random variables simple. When you simulate your own data, you can use `fabricatr`'s functions, R's built-ins, or any custom functions you wish. We continue our exploration of `draw_discrete` below. + +# Adding hierarchy to existing data + +`fabricatr` is also able to import existing data and nest hierarchical data under it. This maybe be useful if, for example, you have existing country-level data but wish to simulate data at lower geographical levels for the purposes of an experiment you plan to conduct. + +Imagine importing the country-province data simulated in the previous example. Because `fabricate` returns a data frame, this simulated data can be re-imported into a subsequent fabricate call, just like external data can be. + +```{r} +citizen_data <- + fabricate( + data = country_data, + citizens = add_level(N=10, + salary = rnorm(N, + mean = gdp_per_capita + + has_natural_resources * 5000 + + has_manufacturing * 5000, + sd = 10000))) +head(citizen_data) +``` + +In this example, we add a third level of data; for each of our 50 country-province observations, we now have 10 citizen-level observations. Citizen-level covariates like salary can draw from both the country-level covariate and the province-level covariate. + +Notice that the syntax for adding a new nested level to existing data is different than the syntax for adding new variables to the original dataset. + +# More complicated level creation with variable numbers of observations + +`add_level` can be used to create more complicated patterns of nesting. For example, when creating lower level data, it is possible to use a different `N` for each of the values of the higher level data: + +```{r} +variable_data <- + fabricate( + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = c(2, 4), age = runif(N, 18, 70)) + ) +variable_data +``` -There are three things to notice about this example: +Here, each city has a different number of citizens. And the value of `N` used to create the age variable automatically updates as needed. The result is a dataset with 6 citizens, 2 in the first city and 4 in the second. As long as N is either a number, or a vector of the same length of the current lowest level of the data, `add_level` will know what to do. -1. The meaning of `N` changes. In the `cities` line, `N` means 2, the number of cities. In the `citizens` line, `N` means 3, the number of citizens. -2. The data created at the cities level is **constant** within cities. Each city has its own elevation. The data created at the citizens level is **not** constant within cities. -3. Variables created at a lower level can depend on variables created at a higher level. Citizen's income depends on the elevation of cities. +It is also possible to provide a function to N, enabling a *random* number of citizens per city: ```{r} my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = sample(1:6, size = 2, replace = TRUE), + age = runif(N, 18, 70)) ) my_data ``` -# Fabricating variables +Here, each city is given a random number of citizens between 1 and 6. Since the `sample` function returns a vector of length 2, this is like specifying 2 separate `N`s as in the example above. -You can use any R function to fabricate a variable. For example, if you want to fabricate a random normal variable, you can use the base `R` function `rnorm()`, i.e.: +Finally, it is possible to define `N` on the basis of higher level variables themselves. Consider the following example: ```{r} -fabricate(N = 3, normal_var = rnorm(N)) +fabricate( + cities = add_level(N = 5, population = runif(N, 10, 200)), + citizens = add_level(N = round(population * 0.3)) +) ``` -Now, what if you want to fabricate discrete variables like binary variables or counts? +Here, the city has a defined population, and the number of citizens in our simulated data reflects a sample of 30% of that population. Each city has a different population, so each city gets a different number of citizens in this example. -## Binary can be called as binary, bernoulli, or binomial +## Modifying existing levels + +Suppose you have hierarchical data, and wish to simulate variables at a higher level of aggregation. For example, imagine you import a dataset containing citizens within countries, but you wish to simulate additional country-level variables. In `fabricatr`, you can do this using the `modify_level` command. + +Let's use our country-province data from earlier: ```{r} -fabricate(N = 3, p = c(0, .5, 1), - binary = draw_discrete(p)) +new_country_data <- + fabricate( + data = country_data, + countries = modify_level(average_temperature = runif(N, 30, 80)) + ) + +head(new_country_data) ``` +Two things are worth noting. First, observe that in the resulting data, the new variable is created at the level of aggregation you chose -- countries. Second, although N is not specified anywhere, `modify_level` knows how large N should be based on the number of countries it finds in the dataset. It is important, then, to ensure that the `modify_level` command is correctly assigned to the level of interest. + +We can also modify more than one level. Recalling our country-province-citizen data from above, the following process is possible: + +```{r} +new_citizen_data <- + fabricate( + data = citizen_data, + countries = modify_level(average_temperature = runif(N, 30, 80)), + provinces = modify_level(conflict_zone = draw_discrete(N, + x=0.2 + has_natural_resources*0.3, + type="binary"), + infant_mortality = runif(N, 0, 10) + + conflict_zone*10 + + (average_temperature > 70)*10), + citizens = modify_level(college_degree = draw_discrete(N, x=0.4 - (0.3*conflict_zone), type="binary")) + ) +``` + +Before assessing what this tells us about `modify_level`, let's consider what the data simulated does. It creates a new variable at the country level, for a country level average temperature. Subsequently, it creates a province level binary indicator for whether the province is an active conflict site. Provinces that have natural resources are more likely to be in conflict in this simulation, drawing on conclusions from literature on "resource curses". The infant mortality rate for the province is able to depend both on province level data we have just generated, and country-level data: it is higher in high-temperature areas (reflecting literature on increased disease burden near the equator) and also higher in conflict zones. Citizens access to education is also random, but depends on whether they live in a conflict area. + +There are a lot of things to learn from this example. First, it's possible to modify multiple levels. Any new variable created will automatically propagate to the lower level data according -- by setting an average temperature for a country, all provinces, and all citizens of those provinces, have the value for the country. Values created from one `modify_level` call can be used in subsequent variables of the same call, or subsequent calls. + +Again, we see the use of `draw_discrete`. We will now discusss this function, which can be used to generate many common discrete data types. + +# Fabricating discrete random variables. + +## Binary and binomial outcomes + +The simplest possible type of data, and `draw_discrete`'s default, is a binary random variable (also called a bernoulli random variable). Generating a binary random variable requires only one parameter `x` which specifies the probability that outcomes drawn from this variable are equal to 1. By default, `draw_discrete` will generate `N = length(x)` draws. `N` can also be specified explicitly. Consider these examples: -## Binary can be called as binary, bernoulli, or binomial ```{r} fabricate(N = 3, p = c(0, .5, 1), - binary = draw_discrete(p, type = "bernoulli")) + binary_1 = draw_discrete(x=p), + binary_2 = draw_discrete(N=3, x=0.5)) ``` -## Binary with link +`draw_discrete` additionally takes an argument `type`, which specifies which type of random variable you wish to draw outcomes from. The default argument here is "binary" -- other aliases include "bernoulli" or "binomial". A simple alias to `draw_discrete(type="binary")` is `draw_binary`. All of the variables created here are equivalent: + ```{r} -fabricate(N = 3, x = 10*rnorm(N), - binary = draw_discrete(x, type = "bernoulli", link = "probit")) +fabricate(N = 3, + binary_1 = draw_discrete(N=N, x=0.5, type="binary"), + binary_2 = draw_discrete(N=N, x=0.5, type="bernoulli"), + binary_3 = draw_discrete(N=N, x=0.5, type="binomial"), + binary_4 = draw_binary(N=N, x=0.5) +) ``` -## Binomial +In addition to binary variables, `draw_discrete` supports repeated Bernoulli trials ("binomial" data). This requires specifying an argument `k`, equal to the number of trials. ```{r} -fabricate(N = 3, p = c(0, .5, 1), - binomial = draw_discrete(p, type = "binomial", k = 10)) +fabricate(N = 3, + freethrows = draw_discrete(N=N, x=0.5, k=10, type="binomial") +) ``` -## Binomial with link +Some researchers may be interested in specifying probabilities through a "link function". This can be done in `draw_discrete` through the `link` argument. The default link function is "identity", but we also support "logit", and "probit". These link functions transform continuous and unbounded latent data into probabilities of a positive outcome. ```{r} fabricate(N = 3, x = 10*rnorm(N), - binomial = draw_discrete(x, type = "binomial", k = 10, link = "logit")) + binary = draw_discrete(x=x, type = "bernoulli", link = "probit")) ``` -## Ordered requires cutoffs +## Ordered outcomes + +Some researchers may be interested in generating ordered outcomes -- for example, Likert scale outcomes. This can be done using the "ordered" type. Ordered variables require a vector of breakpoints, supplied as the argument `breaks` -- points at which the underlying latent variable switches from category to category. The first break should always be below the lower bound of the data, while the final break should always be above the upper bound of the data. + +In the following example, each of three observations has a latent variable `x` which is continuous and unbounded. The variable `ordered` transforms `x` into three numeric categories: 1, 2, and 3. All values of `x` below -1 result in `ordered` 1; all values of `x` between -1 and 1 result in `ordered` 2; all values of `x` above 1 result in `ordered` 3: ```{r} -set.seed(1) fabricate(N = 3, x = 5*rnorm(N), ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf))) ``` -This really just cuts the data +Ordered data also supports link functions including "logit" or "probit": -## Ordered probit ```{r} -set.seed(1) fabricate(N = 3, x = 5*rnorm(N), ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf), link = "probit")) ``` -This is actually ordered probit since x is normal. -## Count is poisson +## Count outcomes + +`draw_discrete` supports Poisson-distributed count outcomes. These require that the user specify the parameter `x`, equal to the Poisson distribution mean (often referred to as `lambda`). + ```{r} fabricate(N = 3, x = c(0,5,100), count = draw_discrete(x, type = "count")) ``` -Negative binomial easily added. Currently takes lamda as argument though could easily take a real number or a probability. +## Categorical data + +`draw_discrete` can also generate non-ordered, categorical data. Users must provide a vector of probabilities for each category (or a matrix, if each observation should have separate probabilities), as well as setting `type` to be "categorical". + +If probabilities do not sum to exactly one, they will be normalized, but negative probabilities will cause an error. + +In the first example, each unit has a different set of probabilities and the probabilities are provided as a matrix: -## Categorical takes as input a matrix of probabilities (that get normalized if they do not sum to 1) ```{r} fabricate(N = 6, - p1 = runif(N), - p2 = runif(N), - p3 = runif(N), - cat = draw_discrete(cbind(p1, p2, p3), type = "categorical")) + p1 = runif(N, 0, 1), + p2 = runif(N, 0, 1), + p3 = runif(N, 0, 1), + cat = draw_discrete(N=N, x=cbind(p1, p2, p3), type = "categorical")) ``` -This could also be set up to take latent variables in the style of multinomial probit or multinomial logit. - +In the second example, each unit has the same probability of getting a given category. `draw_discrete` will issue a warning to remind you that it is interpreting the vector in this way. +```{r} +fabricate(N = 6, + cat = draw_discrete(N=N, x=c(0.2, 0.4, 0.4), type = "categorical")) +``` -# Bringing in your own data +"categorical" variables can also use link functions, for example to generate multinomial probit data. -An essential part of imagining your data before you collect it is the ability to build on the data you all ready have. +# Simulation "resampling" from existing data. -A second way you may wish to use existing data is bootstrap a new dataset from it, thereby preserving all the natural inter-correlations. +One way to imagine new data is to take data you already have and resample it, ensuring that existing inter-correlations between variables are preserved, while generating new data or expanding the size of the dataset. `fabricatr` offers several options to simulate resampling. -## Modifying existing data +## Bootstrapping -If you have already conducted a baseline survey, you may which to imagine how the endline may deviate from it. In this case, you will want to add new variables to your existing dataset. Notice that the meaning of `N` in the definition of `Y_post` automatically refers to the number of rows in the dataset provided to the `data` argument. +The simplest option in `fabricatr` is to "bootstrap" data. Taking data with N observations, the "bootstrap" resamples these observations with replacement and generates N new observations. Existing observations may be used zero times, once, or more than once. Bootstrapping is very simple with the `resample_data` function: ```{r} -baseline_survey <- fabricate(N = 5, Y_pre = rnorm(N)) +survey_data = fabricate(N=10, + voted_republican = draw_binary(N=N, x=0.5)) -my_endline <- fabricate(data = baseline_survey, - Y_post = Y_pre + rnorm(N)) -my_endline +survey_data_new = resample_data(survey_data) +survey_data ``` -## Bootstrapping - -Suppose you wanted to bootstrap from your baseline survey. +It is also possible to resample fewer or greater number of observations from your existing data. We can do this by specifying the argument `N` to `resample_data`. Consider expanding a small dataset to allow for better imagination of larger data to be collected later. ```{r} -bootstrapped_data <- resample_data(baseline_survey, N = 10) -bootstrapped_data +large_survey_data = resample_data(survey_data, N=100) +nrow(large_survey_data) ``` -The real utility of this function comes when resampling from hierarchical data. The example below takes a dataset that contains 2 cities, each with 3 citizens, then resamples to 3 cities, each with 5 citizens. +## Resampling hierarchical data + +One of the most powerful features of all of `fabricatr` is the ability to resample from hierarchical data at any or all levels. Doing so requires specifying which levels you will want to resample with the `ID_labels` argument. Unless otherwise specified, all units from levels below the resampled level will be kept. In our earlier country-province-citizen dataset, resampling countries will lead to all provinces and citizens of the selected country being carried forward. You can resample at multiple levels simultaneously. + +Consider this example, which takes a dataset containing 2 cities of 3 citizens, and resamples it into a dataset of 3 cities, each containing 5 citizens. ```{r} my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = 3, age = runif(N, 18, 70)) ) -my_data_2 <- resample_data(my_data, N = c(3, 5), ID_labels = c("cities", "citizens")) +my_data_2 <- resample_data(my_data, + N = c(3, 5), + ID_labels = c("cities", "citizens")) my_data_2 - ``` -When resampling, level names can also be specified in an alternative manner: +`resample_data` will first select the cities to be resampled. Then, for each city, it will continue by selecting the citizens to be resampled. If a higher level unit is used more than once (for example, the same city being chosen twice), and a lower level is subsequently resampled, the choices of which units to keep for the lower level will differ for each copy of the higher level. In this example, if city 1 is chosen twice, then the sets of five citizens chosen for each copy of the city 1 will differ. +Level names can also be specified within the vector for `N`, as follows: ```{r} my_data_2 <- resample_data(my_data, N = c(cities=3, citizens=5)) my_data_2 ``` -This example also resamples our dataset of 2 cities with 3 citizens to a dataset of 3 cities (each original city may be used zero or more times in the new sample) each with 5 citizens. +## Passing through levels transparently. -When resampling across multiple levels, it may be useful to transparently pass through all units of a particular level. For example, considering data with a clustered design, it may be useful to resample some number of individual observations from each original cluster. +When resampling across multiple levels, it may be useful to transparently pass through all units of a particular level. For example, considering data with a clustered design, it may be useful to resample some number of individual observations from each original cluster. This is done by specifying the all-caps flag ALL for the number of units selected at a given level. Do not quote ALL, and ensure that it is written capitalized. ```{r} clustered_survey <- fabricate( @@ -185,11 +319,13 @@ clustered_survey <- fabricate( cities = add_level(N=10, population=runif(n = N, min=50000, max=1000000)) ) -cluster_resample <- resample_data(clustered_survey, N = c(clusters=ALL, cities=5)) +cluster_resample <- resample_data(clustered_survey, N = c(clusters=ALL, cities=2)) cluster_resample ``` -This example begins with a dataset of 25 clusters each containing 10 cities and resamples to a dataset of the same 25 clusters, each containing 5 cities (the original cities may each be used zero or more times in the resampling process). +Recall that if you used `resample_data` only on `cities`, two cities would be chosen from the entire dataset; selecting to pass through ALL clusters ensures that within each cluster, 2 cities are chosen. + +This example begins with a dataset of 25 clusters each containing 10 cities and resamples to a dataset of the same 25 clusters, each containing 2 cities (the original cities may each be used zero or more times in the resampling process). # Advanced Features @@ -205,53 +341,6 @@ fabricate( ) ``` -## Ns that vary - -When making hierarchical data, you may not want to have the same number of units at each level of the hierarchy. For example, in the example below, we want one city to have 2 citizens and the other city to have four: - -```{r} -my_data <- - fabricate( - cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = c(2, 4), income = round(elevation * rnorm(n = N, mean = 5))) - ) -my_data -``` - -You can even have Ns that are determined by a function, enabling a *random* number of citizens per city: - -```{r} -my_data <- - fabricate( - cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = sample(1:6, size = 2, replace = TRUE), income = round(elevation * rnorm(n = N, mean = 5))) - ) -my_data -``` - - -## Bringing in your own hierarchical data - -Suppose you had existing hierarchical data, and you wanted to add variables that respected the levels. - -```{r} - -my_baseline_data <- - fabricate( - cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = 3, income = round(elevation * rnorm(n = N, mean = 5))) - ) - -# add new variables at each level -my_data <- - fabricate(data = my_baseline_data, - cities = modify_level(density = elevation / 2), - citizens = modify_level(wealth = income - 100)) - -my_data - -``` - # Tidyverse integration Because the functions in `fabricatr` take data and return data, they are easily slotted into a `tidyverse` workflow: @@ -264,7 +353,7 @@ library(dplyr) my_data <- fabricate( cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = add_level(N = c(2, 3), income = round(elevation * rnorm(n = N, mean = 5))) + citizens = add_level(N = c(2, 3), age = runif(N, 18, 70)) ) %>% group_by(cities) %>% mutate(pop = n()) From 5e156f8f0d8532d0c8e9089ad9a64c971f7eb2ce Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 17 Nov 2017 18:06:03 -0800 Subject: [PATCH 16/47] Added README.Rmd to .Rbuildignore --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index cbf62b6..aed6ee3 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -1,4 +1,5 @@ ^\.travis\.yml$ +README.Rmd README.md ^.*\.Rproj$ ^\.Rproj\.user$ From e9277af13a66964585a5b836afde48fa13e192a4 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Mon, 20 Nov 2017 12:56:09 -0800 Subject: [PATCH 17/47] Fixes #32 and provisionally implements suggestion 1 for #33 --- R/fabricate.R | 7 +++++++ tests/testthat/test-fabrication.R | 5 +---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index e153fdf..8cd8b3d 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -79,6 +79,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # User provided level calls if(all_levels) { + # Ensure the user provided a name for each level call. if(is.null(names(data_arguments)) | any(names(data_arguments) == "")) { stop("You must provide a name for each level you create.") @@ -134,6 +135,10 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) stop("User supplied data must be convertible into a data frame.") }) + # Single level -- maybe the user provided an ID_label, maybe they didn't. + # Sanity check and/or construct an ID label for the new data. + ID_label = handle_id(ID_label, data) + # User passed data, not N # First, let's dynamically get N from the number of rows N = nrow(data) @@ -242,6 +247,8 @@ add_level = function(N = NULL, ID_label = NULL, # If the ID label was specified but already exists, we should still log it as a level ID add_level_id(working_environment_, ID_label) } + } else { + stop("Please specify a name for the level call you are creating.") } # Loop through each of the variable generating arguments diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index e0f1cef..bd2468d 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -126,10 +126,7 @@ test_that("trigger errors", { expect_error(fabricate(N=10, 1:N)) }) -test_that("regression broke this test", { - # same for a single level - skip("Regression broke this test -- add_level is being interpreted as a call to data") - +test_that("unusual pass of add_level call to single level generation as data matrix", { expect_error(fabricate(add_level(N = 5, gdp = rnorm(N)))) }) From f894d77b0ec0df6491ba88c62f4245af9cc491d4 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Mon, 20 Nov 2017 12:56:32 -0800 Subject: [PATCH 18/47] Documentation update Nov 20, 2017 --- README.Rmd | 3 +- README.md | 1 + docs/LICENSE.html | 5 +- docs/articles/getting_started.R | 46 +- docs/articles/getting_started.html | 755 ++++++++++++++++++++++------- docs/articles/index.html | 5 +- docs/authors.html | 7 +- docs/index.html | 61 ++- docs/news/index.html | 3 +- docs/pkgdown.css | 11 +- docs/pkgdown.js | 37 ++ docs/reference/ALL.html | 145 ++++++ docs/reference/draw_discrete.html | 224 +++++++++ docs/reference/fabricate.html | 64 ++- docs/reference/fabricatr.html | 3 +- docs/reference/index.html | 21 +- docs/reference/level.html | 46 +- docs/reference/resample_data.html | 127 +++-- 18 files changed, 1270 insertions(+), 294 deletions(-) create mode 100644 docs/reference/ALL.html create mode 100644 docs/reference/draw_discrete.html diff --git a/README.Rmd b/README.Rmd index a0048cb..12015ce 100644 --- a/README.Rmd +++ b/README.Rmd @@ -1,7 +1,6 @@ --- output: - md_document: - variant: markdown_github + github_document --- diff --git a/README.md b/README.md index f340109..efef322 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,4 @@ + fabricatr: Imagine your data before you collect it ================================================== diff --git a/docs/LICENSE.html b/docs/LICENSE.html index 69839d5..51e067a 100644 --- a/docs/LICENSE.html +++ b/docs/LICENSE.html @@ -52,6 +52,9 @@ diff --git a/docs/index.html b/docs/index.html index 0a9590a..b1ee724 100644 --- a/docs/index.html +++ b/docs/index.html @@ -15,7 +15,7 @@ -
+
-
-
+
+ + + + +
+ +

fabricatr: Imagine your data before you collect it

Making decisions about research design and analysis strategies is often difficult before data is collected, because it is hard to imagine the exact form data will take. Instead, researchers typically modify analysis strategies to fit the data. fabricatr helps researchers imagine what data will look like before they collect it. Researchers can evaluate alternative analysis strategies, find the best one given how the data will look, and precommit before looking at the realized data.

-

This software is in alpha release.

+

This software is in alpha release. Please contact the authors before using in experiments or published work. Specifications, names, and arguments of functions are subject to change.

To install the latest development release of fabricatr, please ensure that you are running version 3.3 or later of R and run the following code:

-
install.packages("fabricatr", dependencies = TRUE,
-  repos = c("http://install.declaredesign.org", "https://cloud.r-project.org"))
+
install.packages("fabricatr", dependencies = TRUE,
+  repos = c("http://R.declaredesign.org", "https://cloud.r-project.org"))
+
+

+Getting started

+

Once the package is installed, it is easy to generate new data, or modify your own. The below example simulates the United States House of Representatives, where 435 members belong to two parties, and both parties and representatives have characteristics modeled in the data:

+
library(fabricatr)
+
+house_candidates = fabricate(
+  parties = add_level(N=2, 
+                      party_ideology = c(0.5, -0.5), 
+                      in_power = c(1, 0), 
+                      party_incumbents=c(241, 194)),
+  representatives = add_level(N=party_incumbents, 
+                              member_ideology = rnorm(N, party_ideology), 
+                              terms_served=draw_discrete(N=N, x=3, type="count"),
+                              female=draw_discrete(N=N, x=0.2, type="bernoulli")))
+head(house_candidates)
+
##   parties party_ideology in_power party_incumbents representatives
+## 1       1            0.5        1              241             001
+## 2       1            0.5        1              241             002
+## 3       1            0.5        1              241             003
+## 4       1            0.5        1              241             004
+## 5       1            0.5        1              241             005
+## 6       1            0.5        1              241             006
+##   member_ideology terms_served female
+## 1      1.26410289            2      0
+## 2      0.59186750            2      0
+## 3      0.04551557            2      1
+## 4      0.02327683            3      0
+## 5      1.53852440            6      0
+## 6     -0.49976146            4      0
+

For more information, use the command ?fabricate in R to explore our documentation or click here to read our online tutorial.

This project is generously supported by a grant from the Laura and John Arnold Foundation and seed funding from EGAP.

-

(c) 2015 Graeme Blair, Jasper Cooper, Alexander Coppock, and Macartan Humphreys. All rights reserved.

+
+
- diff --git a/docs/news/index.html b/docs/news/index.html index fc9e9a2..c3ecb2d 100644 --- a/docs/news/index.html +++ b/docs/news/index.html @@ -23,7 +23,8 @@ - + + diff --git a/docs/pkgdown.css b/docs/pkgdown.css index 9c437c7..209ce57 100644 --- a/docs/pkgdown.css +++ b/docs/pkgdown.css @@ -34,6 +34,10 @@ img.icon { float: right; } +img { + max-width: 100%; +} + /* Section anchors ---------------------------------*/ a.anchor { @@ -133,9 +137,14 @@ pre, code { color: #333; } -pre img { +pre .img { + margin: 5px 0; +} + +pre .img img { background-color: #fff; display: block; + height: auto; } code a, pre a { diff --git a/docs/pkgdown.js b/docs/pkgdown.js index c8b38c4..4b81713 100644 --- a/docs/pkgdown.js +++ b/docs/pkgdown.js @@ -5,4 +5,41 @@ $(function() { offset: 60 }); + var cur_path = paths(location.pathname); + $("#navbar ul li a").each(function(index, value) { + if (value.text == "Home") + return; + if (value.getAttribute("href") === "#") + return; + + var path = paths(value.pathname); + if (is_prefix(cur_path, path)) { + // Add class to parent
  • , and enclosing
  • if in dropdown + var menu_anchor = $(value); + menu_anchor.parent().addClass("active"); + menu_anchor.closest("li.dropdown").addClass("active"); + } + }); }); + +function paths(pathname) { + var pieces = pathname.split("/"); + pieces.shift(); // always starts with / + + var end = pieces[pieces.length - 1]; + if (end === "index.html" || end === "") + pieces.pop(); + return(pieces); +} + +function is_prefix(needle, haystack) { + if (needle.length > haystack.lengh) + return(false); + + for (var i = 0; i < haystack.length; i++) { + if (needle[i] != haystack[i]) + return(false); + } + + return(true); +} diff --git a/docs/reference/ALL.html b/docs/reference/ALL.html new file mode 100644 index 0000000..be438d3 --- /dev/null +++ b/docs/reference/ALL.html @@ -0,0 +1,145 @@ + + + + + + + + +Magic number constant to allow users to specify "ALL" for passthrough resampling — ALL • fabricatr + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    +
    + + + +
    + +
    +
    +
    +

    Magic number constant to allow users to specify "ALL" for passthrough resampling

    +
    + + +

    Magic number constant to allow users to specify "ALL" for passthrough resampling

    + + + 
    ALL
    + +

    Format

    + +

    An object of class integer of length 1.

    + + +
    + +
    + +
    +
    +

    Developed by Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys.

    +
    + +
    +

    Site built with pkgdown.

    +
    + +
    +
    + + + diff --git a/docs/reference/draw_discrete.html b/docs/reference/draw_discrete.html new file mode 100644 index 0000000..3149b9c --- /dev/null +++ b/docs/reference/draw_discrete.html @@ -0,0 +1,224 @@ + + + + + + + + +Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical — draw_discrete • fabricatr + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    +
    + + + +
    + +
    +
    +
    +

    Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical

    +
    + + +

    Drawing discrete data based on probabilities or latent traits is a common task that can be cumbersome. draw_binary is an alias for draw_discrete(type = "binary") that allows you to draw binary outcomes more easily.

    + + + 
    draw_discrete(x, N = length(x), type = "binary", link = "identity",
+  breaks = c(-Inf, 0, Inf), break_labels = FALSE, k = 1)
+
+draw_binary(x, N = length(x), link = "identity")
    + +

    Arguments

    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    x

    vector representing either the latent variable used to draw the count outcome (if link is "logit" or "probit") or the probability for the count outcome (if link is "identity"). For cartegorical distributions x is a matrix with as many columns as possible outcomes.

    N

    number of units to draw. Defaults to the length of the vector x

    type

    type of discrete outcome to draw, one of 'binary' (or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count'

    link

    link function between the latent variable and the probability of a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" link, the latent variable must be a probability.

    breaks

    vector of breaks to cut an ordered latent outcome

    break_labels

    vector of labels for the breaks for an ordered latent outcome (must be the same length as breaks)

    k

    the number of trials (zero or more)

    + + +

    Examples

    + 
    fabricate(N = 3,
+   p = c(0, .5, 1),
+   binary = draw_discrete(p))
    #>   ID   p binary
+#> 1  1 0.0      0
+#> 2  2 0.5      0
+#> 3  3 1.0      1
    
+fabricate(N = 3,
+   p = c(0, .5, 1),
+   binary = draw_discrete(p, type = "bernoulli"))
    #>   ID   p binary
+#> 1  1 0.0      0
+#> 2  2 0.5      1
+#> 3  3 1.0      1
    
+fabricate(N = 3,
+   x = 10*rnorm(N),
+   binary = draw_discrete(x, type = "bernoulli", link = "probit"))
    #>   ID            x binary
+#> 1  1   2.55317055      1
+#> 2  2 -24.37263611      0
+#> 3  3  -0.05571287      1
    
+fabricate(N = 3,
+   p = c(0, .5, 1),
+   binomial = draw_discrete(p, type = "binomial", k = 10))
    #>   ID   p binomial
+#> 1  1 0.0        0
+#> 2  2 0.5        4
+#> 3  3 1.0       10
    
+fabricate(N = 3,
+   x = 5*rnorm(N),
+   ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf)))
    #>   ID         x ordered
+#> 1  1 -9.109088       1
+#> 2  2 -1.236627       1
+#> 3  3 -1.220998       1
    
+fabricate(N = 3,
+   x = c(0,5,100),
+   count = draw_discrete(x, type = "count"))
    #>   ID   x count
+#> 1  1   0     0
+#> 2  2   5     4
+#> 3  3 100   119
    
+# Categorical
+fabricate(N = 6, p1 = runif(N), p2 = runif(N), p3 = runif(N),
+         cat = draw_discrete(cbind(p1, p2, p3), type = "categorical"))
    #>   ID         p1         p2        p3 cat
+#> 1  1 0.67838043 0.53021246 0.6364656   1
+#> 2  2 0.73531960 0.69582388 0.4790245   2
+#> 3  3 0.19595673 0.68855600 0.4321713   2
+#> 4  4 0.98053967 0.03123033 0.7064338   3
+#> 5  5 0.74152153 0.22556253 0.9485766   1
+#> 6  6 0.05144628 0.30083081 0.1803388   2
    +
    + +
    + +
    +
    +

    Developed by Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys.

    +
    + +
    +

    Site built with pkgdown.

    +
    + +
    +
    + + + diff --git a/docs/reference/fabricate.html b/docs/reference/fabricate.html index 25eb291..1d1605f 100644 --- a/docs/reference/fabricate.html +++ b/docs/reference/fabricate.html @@ -23,7 +23,8 @@ - + + @@ -107,10 +108,16 @@

    Fabricate data

    • -

    fabricate helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing data to fabricate()) or start from scratch by defining N. Create hierarchical data with multiple levels of data such as citizens within cities within states using level(). You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, draw_binary and draw_count.

    +

    fabricate helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing data to fabricate()) or start from scratch by defining N. Create hierarchical data with multiple levels of data such as citizens within cities within states using add_level() or modify existing hierarchical data using modify_level(). You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, draw_binary and draw_discrete.

    - 
    fabricate(data = NULL, N = NULL, ID_label = NULL, ...)
    + 
    fabricate(data = NULL, N = NULL, ID_label = NULL, ...)
+
+add_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ...,
+  data_arguments = quos(...), new_hierarchy = FALSE)
+
+modify_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ...,
+  data_arguments = quos(...))

    Arguments

    @@ -121,7 +128,7 @@

    Ar

    - + @@ -129,7 +136,19 @@

    Ar

    - + + + + + + + + + + + + +
    N

    (optional) number of units to draw, if drawing a single level of data (i.e. not hierarchical data)

    (optional) number of units to draw. If provided as fabricate(N = 5), this determines the number of units in the single-level data. If provided in level, i.e. fabricate(cities = level(N = 5)), N determines the number of units in a specific level of a hierarchical dataset.
    ID_label
    ...

    Variable or level-generating arguments, such as my_var = rnorm(N). You may also pass level() arguments, which define a level of a multi-level dataset. For example, you could send to ... my_level = level(N = 5, var = rnorm). See examples.

    Variable or level-generating arguments, such as my_var = rnorm(N). For fabricate, you may also pass add_level() or modify_level() arguments, which define a level of a multi-level dataset. See examples.

    working_environment_

    Internal argument, not intended for end-user use.

    data_arguments

    Internal argument, not intended for end-user use.

    new_hierarchy

    Reserved argument for future functionality to add cross-classified data. Not yet implemented.
    @@ -155,12 +174,12 @@

    Examp height_ft = runif(N, 3.5, 8) ) head(df)

    #> ID height_ft -#> 1 001 5.867480 -#> 2 002 7.298735 -#> 3 003 4.111960 -#> 4 004 5.194103 -#> 5 005 4.684889 -#> 6 006 5.740338
    +#> 1 001 6.945201 +#> 2 002 6.963537 +#> 3 003 7.958205 +#> 4 004 7.867344 +#> 5 005 5.251322 +#> 6 006 5.575339
    # Start with existing data df <- fabricate( data = df, @@ -170,21 +189,22 @@

    Examp # Draw a two-level hierarchical dataset # containing cities within regions df <- fabricate( - regions = level(N = 5), - cities = level(N = 2, pollution = rnorm(N, mean = 5))) + regions = add_level(N = 5), + cities = add_level(N = 2, pollution = rnorm(N, mean = 5))) head(df)

    #> regions cities pollution -#> 1 1 01 6.518193 -#> 2 1 02 4.615993 -#> 3 2 03 6.827125 -#> 4 2 04 4.448508 -#> 5 3 05 4.134246 -#> 6 3 06 4.656169
    +#> 1 1 01 5.239065 +#> 2 1 02 5.236321 +#> 3 2 03 4.740881 +#> 4 2 04 5.649046 +#> 5 3 05 3.782359 +#> 6 3 06 5.841970
    # Start with existing data and add variables to hierarchical data -# note: do not provide N when adding variables to an existing level +# at levels which are already present in the existing data. +# Note: do not provide N when adding variables to an existing level df <- fabricate( data = df, - regions = level(watershed = sample(c(0, 1), N, replace = TRUE)), - cities = level(runoff = rnorm(N)) + regions = modify_level(watershed = sample(c(0, 1), N, replace = TRUE)), + cities = modify_level(runoff = rnorm(N)) )
    From 8b2cde99715be1b6600f3595b184f6b44bb64f6b Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 28 Nov 2017 14:55:58 -0800 Subject: [PATCH 19/47] Added draw_binary_icc and did line length trimming on variable_creation_functions. --- NAMESPACE | 1 + R/draw_binary_icc.R | 103 +++++++++++++++++++++ R/fabricate.R | 157 +++++++++++++++++++++----------- R/variable_creation_functions.R | 59 ++++++++---- man/draw_binary_icc.Rd | 45 +++++++++ man/draw_discrete.Rd | 29 ++++-- man/fabricate.Rd | 29 +++++- man/level.Rd | 6 +- tests/testthat/test-variables.R | 27 ++++++ 9 files changed, 371 insertions(+), 85 deletions(-) create mode 100644 R/draw_binary_icc.R create mode 100644 man/draw_binary_icc.Rd diff --git a/NAMESPACE b/NAMESPACE index 97663a4..b4d5298 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,6 +3,7 @@ export(ALL) export(add_level) export(draw_binary) +export(draw_binary_icc) export(draw_discrete) export(fabricate) export(level) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R new file mode 100644 index 0000000..ef9266f --- /dev/null +++ b/R/draw_binary_icc.R @@ -0,0 +1,103 @@ +#' Draw binary data with fixed intra-cluster correlation. +#' +#' Data is generated according to the following algorithm, where \eqn{i} is +#' the index of a cluster and \eqn{j} is the index of a unit: \deqn{z_i ~ +#' Bernoulli(p_i) \cr +#' y_{ij} ~ Bernoulli(p_{ij}) \cr +#' u_{ij} ~ Bernoulli(sqrt(\rho)) \cr +#' x_{ij} = (u_{ij}) z_i + (1 - u_{ij}) y_{ij}} +#' +#' This system of equations ensures inter-cluster correlation 0, intra-cluster +#' correlation in expectation \eqn{\rho}. Algorithm from Hossein, Akhtar. +#' "ICCbin: An R Package Facilitating Clustered Binary Data Generation, and +#' Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data". +#' We rederived the analytical properties of this data and did a simulation +#' study to confirm that the data generated ensured the ICC we mentioned. +#' +#' @param x A number or vector of numbers, one probability per cluster. +#' @param N (Optional) A number indicating the number of observations to be +#' generated. Must be equal to length(cluster_ids) if provided. +#' @param cluster_ids A vector of factors or items that can be coerced to +#' clusters; the length will determine the length of the generated data. +#' @param rho A number indicating the desired RCC. +#' @return A vector of binary numbers corresponding to the observations from +#' the supplied cluster IDs. +#' @examples +#' cluster_ids = rep(1:5, 10) +#' draw_binary_icc(cluster_ids = cluster_ids) +#' draw_binary_icc(x = 0.5, cluster_ids = cluster_ids, rho = 0.5) +#' +#' @importFrom stats rbinom +#' +#' @export +draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { + # Let's not worry about how cluster_ids are provided + tryCatch({ + cluster_ids = as.numeric(as.factor(cluster_ids)) + }, error=function(e) { + stop("Error coercing cluster IDs to factor levels.") + }) + number_of_clusters = length(unique(cluster_ids)) + + # Sanity check x + if(!length(x) %in% c(1, number_of_clusters)) { + stop("x must be either one number or one number per cluster.") + } + if(!is.null(N) && !is.numeric(N)) { + stop("If you provide an N, it must be numeric.") + } + if(!is.null(N) && N != length(cluster_ids)) { + stop("If you provide an N, it must be equal to the length of provided + cluster ids") + } + if(!is.vector(x)) { + stop("x must be a number or vector of numbers.") + } + if(any(!is.numeric(x))) { + stop("x must be a number or vector of numbers.") + } + if(any(x > 1 | x < 0)) { + stop("x must be numeric probabilities between 0 and 1 inclusive.") + } + + # Sanity check rho + if(length(rho) > 1) { + stop("rho must be a single number.") + } + if(!is.numeric(rho)) { + stop("rho must be a number.") + } + if(rho > 1 | rho < 0) { + stop("rho must be a number between 0 and 1.") + } + + # Generate cluster and individual probabilities + if(length(x) == 1) { + cluster_prob = rep(x, number_of_clusters) + } else { + cluster_prob = x + } + # Individual probabilities: subset operator maps cluster probs to units. + individual_prob = cluster_prob[cluster_ids] + + # Draw the z_ijs + cluster_draw = rbinom(n = number_of_clusters, + size = 1, + prob = cluster_prob)[cluster_ids] + + # Draw the y_ijs + individual_draw = rbinom(n = length(cluster_ids), + size = 1, + prob = individual_prob) + + # Draw the u_ijs -- sqrt(rho) because the actual ICC for this data will be + # rho^2 -- sqrt(rho^2) = rho, to ensure users can enter in the terms they feel + # most comfortable in + switch_draw = rbinom(n = length(cluster_ids), + size = 1, + prob = sqrt(rho)) + + # Return either the cluster outcome or individual outcome depending on the + # switch + ifelse(switch_draw, cluster_draw, individual_draw) + } diff --git a/R/fabricate.R b/R/fabricate.R index 8cd8b3d..7a73915 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -1,12 +1,31 @@ #' Fabricate data #' -#' \code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{add_level()} or modify existing hierarchical data using \code{modify_level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +#' \code{fabricate} helps you simulate a dataset before you collect it. You can +#' either start with your own data and add simulated variables to it (by passing +#' \code{data} to \code{fabricate()}) or start from scratch by defining +#' \code{N}. Create hierarchical data with multiple levels of data such as +#' citizens within cities within states using \code{add_level()} or modify +#' existing hierarchical data using \code{modify_level()}. You can use any R +#' function to create each variable. We provide several built-in options to +#' easily draw from binary and count outcomes, \code{\link{draw_binary}}, +#' \code{\link{draw_binary_icc}}, and \code{\link{draw_discrete}}. #' -#' @param data (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided). -#' @param N (optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset. +#' @param data (optional) user-provided data that forms the basis of the +#' fabrication, i.e. you can add variables to existing data. Provide either +#' \code{N} or \code{data} (\code{N} is the number of rows of the data if +#' \code{data} is provided). +#' @param N (optional) number of units to draw. If provided as +#' \code{fabricate(N = 5)}, this determines the number of units in the +#' single-level data. If provided in \code{add_level}, i.e. +#' \code{fabricate(cities = add_level(N = 5))}, \code{N} determines the number +#' of units in a specific level of a hierarchical dataset. #' @param ID_label (optional) variable name for ID variable, i.e. citizen_ID -#' @param ... Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{add_level()} or \code{modify_level()} arguments, which define a level of a multi-level dataset. See examples. -#' @param new_hierarchy Reserved argument for future functionality to add cross-classified data. Not yet implemented. +#' @param ... Variable or level-generating arguments, such as +#' \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass +#' \code{add_level()} or \code{modify_level()} arguments, which define a level +#' of a multi-level dataset. See examples. +#' @param new_hierarchy Reserved argument for future functionality to add +#' cross-classified data. Not yet implemented. #' @param working_environment_ Internal argument, not intended for end-user use. #' @param data_arguments Internal argument, not intended for end-user use. #' @@ -47,7 +66,8 @@ #' cities = modify_level(runoff = rnorm(N)) #' ) #' -#' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args is_lang get_expr +#' @importFrom rlang quos quo_name eval_tidy lang_name lang_modify lang_args +#' is_lang get_expr #' #' @export fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) @@ -70,7 +90,10 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) (!is.null(N) & !missing(N)), all_levels) != 1) { stop( - "Fabricate can be called in one of three ways: \n 1) Provide one or more level calls, with or without existing data \n 2) Provide existing data and add new variables without adding a level \n 3) Provide an \"N\" and add new variables" + "Fabricate can be called in one of three ways: \n + 1) Provide one or more level calls, with or without existing data \n + 2) Provide existing data and add new variables without adding a level \n + 3) Provide an \"N\" and add new variables" ) } @@ -100,7 +123,8 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) working_environment_ = working_environment, ID_label = names(data_arguments)[i]) - # Execute the level build and pass it back to the current working environment. + # Execute the level build and pass it back to the current working + # environment. working_environment = eval_tidy(data_arguments[[i]]) } @@ -150,7 +174,10 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) # Run the level adder, report the results, and return return( report_results( - add_level(N = N, ID_label = ID_label, data_arguments = data_arguments, new_hierarchy=TRUE) + add_level(N = N, + ID_label = ID_label, + data_arguments = data_arguments, + new_hierarchy=TRUE) ) ) } @@ -165,7 +192,8 @@ add_level = function(N = NULL, ID_label = NULL, data_arguments=quos(...), new_hierarchy = FALSE) { - # Copy the working environment out of the data_arguments quosure and into the root. + # Copy the working environment out of the data_arguments quosure and into + # the root. if("working_environment_" %in% names(data_arguments)) { working_environment_ = data_arguments[["working_environment_"]] data_arguments[["working_environment_"]] = NULL @@ -214,7 +242,8 @@ add_level = function(N = NULL, ID_label = NULL, } # User is adding a new level, but we need to sneak in the imported data first. - # When this is done, trash the imported data, because the working data frame contains it. + # When this is done, trash the imported data, because the working data frame + # contains it. if("imported_data_" %in% names(working_environment_)) { tryCatch({ num_obs_imported = nrow(working_environment_$imported_data_) @@ -234,17 +263,20 @@ add_level = function(N = NULL, ID_label = NULL, # Staple in an ID column onto the data list. if(!is.null(ID_label)) { - # It's possible the working data frame already has the ID label, if so, don't do anything. + # It's possible the working data frame already has the ID label, if so, + # don't do anything. if(is.null(names(working_data_list)) || !ID_label %in% names(working_data_list)) { # First, add the column to the working data frame working_data_list[[ID_label]] = generate_id_pad(N) # Next, add the ID_label to the level ids tracker - # Why does this not need to return? Because environments are passed by reference + # Why does this not need to return? Because environments are passed by + # reference add_level_id(working_environment_, ID_label) add_variable_name(working_environment_, ID_label) } else { - # If the ID label was specified but already exists, we should still log it as a level ID + # If the ID label was specified but already exists, we should still log + # it as a level ID add_level_id(working_environment_, ID_label) } } else { @@ -262,8 +294,8 @@ add_level = function(N = NULL, ID_label = NULL, # Write the variable name to the list of variable names add_variable_name(working_environment_, i) - # Nuke the current data argument -- if we have the same variable name created twice, - # this is OK, because it'll only nuke the current one. + # Nuke the current data argument -- if we have the same variable name + # created twice, this is OK, because it'll only nuke the current one. data_arguments[[i]] = NULL } @@ -288,7 +320,8 @@ nest_level = function(N = NULL, ID_label = NULL, ..., data_arguments=quos(...)) { - # Copy the working environment out of the data_arguments quosure and into the root. + # Copy the working environment out of the data_arguments quosure and into the + # root. if("working_environment_" %in% names(data_arguments)) { working_environment_ = data_arguments[["working_environment_"]] data_arguments[["working_environment_"]] = NULL @@ -331,7 +364,8 @@ nest_level = function(N = NULL, ID_label = NULL, # We're now going to modify the index set to take into account the expansion # If N is a single number, then we repeat each index N times # If N is of length past_level_N, then we repeat each index N_i times. - # For r's rep, the each / times arguments have odd behaviour that necessitates this approach + # For r's rep, the each / times arguments have odd behaviour that necessitates + # this approach if(length(N)==1) rep_indices = rep(indices, each=N) else rep_indices = rep(indices, times=N) @@ -339,15 +373,17 @@ nest_level = function(N = NULL, ID_label = NULL, inner_N = N N = length(rep_indices) - # Expand the data frame by duplicating the indices and then coerce the data frame - # to a list -- we do this to basically make variables accessible in the namespace. + # Expand the data frame by duplicating the indices and then coerce the data + # frame to a list -- we do this to basically make variables accessible in the + # namespace. working_data_list = as.list(working_environment_$data_frame_output_[rep_indices, , drop=FALSE]) - ### Everything after here is non-unique to nest_level versus add_level -- need to think about how to - ### refactor this out. + # Everything after here is non-unique to nest_level versus add_level -- need + # to think about how to refactor this out. # Staple in an ID column onto the data list. - if(!is.null(ID_label) && (is.null(names(working_data_list)) || !ID_label %in% names(working_data_list))) { + if(!is.null(ID_label) && (is.null(names(working_data_list)) || + !ID_label %in% names(working_data_list))) { # First, add the column to the working data frame working_data_list[[ID_label]] = generate_id_pad(N) @@ -363,17 +399,23 @@ nest_level = function(N = NULL, ID_label = NULL, working_data_list[[i]] = eval_tidy(data_arguments[[i]], append(working_data_list, list(N=N))) - # User provided a fixed-length data variable whose length is the length of the inner-most - # level for a given outer level. See example: + # User provided a fixed-length data variable whose length is the length of + # the inner-most level for a given outer level. See example: # fabricate(countries = add_level(N=20), # cities = nest_level(N=2, capital=c(TRUE, FALSE))) # We need to expand this to each setting of the outer level. # Only evaluate if inner_N is a single number if(length(inner_N) == 1 && length(working_data_list[[i]]) == inner_N) { - # If there's a non-even multiple that's an indication something is badly wrong with the data here. + # If there's a non-even multiple that's an indication something is badly + # wrong with the data here. if((N/inner_N) %% 1) { - stop("Variable ", i, " has inappropriate length for nested level ", ID_label, ". \n", - " If the nested level has a fixed length, please generate data of the length of either the inner level or the entire data frame. If the nested level has a variable length, please generate data equal to the length of the entire data frame using the N argument.") + stop("Variable ", i, " has inappropriate length for nested level ", + ID_label, ". \n", + " If the nested level has a fixed length, please generate data of + the length of either the inner level or the entire data frame. + If the nested level has a variable length, please generate data + equal to the length of the entire data frame using the N + argument.") } # Do the repetition working_data_list[[i]] = rep(working_data_list[[i]], (N/inner_N)) @@ -382,8 +424,8 @@ nest_level = function(N = NULL, ID_label = NULL, # Write the variable name to the list of variable names add_variable_name(working_environment_, i) - # Nuke the current data argument -- if we have the same variable name created twice, - # this is OK, because it'll only nuke the current one. + # Nuke the current data argument -- if we have the same variable name + # created twice, this is OK, because it'll only nuke the current one. data_arguments[[i]] = NULL } @@ -408,7 +450,8 @@ modify_level = function(N = NULL, ..., data_arguments=quos(...)) { - # Copy the working environment out of the data_arguments quosure and into the root. + # Copy the working environment out of the data_arguments quosure and into + # the root. if("working_environment_" %in% names(data_arguments)) { working_environment_ = data_arguments[["working_environment_"]] data_arguments[["working_environment_"]] = NULL @@ -423,7 +466,8 @@ modify_level = function(N = NULL, # Need to supply an ID_label, otherwise we have no idea what to modify. # You actually can, though! It'd just be per unit if(is.null(ID_label)) { - stop("You can't modify a level without a known level ID variable. If you are adding nested data, please use add_level") + stop("You can't modify a level without a known level ID variable. If you + are adding nested data, please use add_level") } # First, establish that if we have no working data frame, we can't continue @@ -437,13 +481,16 @@ modify_level = function(N = NULL, stop("User supplied data must be convertible into a data frame.") }) } else { - stop("You can't modify a level if there is no working data frame to modify: you must either load pre-existing data or generate some data before modifying.") + stop("You can't modify a level if there is no working data frame to + modify: you must either load pre-existing data or generate some data + before modifying.") } } - # There are two possibilities. One is that we are modifying the lowest level of data. - # In which case, we simply add variables, like if someone called add_level with a dataset. - # To check if that's the world we're in, check if we have any duplicates in the ID label: + # There are two possibilities. One is that we are modifying the lowest level + # of data. In which case, we simply add variables, like if someone called + # add_level with a dataset. To check if that's the world we're in, check if + # we have any duplicates in the ID label: if(!anyDuplicated(working_environment_$data_frame_output_[[ID_label]])) { # There is no subsetting going on, but modify_level was used anyway. N = nrow(working_environment_$data_frame_output_) @@ -463,8 +510,8 @@ modify_level = function(N = NULL, # Write the variable name to the list of variable names add_variable_name(working_environment_, i) - # Nuke the current data argument -- if we have the same variable name created twice, - # this is OK, because it'll only nuke the current one. + # Nuke the current data argument -- if we have the same variable name + # created twice, this is OK, because it'll only nuke the current one. data_arguments[[i]] = NULL } @@ -512,16 +559,18 @@ modify_level = function(N = NULL, # Error if we try to write using a variable that's not unique to the level. if(length(level_unique_variables) != length(write_variables) & length(write_variables) != 0) { - stop("Your modify_level command attempts to generate a new variable at the level \"", ID_label, - "\" but requires reading from the existing variable(s) [", + stop("Your modify_level command attempts to generate a new variable at the + level \"", ID_label, "\" + but requires reading from the existing variable(s) [", paste(setdiff(write_variables, level_unique_variables), collapse=", "), "] which are not defined at the level \"", ID_label, - "\"\n\n To prevent this error, you may modify the data at the level of interest, or change the definition of your new variables.") + "\"\n\n To prevent this error, you may modify the data at the level of + interest, or change the definition of your new variables.") } - # Our subset needs these columns -- the level variable, all the unique variables - # we are going to use to write, and then in case the latter is "", remove that dummy - # obs.: + # Our subset needs these columns -- the level variable, all the unique + # variables we are going to use to write, and then in case the latter is "", + # remove that dummy obs.: merged_set = unique(c(ID_label, setdiff(level_unique_variables, ""))) # And these rows: @@ -554,12 +603,12 @@ modify_level = function(N = NULL, add_variable_name(working_environment_, i) # Expand the variable and store it in the actual, expanded working data list - # Why do we keep these in parallel? Because subsequent variables might need the non-expanded - # version to generate new variables. + # Why do we keep these in parallel? Because subsequent variables might need + # the non-expanded version to generate new variables. super_working_data_list[[i]] = working_data_list[[i]][index_maps] - # Nuke the current data argument -- if we have the same variable name created twice, - # this is OK, because it'll only nuke the current one. + # Nuke the current data argument -- if we have the same variable name + # created twice, this is OK, because it'll only nuke the current one. data_arguments[[i]] = NULL } @@ -575,17 +624,19 @@ modify_level = function(N = NULL, return(working_environment_) } -#' Deprecated level call function maintained to provide useful error for previous fabricatr code. +#' Deprecated level call function maintained to provide useful error for +#' previous fabricatr code. #' @keywords internal #' @export level = function(N = NULL, ID_label = NULL, ...) { stop("Level calls are currently deprecated; use add_level and modify_level") - # Stub, this doesn't do anything yet -- may in the future dispatch to the relevant - # levels. + # Stub, this doesn't do anything yet -- may in the future dispatch to the + # relevant levels. } -# Dummy helper function that just extracts the working data frame from the environment. -# This exists because we may in the future want to return something that is not a data frame. +# Dummy helper function that just extracts the working data frame from the +# environment. This exists because we may in the future want to return something +# that is not a data frame. report_results = function(working_environment) { return(working_environment$data_frame_output_) } diff --git a/R/variable_creation_functions.R b/R/variable_creation_functions.R index 848b33d..0a98bbf 100644 --- a/R/variable_creation_functions.R +++ b/R/variable_creation_functions.R @@ -1,13 +1,25 @@ -#' Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical +#' Draw discrete variables including binary, binomial count, poisson count, +#' ordered, and categorical #' -#' Drawing discrete data based on probabilities or latent traits is a common task that can be cumbersome. \code{draw_binary} is an alias for \code{draw_discrete(type = "binary")} that allows you to draw binary outcomes more easily. +#' Drawing discrete data based on probabilities or latent traits is a common +#' task that can be cumbersome. \code{draw_binary} is an alias for +#' \code{draw_discrete(type = "binary")} that allows you to draw binary +#' outcomes more easily. #' -#' @param x vector representing either the latent variable used to draw the count outcome (if link is "logit" or "probit") or the probability for the count outcome (if link is "identity"). For cartegorical distributions x is a matrix with as many columns as possible outcomes. -#' @param N number of units to draw. Defaults to the length of the vector \code{x} -#' @param type type of discrete outcome to draw, one of 'binary' (or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count' -#' @param link link function between the latent variable and the probability of a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" link, the latent variable must be a probability. +#' @param x vector representing either the latent variable used to draw the +#' count outcome (if link is "logit" or "probit") or the probability for the +#' count outcome (if link is "identity"). For cartegorical distributions x is +#' a matrix with as many columns as possible outcomes. +#' @param N number of units to draw. Defaults to the length of the vector +#' \code{x} +#' @param type type of discrete outcome to draw, one of 'binary' +#' (or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count' +#' @param link link function between the latent variable and the probability of +#' a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" +#' link, the latent variable must be a probability. #' @param breaks vector of breaks to cut an ordered latent outcome -#' @param break_labels vector of labels for the breaks for an ordered latent outcome (must be the same length as breaks) +#' @param break_labels vector of labels for the breaks for an ordered latent +#' outcome (must be the same length as breaks) #' @param k the number of trials (zero or more) #' #' @importFrom stats pnorm rnorm rpois @@ -33,7 +45,8 @@ #' #' fabricate(N = 3, #' x = 5*rnorm(N), -#' ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf))) +#' ordered = draw_discrete(x, type = "ordered", +#' breaks = c(-Inf, -1, 1, Inf))) #' #' fabricate(N = 3, #' x = c(0,5,100), @@ -62,7 +75,8 @@ draw_discrete <- "ordered", "count")) { stop( - "Please choose either 'binary' (or 'bernoulli'), 'binomial', 'categorical', 'ordered', or 'count' as a data type." + "Please choose either 'binary' (or 'bernoulli'), 'binomial', + 'categorical', 'ordered', or 'count' as a data type." ) } @@ -91,7 +105,8 @@ draw_discrete <- } if (link == "identity") if (!all(0 <= x & x <= 1)) { - stop("The identity link requires probability values between 0 and 1, inclusive.") + stop("The identity link requires probability values between 0 and 1, + inclusive.") } out <- rbinom(N, k, prob) @@ -105,7 +120,8 @@ draw_discrete <- if(is.vector(k) & length(k)>1) { if(N %% length(k)) { stop( - "\"N\" is not an even multiple of the length of the number of trials, \"k\"." + "\"N\" is not an even multiple of the length of the number of + trials, \"k\"." ) } if(!all(is.numeric(k) & (is.integer(k) | !k%%1))) { @@ -116,7 +132,8 @@ draw_discrete <- } if(!is.null(dim(k))) { stop( - "Number of trials must be an integer or vector, not higher-dimensional." + "Number of trials must be an integer or vector, + not higher-dimensional." ) } if(is.null(k) | is.na(k)) { @@ -158,9 +175,13 @@ draw_discrete <- stop("Numeric breaks must be in ascending order.") } if(any(breaks[1] > x) | any(breaks[length(breaks)] < x)) { - stop("Numeric break endpoints should be outside min/max of x data range.") + stop("Numeric break endpoints should be outside min/max of x data + range.") } - if(is.vector(break_labels) & !is.logical(break_labels) & all(!is.na(break_labels)) & length(break_labels) != length(breaks)-1) { + if(is.vector(break_labels) & + !is.logical(break_labels) & + all(!is.na(break_labels)) & + length(break_labels) != length(breaks)-1) { stop("Break labels should be of length one less than breaks.") } @@ -188,17 +209,21 @@ draw_discrete <- if (is.vector(x) & all(is.numeric(x)) & length(x)>1) { x <- matrix(rep(x, N), byrow=TRUE, ncol=length(x), nrow=N) warning( - "For a categorical (multinomial) distribution, a matrix of probabilities should be provided. Data generated by interpreting vector of category probabilities, identical for each observation." + "For a categorical (multinomial) distribution, a matrix of + probabilities should be provided. Data generated by interpreting + vector of category probabilities, identical for each observation." ) } else { stop( - "For a categorical (multinomial) distribution, a matrix of probabilities should be provided" + "For a categorical (multinomial) distribution, a matrix of + probabilities should be provided" ) } } if (!all(apply(x, 1, min) > 0)) { stop( - "For a categorical (multinomial) distribution, the elements of x should be positive and sum to a positive number." + "For a categorical (multinomial) distribution, the elements of x + should be positive and sum to a positive number." ) } diff --git a/man/draw_binary_icc.Rd b/man/draw_binary_icc.Rd new file mode 100644 index 0000000..d361652 --- /dev/null +++ b/man/draw_binary_icc.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/draw_binary_icc.R +\name{draw_binary_icc} +\alias{draw_binary_icc} +\title{Draw binary data with fixed intra-cluster correlation.} +\usage{ +draw_binary_icc(x = 0.5, N = NULL, cluster_ids, rho = 0.5) +} +\arguments{ +\item{x}{A number or vector of numbers, one probability per cluster.} + +\item{N}{(Optional) A number indicating the number of observations to be +generated. Must be equal to length(cluster_ids) if provided.} + +\item{cluster_ids}{A vector of factors or items that can be coerced to +clusters; the length will determine the length of the generated data.} + +\item{rho}{A number indicating the desired RCC.} +} +\value{ +A vector of binary numbers corresponding to the observations from +the supplied cluster IDs. +} +\description{ +Data is generated according to the following algorithm, where \eqn{i} is +the index of a cluster and \eqn{j} is the index of a unit: \deqn{z_i ~ +Bernoulli(p_i) \cr +y_{ij} ~ Bernoulli(p_{ij}) \cr +u_{ij} ~ Bernoulli(sqrt(\rho)) \cr +x_{ij} = (u_{ij}) z_i + (1 - u_{ij}) y_{ij}} +} +\details{ +This system of equations ensures inter-cluster correlation 0, intra-cluster +correlation in expectation \eqn{\rho}. Algorithm from Hossein, Akhtar. +"ICCbin: An R Package Facilitating Clustered Binary Data Generation, and +Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data". +We rederived the analytical properties of this data and did a simulation +study to confirm that the data generated ensured the ICC we mentioned. +} +\examples{ +cluster_ids = rep(1:5, 10) +draw_binary_icc(cluster_ids = cluster_ids) +draw_binary_icc(x = 0.5, cluster_ids = cluster_ids, rho = 0.5) + +} diff --git a/man/draw_discrete.Rd b/man/draw_discrete.Rd index 8a23400..7430398 100644 --- a/man/draw_discrete.Rd +++ b/man/draw_discrete.Rd @@ -3,7 +3,8 @@ \name{draw_discrete} \alias{draw_discrete} \alias{draw_binary} -\title{Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical} +\title{Draw discrete variables including binary, binomial count, poisson count, +ordered, and categorical} \usage{ draw_discrete(x, N = length(x), type = "binary", link = "identity", breaks = c(-Inf, 0, Inf), break_labels = FALSE, k = 1) @@ -11,22 +12,33 @@ draw_discrete(x, N = length(x), type = "binary", link = "identity", draw_binary(x, N = length(x), link = "identity") } \arguments{ -\item{x}{vector representing either the latent variable used to draw the count outcome (if link is "logit" or "probit") or the probability for the count outcome (if link is "identity"). For cartegorical distributions x is a matrix with as many columns as possible outcomes.} +\item{x}{vector representing either the latent variable used to draw the +count outcome (if link is "logit" or "probit") or the probability for the +count outcome (if link is "identity"). For cartegorical distributions x is +a matrix with as many columns as possible outcomes.} -\item{N}{number of units to draw. Defaults to the length of the vector \code{x}} +\item{N}{number of units to draw. Defaults to the length of the vector +\code{x}} -\item{type}{type of discrete outcome to draw, one of 'binary' (or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count'} +\item{type}{type of discrete outcome to draw, one of 'binary' +(or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count'} -\item{link}{link function between the latent variable and the probability of a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" link, the latent variable must be a probability.} +\item{link}{link function between the latent variable and the probability of +a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" +link, the latent variable must be a probability.} \item{breaks}{vector of breaks to cut an ordered latent outcome} -\item{break_labels}{vector of labels for the breaks for an ordered latent outcome (must be the same length as breaks)} +\item{break_labels}{vector of labels for the breaks for an ordered latent +outcome (must be the same length as breaks)} \item{k}{the number of trials (zero or more)} } \description{ -Drawing discrete data based on probabilities or latent traits is a common task that can be cumbersome. \code{draw_binary} is an alias for \code{draw_discrete(type = "binary")} that allows you to draw binary outcomes more easily. +Drawing discrete data based on probabilities or latent traits is a common +task that can be cumbersome. \code{draw_binary} is an alias for +\code{draw_discrete(type = "binary")} that allows you to draw binary +outcomes more easily. } \examples{ fabricate(N = 3, @@ -47,7 +59,8 @@ fabricate(N = 3, fabricate(N = 3, x = 5*rnorm(N), - ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf))) + ordered = draw_discrete(x, type = "ordered", + breaks = c(-Inf, -1, 1, Inf))) fabricate(N = 3, x = c(0,5,100), diff --git a/man/fabricate.Rd b/man/fabricate.Rd index c5015cb..47a5928 100644 --- a/man/fabricate.Rd +++ b/man/fabricate.Rd @@ -15,25 +15,44 @@ modify_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments = quos(...)) } \arguments{ -\item{data}{(optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} +\item{data}{(optional) user-provided data that forms the basis of the +fabrication, i.e. you can add variables to existing data. Provide either +\code{N} or \code{data} (\code{N} is the number of rows of the data if +\code{data} is provided).} -\item{N}{(optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{level}, i.e. \code{fabricate(cities = level(N = 5))}, \code{N} determines the number of units in a specific level of a hierarchical dataset.} +\item{N}{(optional) number of units to draw. If provided as +\code{fabricate(N = 5)}, this determines the number of units in the +single-level data. If provided in \code{add_level}, i.e. +\code{fabricate(cities = add_level(N = 5))}, \code{N} determines the number +of units in a specific level of a hierarchical dataset.} \item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} -\item{...}{Variable or level-generating arguments, such as \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass \code{add_level()} or \code{modify_level()} arguments, which define a level of a multi-level dataset. See examples.} +\item{...}{Variable or level-generating arguments, such as +\code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass +\code{add_level()} or \code{modify_level()} arguments, which define a level +of a multi-level dataset. See examples.} \item{working_environment_}{Internal argument, not intended for end-user use.} \item{data_arguments}{Internal argument, not intended for end-user use.} -\item{new_hierarchy}{Reserved argument for future functionality to add cross-classified data. Not yet implemented.} +\item{new_hierarchy}{Reserved argument for future functionality to add +cross-classified data. Not yet implemented.} } \value{ data.frame } \description{ -\code{fabricate} helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing \code{data} to \code{fabricate()}) or start from scratch by defining \code{N}. Create hierarchical data with multiple levels of data such as citizens within cities within states using \code{add_level()} or modify existing hierarchical data using \code{modify_level()}. You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, \code{\link{draw_binary}} and \code{\link{draw_discrete}}. +\code{fabricate} helps you simulate a dataset before you collect it. You can +either start with your own data and add simulated variables to it (by passing +\code{data} to \code{fabricate()}) or start from scratch by defining +\code{N}. Create hierarchical data with multiple levels of data such as +citizens within cities within states using \code{add_level()} or modify +existing hierarchical data using \code{modify_level()}. You can use any R +function to create each variable. We provide several built-in options to +easily draw from binary and count outcomes, \code{\link{draw_binary}}, +\code{\link{draw_binary_icc}}, and \code{\link{draw_discrete}}. } \examples{ diff --git a/man/level.Rd b/man/level.Rd index e7f861e..a4592ee 100644 --- a/man/level.Rd +++ b/man/level.Rd @@ -2,11 +2,13 @@ % Please edit documentation in R/fabricate.R \name{level} \alias{level} -\title{Deprecated level call function maintained to provide useful error for previous fabricatr code.} +\title{Deprecated level call function maintained to provide useful error for +previous fabricatr code.} \usage{ level(N = NULL, ID_label = NULL, ...) } \description{ -Deprecated level call function maintained to provide useful error for previous fabricatr code. +Deprecated level call function maintained to provide useful error for +previous fabricatr code. } \keyword{internal} diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index a12a82c..57b6d03 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -170,3 +170,30 @@ test_that("Ordered data valid tests", { break_labels = c("A", "B"), link="probit") }) + +test_that("Binary ICCs", { + cluster_ids = rep(1:5, 10) + # Single probability + draw_binary_icc(cluster_ids = cluster_ids) + # Probability = length(cluster ids) + draw_binary_icc(x = c(0.3, 0.5, 0.7, 0.8, 0.9), cluster_ids = cluster_ids) + + # Invalid cluster IDs + expect_error(draw_binary_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) + # X doesn't match cluster IDs + expect_error(draw_binary_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + # X isn't numeric + expect_error(draw_binary_icc(x = "hello", cluster_ids = cluster_ids)) + # X isn't a probability + expect_error(draw_binary_icc(x = -0.5, cluster_ids = cluster_ids)) + # rho isn't a single number + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) + # rho isn't a probability + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = 2)) + # rho isn't a number + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = "hello")) + # Non-numeric N + expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = "hello")) + # N provided but doesn't match + expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = 20)) +}) From 7ebb9e2269dc07c537322f387558e81fde01b60e Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 28 Nov 2017 15:24:18 -0800 Subject: [PATCH 20/47] Fixed #35 and sped up ordered data by swapping cut for findInterval --- R/variable_creation_functions.R | 59 +++++++++++++++++++-------------- 1 file changed, 34 insertions(+), 25 deletions(-) diff --git a/R/variable_creation_functions.R b/R/variable_creation_functions.R index 0a98bbf..84eb7c3 100644 --- a/R/variable_creation_functions.R +++ b/R/variable_creation_functions.R @@ -61,7 +61,7 @@ draw_discrete <- type = "binary", link = "identity", breaks = c(-Inf, 0, Inf), - break_labels = FALSE, + break_labels = NULL, k = 1) { if (!link %in% c("logit", "probit", "identity")) { @@ -75,8 +75,8 @@ draw_discrete <- "ordered", "count")) { stop( - "Please choose either 'binary' (or 'bernoulli'), 'binomial', - 'categorical', 'ordered', or 'count' as a data type." + "Please choose either 'binary' (or 'bernoulli'), 'binomial',", + "'categorical', 'ordered', or 'count' as a data type." ) } @@ -105,8 +105,8 @@ draw_discrete <- } if (link == "identity") if (!all(0 <= x & x <= 1)) { - stop("The identity link requires probability values between 0 and 1, - inclusive.") + stop("The identity link requires probability values between 0 and 1,", + "inclusive.") } out <- rbinom(N, k, prob) @@ -132,8 +132,8 @@ draw_discrete <- } if(!is.null(dim(k))) { stop( - "Number of trials must be an integer or vector, - not higher-dimensional." + "Number of trials must be an integer or vector,", + " not higher-dimensional." ) } if(is.null(k) | is.na(k)) { @@ -168,25 +168,34 @@ draw_discrete <- if (is.matrix(breaks) | is.data.frame(breaks)) { stop("Numeric breaks must be a vector.") } - if (length(breaks) < 3) { - stop("Numeric breaks for ordered data must be of at least length 3.") - } if (is.unsorted(breaks)) { stop("Numeric breaks must be in ascending order.") } - if(any(breaks[1] > x) | any(breaks[length(breaks)] < x)) { - stop("Numeric break endpoints should be outside min/max of x data - range.") + + # Pre-pend -Inf + if(any(breaks[1] > x)) { + breaks = c(-Inf, breaks) + } + # Post-pend Inf + if(any(breaks[length(breaks)] < x)) { + breaks = c(breaks, Inf) } - if(is.vector(break_labels) & + + if(!is.null(break_labels) && + (is.vector(break_labels) & !is.logical(break_labels) & all(!is.na(break_labels)) & - length(break_labels) != length(breaks)-1) { - stop("Break labels should be of length one less than breaks.") + length(break_labels) != length(breaks)-1)) { + stop("Break labels should be of length one less than breaks. ", + "Currently you have ", length(break_labels), " bucket labels and ", + length(breaks)-1, " buckets of data.") } - out <- cut(x, breaks, labels = break_labels) - + if(!is.null(break_labels)) { + out <- break_labels[findInterval(x, breaks)] + } else { + out <- findInterval(x, breaks) + } } else if (type == "count") { if (link != "identity") { stop("Count data does not accept link functions.") @@ -209,21 +218,21 @@ draw_discrete <- if (is.vector(x) & all(is.numeric(x)) & length(x)>1) { x <- matrix(rep(x, N), byrow=TRUE, ncol=length(x), nrow=N) warning( - "For a categorical (multinomial) distribution, a matrix of - probabilities should be provided. Data generated by interpreting - vector of category probabilities, identical for each observation." + "For a categorical (multinomial) distribution, a matrix of ", + "probabilities should be provided. Data generated by interpreting ", + "vector of category probabilities, identical for each observation." ) } else { stop( - "For a categorical (multinomial) distribution, a matrix of - probabilities should be provided" + "For a categorical (multinomial) distribution, a matrix of ", + "probabilities should be provided" ) } } if (!all(apply(x, 1, min) > 0)) { stop( - "For a categorical (multinomial) distribution, the elements of x - should be positive and sum to a positive number." + "For a categorical (multinomial) distribution, the elements of x ", + "should be positive and sum to a positive number." ) } From 31797f601949916c405f08a8bf76338712cdb5e1 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 28 Nov 2017 15:30:25 -0800 Subject: [PATCH 21/47] Added a likert unit test to draw ordered data. --- R/draw_binary_icc.R | 4 ++-- tests/testthat/test-variables.R | 23 +++++++++++++++++++++++ 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index ef9266f..e8bf39b 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -47,8 +47,8 @@ draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { stop("If you provide an N, it must be numeric.") } if(!is.null(N) && N != length(cluster_ids)) { - stop("If you provide an N, it must be equal to the length of provided - cluster ids") + stop("If you provide an N, it must be equal to the length of provided ", + "cluster ids") } if(!is.vector(x)) { stop("x must be a number or vector of numbers.") diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 57b6d03..2a927f2 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -197,3 +197,26 @@ test_that("Binary ICCs", { # N provided but doesn't match expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = 20)) }) + +test_that("Likert data example", { + set.seed(19861108) + latent = rnorm(n=100, mean=3, sd=10) + cutpoints = c(-15, -7, -3, 3, 7, 15) + likert = draw_discrete(x=latent, + type="ordered", + breaks = cutpoints) + expect(length(unique(likert)) == 7) + expect(max(likert) == 7) + expect(min(likert) == 1) + + draw_discrete(x=latent, + type="ordered", + breaks = cutpoints, + break_labels = c("Strongly Disagree", + "Disagree", + "Lean Disagree", + "No Opinion", + "Lean Agree", + "Agree", + "Strongly Agree")) +}) From b5f51138e83068b9439b4846659a9d380c61a8e0 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 28 Nov 2017 16:35:47 -0800 Subject: [PATCH 22/47] Fixed issues with last set of tests, added draw_normal_icc --- NAMESPACE | 1 + R/draw_binary_icc.R | 9 +-- R/draw_normal_icc.R | 111 ++++++++++++++++++++++++++++++++ man/draw_discrete.Rd | 2 +- man/draw_normal_icc.Rd | 45 +++++++++++++ tests/testthat/test-variables.R | 44 ++++++++++--- 6 files changed, 198 insertions(+), 14 deletions(-) create mode 100644 R/draw_normal_icc.R create mode 100644 man/draw_normal_icc.Rd diff --git a/NAMESPACE b/NAMESPACE index b4d5298..ddb4f09 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -5,6 +5,7 @@ export(add_level) export(draw_binary) export(draw_binary_icc) export(draw_discrete) +export(draw_normal_icc) export(fabricate) export(level) export(modify_level) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index e8bf39b..3324567 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -39,10 +39,7 @@ draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { }) number_of_clusters = length(unique(cluster_ids)) - # Sanity check x - if(!length(x) %in% c(1, number_of_clusters)) { - stop("x must be either one number or one number per cluster.") - } + # Sanity check N if(!is.null(N) && !is.numeric(N)) { stop("If you provide an N, it must be numeric.") } @@ -50,6 +47,10 @@ draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { stop("If you provide an N, it must be equal to the length of provided ", "cluster ids") } + # Sanity check x + if(!length(x) %in% c(1, number_of_clusters)) { + stop("x must be either one number or one number per cluster.") + } if(!is.vector(x)) { stop("x must be a number or vector of numbers.") } diff --git a/R/draw_normal_icc.R b/R/draw_normal_icc.R new file mode 100644 index 0000000..9342f17 --- /dev/null +++ b/R/draw_normal_icc.R @@ -0,0 +1,111 @@ +#' Draw normal data with fixed intra-cluster correlation. +#' +#' Data is generated according to the following algorithm, where \eqn{i} is +#' the index of a cluster and \eqn{j} is the index of a unit: +#' +#' \deqn{\sigma^2_{\alpha}(i) = (\rho \sigma^2_{\epsilon}(i)) / (1 - \rho) \cr +#' \mu_{ij} ~ \mathcall{N}(\mu_i, \sigma_{\epsilon}(i)) +#' \alpha_{i} ~ \mathcal{N}(0, \sigma_{\alpha}(i)) \cr +#' x_{ij} = \mu_{ij} + \alpha_{i}} +#' +#' This system of equations ensures inter-cluster correlation 0, intra-cluster +#' correlation in expectation \eqn{\rho}. Algorithm discussed at +#' \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} +#' +#' @param x A number or vector of numbers, one mean per cluster. +#' @param N (Optional) A number indicating the number of observations to be +#' generated. Must be equal to length(cluster_ids) if provided. +#' @param cluster_ids A vector of factors or items that can be coerced to +#' clusters; the length will determine the length of the generated data. +#' @param sd A number or vector of numbers, indicating the standard deviation of +#' each cluster's error terms +#' @param rho A number indicating the desired RCC. +#' @return A vector of numbers corresponding to the observations from +#' the supplied cluster IDs. +#' @examples +#' cluster_ids = rep(1:5, 10) +#' draw_normal_icc(cluster_ids = cluster_ids) +#' +#' @importFrom stats rnorm +#' +#' @export +draw_normal_icc = function(x = 0, + N = NULL, + cluster_ids, + sd = 1, + rho = 0.5) { + + # Let's not worry about how cluster_ids are provided + tryCatch({ + cluster_ids = as.numeric(as.factor(cluster_ids)) + }, error=function(e) { + stop("Error coercing cluster IDs to factor levels.") + }) + number_of_clusters = length(unique(cluster_ids)) + + # Sanity check N + if(!is.null(N) && !is.numeric(N)) { + stop("If you provide an N, it must be numeric.") + } + if(!is.null(N) && N != length(cluster_ids)) { + stop("If you provide an N, it must be equal to the length of provided ", + "cluster ids") + } + + # Sanity check x + if(!length(x) %in% c(1, number_of_clusters)) { + stop("x must be either one number or one number per cluster.") + } + if(!is.vector(x)) { + stop("x must be a number or vector of numbers.") + } + if(any(!is.numeric(x))) { + stop("x must be a number or vector of numbers.") + } + + # Sanity check rho + if(length(rho) > 1) { + stop("rho must be a single number.") + } + if(!is.numeric(rho)) { + stop("rho must be a number.") + } + if(rho > 1 | rho < 0) { + stop("rho must be a number between 0 and 1.") + } + + # Sanity check sd + if(!length(sd) %in% c(1, number_of_clusters)) { + stop("sd must be either a number or one number per cluster.") + } + if(!is.vector(sd)) { + stop("sd must be a number or vector of numbers.") + } + if(any(!is.numeric(sd))) { + stop("sd must be a number or vector of numbers.") + } + + # Get number of clusters + number_of_clusters = length(unique(cluster_ids)) + # Convert rho to implied variance per cluster + recover_var_cluster = (rho * sd^2) / (1 - rho) + + # Cluster means are either the same or individually supplied + if(length(x) == 1) { + cluster_mean = rep(x, number_of_clusters) + } else { + cluster_mean = x + } + # Expand to individual means + individual_mean = cluster_mean[cluster_ids] + + # Cluster level draws, expanded to individual level draws + alpha_cluster = rnorm(n=number_of_clusters, + mean=0, + sd=sqrt(recover_var_cluster))[cluster_ids] + + # And error terms, which are truly individual + epsilon_ij = rnorm(length(unique(cluster_ids)), 0, sd) + + individual_mean + alpha_cluster + epsilon_ij +} diff --git a/man/draw_discrete.Rd b/man/draw_discrete.Rd index 7430398..a9f0adf 100644 --- a/man/draw_discrete.Rd +++ b/man/draw_discrete.Rd @@ -7,7 +7,7 @@ ordered, and categorical} \usage{ draw_discrete(x, N = length(x), type = "binary", link = "identity", - breaks = c(-Inf, 0, Inf), break_labels = FALSE, k = 1) + breaks = c(-Inf, 0, Inf), break_labels = NULL, k = 1) draw_binary(x, N = length(x), link = "identity") } diff --git a/man/draw_normal_icc.Rd b/man/draw_normal_icc.Rd new file mode 100644 index 0000000..570f55a --- /dev/null +++ b/man/draw_normal_icc.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/draw_normal_icc.R +\name{draw_normal_icc} +\alias{draw_normal_icc} +\title{Draw normal data with fixed intra-cluster correlation.} +\usage{ +draw_normal_icc(x = 0, N = NULL, cluster_ids, sd = 1, rho = 0.5) +} +\arguments{ +\item{x}{A number or vector of numbers, one mean per cluster.} + +\item{N}{(Optional) A number indicating the number of observations to be +generated. Must be equal to length(cluster_ids) if provided.} + +\item{cluster_ids}{A vector of factors or items that can be coerced to +clusters; the length will determine the length of the generated data.} + +\item{sd}{A number or vector of numbers, indicating the standard deviation of +each cluster's error terms} + +\item{rho}{A number indicating the desired RCC.} +} +\value{ +A vector of numbers corresponding to the observations from +the supplied cluster IDs. +} +\description{ +Data is generated according to the following algorithm, where \eqn{i} is +the index of a cluster and \eqn{j} is the index of a unit: +} +\details{ +\deqn{\sigma^2_{\alpha}(i) = (\rho \sigma^2_{\epsilon}(i)) / (1 - \rho) \cr +\mu_{ij} ~ \mathcall{N}(\mu_i, \sigma_{\epsilon}(i)) +\alpha_{i} ~ \mathcal{N}(0, \sigma_{\alpha}(i)) \cr +x_{ij} = \mu_{ij} + \alpha_{i}} + +This system of equations ensures inter-cluster correlation 0, intra-cluster +correlation in expectation \eqn{\rho}. Algorithm discussed at +\url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} +} +\examples{ +cluster_ids = rep(1:5, 10) +draw_normal_icc(cluster_ids = cluster_ids) + +} diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 2a927f2..03ece89 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -143,14 +143,8 @@ test_that("Ordered data invalid tests", { breaks=NA, break_labels=NA)) # Need to specify breaks expect_error(draw_discrete(x=rnorm(5), type="ordered", breaks=c("invalid", "break", "test"), break_labels=NA)) # Non-numeric breaks - expect_error(draw_discrete(x=rnorm(5), type="ordered", - breaks=c(1, 2), break_labels=NA)) # Insufficient number of breaks expect_error(draw_discrete(x=rnorm(5), type="ordered", breaks=c(1, 3, 2), break_labels=NA)) # Breaks out of order - expect_error(draw_discrete(x=rnorm(5), type="ordered", - breaks=c(10, 20, 30), break_labels=NA)) # Break endpoints above data - expect_error(draw_discrete(x=rnorm(5), type="ordered", - breaks=c(-50, -40, -30), break_labels=NA)) # Break endpoints below data expect_error(draw_discrete(x=rnorm(5), type="ordered", breaks=matrix(rep(c(0, 1, 2), 3), byrow=TRUE, ncol=3, nrow=3))) # Non-vector breaks expect_error(draw_discrete(x=rnorm(5), type="ordered", @@ -205,9 +199,9 @@ test_that("Likert data example", { likert = draw_discrete(x=latent, type="ordered", breaks = cutpoints) - expect(length(unique(likert)) == 7) - expect(max(likert) == 7) - expect(min(likert) == 1) + expect_equal(length(unique(likert)), 7) + expect_equal(max(likert), 7) + expect_equal(min(likert), 1) draw_discrete(x=latent, type="ordered", @@ -220,3 +214,35 @@ test_that("Likert data example", { "Agree", "Strongly Agree")) }) + +test_that("Normal ICC", { + cluster_ids = rep(1:5, 10) + # Single mean + draw_normal_icc(cluster_ids = cluster_ids) + # Means = length(cluster ids) + draw_normal_icc(x = c(-1, -0.5, 0, 0.5, 1), cluster_ids = cluster_ids) + + # Invalid cluster IDs + expect_error(draw_normal_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) + # X doesn't match cluster IDs + expect_error(draw_normal_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + # X isn't numeric + expect_error(draw_binary_icc(x = "hello", cluster_ids = cluster_ids)) + # rho isn't a single number + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) + # rho isn't a probability + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = 2)) + # rho isn't a number + expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = "hello")) + # Non-numeric N + expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = "hello")) + # N provided but doesn't match + expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = 20)) + # SD is wrong length + expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = c(1, 2))) + # SD is non-numeric + expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = "hello")) + # SD is not a vector + expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = data.frame(X=1:10, Y=1:10))) + +}) From a61e41db08007fe84ec07c7fc6b5dc82b0fabaa9 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 28 Nov 2017 18:51:03 -0800 Subject: [PATCH 23/47] Changed documentation to remove math which was causing an error on Travis but not on local builds, related to building the PDF manual. --- R/draw_binary_icc.R | 18 +++++------------- R/draw_normal_icc.R | 15 ++++----------- 2 files changed, 9 insertions(+), 24 deletions(-) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index 3324567..1ceb412 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -1,18 +1,10 @@ #' Draw binary data with fixed intra-cluster correlation. #' -#' Data is generated according to the following algorithm, where \eqn{i} is -#' the index of a cluster and \eqn{j} is the index of a unit: \deqn{z_i ~ -#' Bernoulli(p_i) \cr -#' y_{ij} ~ Bernoulli(p_{ij}) \cr -#' u_{ij} ~ Bernoulli(sqrt(\rho)) \cr -#' x_{ij} = (u_{ij}) z_i + (1 - u_{ij}) y_{ij}} -#' -#' This system of equations ensures inter-cluster correlation 0, intra-cluster -#' correlation in expectation \eqn{\rho}. Algorithm from Hossein, Akhtar. -#' "ICCbin: An R Package Facilitating Clustered Binary Data Generation, and -#' Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data". -#' We rederived the analytical properties of this data and did a simulation -#' study to confirm that the data generated ensured the ICC we mentioned. +#' Data is generated to ensure inter-cluster correlation 0, intra-cluster +#' correlation in expectation \eqn{\rho}. Algorithm taken from Hossein, +#' Akhtar. "ICCbin: An R Package Facilitating Clustered Binary Data +#' Generation, and Estimation of Intracluster Correlation Coefficient (ICC) +#' for Binary Data". #' #' @param x A number or vector of numbers, one probability per cluster. #' @param N (Optional) A number indicating the number of observations to be diff --git a/R/draw_normal_icc.R b/R/draw_normal_icc.R index 9342f17..fe94fb1 100644 --- a/R/draw_normal_icc.R +++ b/R/draw_normal_icc.R @@ -1,17 +1,10 @@ #' Draw normal data with fixed intra-cluster correlation. #' -#' Data is generated according to the following algorithm, where \eqn{i} is -#' the index of a cluster and \eqn{j} is the index of a unit: -#' -#' \deqn{\sigma^2_{\alpha}(i) = (\rho \sigma^2_{\epsilon}(i)) / (1 - \rho) \cr -#' \mu_{ij} ~ \mathcall{N}(\mu_i, \sigma_{\epsilon}(i)) -#' \alpha_{i} ~ \mathcal{N}(0, \sigma_{\alpha}(i)) \cr -#' x_{ij} = \mu_{ij} + \alpha_{i}} -#' -#' This system of equations ensures inter-cluster correlation 0, intra-cluster -#' correlation in expectation \eqn{\rho}. Algorithm discussed at +#' Data is generated to ensure inter-cluster correlation 0, intra-cluster +#' correlation in expectation \eqn{\rho}{rho}. The data generating process +#' used in this function is specified at the following URL: #' \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} -#' +#' #' @param x A number or vector of numbers, one mean per cluster. #' @param N (Optional) A number indicating the number of observations to be #' generated. Must be equal to length(cluster_ids) if provided. From 43495503ac1529f8873b96310f2021dc8a2252f6 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 11:55:19 -0800 Subject: [PATCH 24/47] Fixed documentation to reflect add_level, modify_level, and added documentation for ICC functions, and fixed bug with normal ICC data. --- R/draw_normal_icc.R | 7 +- vignettes/advanced_features.Rmd | 34 ++++----- vignettes/getting_started.Rmd | 49 ++++++------ vignettes/resampling.Rmd | 21 +++++- vignettes/variable_generation.Rmd | 121 +++++++++++++++++++++++++++++- 5 files changed, 180 insertions(+), 52 deletions(-) diff --git a/R/draw_normal_icc.R b/R/draw_normal_icc.R index fe94fb1..0c68813 100644 --- a/R/draw_normal_icc.R +++ b/R/draw_normal_icc.R @@ -4,7 +4,7 @@ #' correlation in expectation \eqn{\rho}{rho}. The data generating process #' used in this function is specified at the following URL: #' \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} -#' +#' #' @param x A number or vector of numbers, one mean per cluster. #' @param N (Optional) A number indicating the number of observations to be #' generated. Must be equal to length(cluster_ids) if provided. @@ -96,9 +96,10 @@ draw_normal_icc = function(x = 0, alpha_cluster = rnorm(n=number_of_clusters, mean=0, sd=sqrt(recover_var_cluster))[cluster_ids] + alpha_individual = alpha_cluster[cluster_ids] # And error terms, which are truly individual - epsilon_ij = rnorm(length(unique(cluster_ids)), 0, sd) + epsilon_ij = rnorm(length(cluster_ids), 0, sd) - individual_mean + alpha_cluster + epsilon_ij + individual_mean + alpha_individual + epsilon_ij } diff --git a/vignettes/advanced_features.Rmd b/vignettes/advanced_features.Rmd index c6627e8..d3163af 100644 --- a/vignettes/advanced_features.Rmd +++ b/vignettes/advanced_features.Rmd @@ -16,13 +16,13 @@ library(fabricatr) # More complicated level creation with variable numbers of observations -[`level()`](../reference/level.html) can be used to create more complicated patterns of nesting. For example, when creating lower level data, it is possible to use a different `N` for each of the values of the higher level data: +[`add_level()`](../reference/add_level.html) can be used to create more complicated patterns of nesting. For example, when creating lower level data, it is possible to use a different `N` for each of the values of the higher level data: ```{r echo=TRUE, results="hide"} variable_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = c(2, 4), age = runif(N, 18, 70)) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = c(2, 4), age = runif(N, 18, 70)) ) variable_data ``` @@ -30,16 +30,16 @@ variable_data knitr::kable(variable_data) ``` -Here, each city has a different number of citizens. And the value of `N` used to create the age variable automatically updates as needed. The result is a dataset with 6 citizens, 2 in the first city and 4 in the second. As long as N is either a number, or a vector of the same length of the current lowest level of the data, [`level()`](../reference/level.html) will know what to do. +Here, each city has a different number of citizens. And the value of `N` used to create the age variable automatically updates as needed. The result is a dataset with 6 citizens, 2 in the first city and 4 in the second. As long as N is either a number, or a vector of the same length of the current lowest level of the data, [`add_level()`](../reference/add_level.html) will know what to do. It is also possible to provide a function to N, enabling a *random* number of citizens per city: ```{r echo=TRUE, results="hide"} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = sample(1:6, size = 2, replace = TRUE), - age = runif(N, 18, 70)) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = sample(1:6, size = 2, replace = TRUE), + age = runif(N, 18, 70)) ) my_data ``` @@ -53,8 +53,8 @@ Finally, it is possible to define `N` on the basis of higher level variables the ```{r echo=TRUE, results="hide"} variable_n_function = fabricate( - cities = level(N = 5, population = runif(N, 10, 200)), - citizens = level(N = round(population * 0.3)) + cities = add_level(N = 5, population = runif(N, 10, 200)), + citizens = add_level(N = round(population * 0.3)) ) head(variable_n_function) ``` @@ -70,10 +70,10 @@ You may want to include the mean value of a variable within a group defined by a ```{r echo=TRUE, results="hide"} ave_example = fabricate( - cities = level(N = 2), - citizens = level(N = 1:2, - income = rnorm(N), - income_mean_city = ave(income, cities)) + cities = add_level(N = 2), + citizens = add_level(N = 1:2, + income = rnorm(N), + income_mean_city = ave(income, cities)) ) ave_example ``` @@ -92,8 +92,8 @@ library(dplyr) my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = c(2, 3), age = runif(N, 18, 70)) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = c(2, 3), age = runif(N, 18, 70)) ) %>% group_by(cities) %>% mutate(pop = n()) @@ -106,8 +106,8 @@ knitr::kable(my_data) ```{r echo=TRUE, results="hide"} my_data <- -data_frame(Y = sample(1:10, 2)) %>% - fabricate(lower_level = level(N = 3, Y2 = Y + rnorm(N))) +data_frame(Y = sample(1:10, 2)) %>% + fabricate(lower_level = add_level(N = 3, Y2 = Y + rnorm(N))) my_data ``` ```{r echo=FALSE} diff --git a/vignettes/getting_started.Rmd b/vignettes/getting_started.Rmd index 65ff1a6..a285685 100644 --- a/vignettes/getting_started.Rmd +++ b/vignettes/getting_started.Rmd @@ -66,10 +66,10 @@ The most powerful use of **fabricatr** is to create hierarchical ("nested") data ```{r echo=TRUE, results="hide"} country_data <- fabricate( - countries = level(N = 5, + countries = add_level(N = 5, gdp_per_capita = runif(N, min=10000, max=50000), life_expectancy = 50 + runif(N, 10, 20) + ((gdp_per_capita > 30000) * 10)), - provinces = level(N = 10, + provinces = add_level(N = 10, has_nat_resources = draw_discrete(x=0.3, N=N, type="bernoulli"), has_manufacturing = draw_discrete(x=0.7, N=N, type="bernoulli")) ) @@ -80,7 +80,7 @@ knitr::kable(head(country_data), format.args=list(big.mark = ",")) ``` -Several things can be observed in this example. First, fabricate knows that your second [`level()`](../reference/level.html) command will be nested under the first level of data. Each level gets its own ID variable, in addition to the variables you create. Second, the meaning of the variable "N" changes. During the [`level()`](../reference/level.html) call for countries, N is 5. During the [`level()`](../reference/level.html) call for provinces, N is 10. And the resulting data, of course, has 50 observations. +Several things can be observed in this example. First, fabricate knows that your second [`add_level()`](../reference/add_level.html) command will be nested under the first level of data. Each level gets its own ID variable, in addition to the variables you create. Second, the meaning of the variable "N" changes. During the [`add_level()`](../reference/add_level.html) call for countries, N is 5. During the [`add_level()`](../reference/level.html) call for provinces, N is 10. And the resulting data, of course, has 50 observations. Finally, the province-level variables are created using the [`draw_discrete()`](../reference/draw_discrete.html) function. This is a function provided by **fabricatr** to make simulating discrete random variables simple. When you simulate your own data, you can use **fabricatr**'s functions, R's built-ins, or any custom functions you wish. [`draw_discrete()`](../reference/draw_discrete.html) is explained in [our tutorial on variable generation using **fabricatr**](variable_generation.html) @@ -94,11 +94,11 @@ Imagine importing the country-province data simulated in the previous example. B citizen_data <- fabricate( data = country_data, - citizens = level(N=10, - salary = rnorm(N, - mean = gdp_per_capita + - has_nat_resources * 5000 + - has_manufacturing * 5000, + citizens = add_level(N=10, + salary = rnorm(N, + mean = gdp_per_capita + + has_nat_resources * 5000 + + has_manufacturing * 5000, sd = 10000))) head(citizen_data) ``` @@ -106,14 +106,13 @@ head(citizen_data) knitr::kable(head(citizen_data), format.args=list(big.mark = ",")) ``` - In this example, we add a third level of data; for each of our 50 country-province observations, we now have 10 citizen-level observations. Citizen-level covariates like salary can draw from both the country-level covariate and the province-level covariate. Notice that the syntax for adding a new nested level to existing data is different than the syntax for adding new variables to the original dataset. # Modifying existing levels -Suppose you have hierarchical data, and wish to simulate variables at a higher level of aggregation. For example, imagine you import a dataset containing citizens within countries, but you wish to simulate additional country-level variables. In **fabricatr**, you can do this using the [`level()`](../reference/level.html) command. +Suppose you have hierarchical data, and wish to simulate variables at a higher level of aggregation. For example, imagine you import a dataset containing citizens within countries, but you wish to simulate additional country-level variables. In **fabricatr**, you can do this using the [`modify_level()`](../reference/modify_level.html) command. Let's use our country-province data from earlier: @@ -121,7 +120,7 @@ Let's use our country-province data from earlier: new_country_data <- fabricate( data = country_data, - countries = level(avg_temp = runif(N, 30, 80)) + countries = modify_level(avg_temp = runif(N, 30, 80)) ) head(new_country_data) @@ -131,9 +130,7 @@ knitr::kable(head(new_country_data), format.args=list(big.mark = ",")) ``` -How does [`level()`](../reference/level.html) know whether to modify your data or add a new level? [`level()`](../reference/level.html) uses contextual information -- if the name you provide to your [`level()`](../reference/level.html) call is already a field that exists in your data set, [`level()`](../reference/level.html) will treat this as a request to modify this level of data. If, on the other hand, you provide a name not used in the data set, [`level()`](../reference/level.html) will assume you mean to add nested data under the existing data. - -We can observe that the new variable is created at the level of aggregation you chose -- countries. Also, although N is not specified anywhere, [`level()`](../reference/level.html) knows how large N should be based on the number of countries it finds in the dataset. It is important, then, to ensure that the [`level()`](../reference/level.html) command is correctly assigned to the level of interest. +We can observe that the new variable is created at the level of aggregation you chose -- countries. Also, although N is not specified anywhere, [`modify_level()`](../reference/level.html) knows how large N should be based on the number of countries it finds in the dataset. It is important, then, to ensure that the [`modify_level()`](../reference/level.html) command is correctly assigned to the level of interest. We can also modify more than one level. Recalling our country-province-citizen data from above, the following process is possible: @@ -141,22 +138,22 @@ We can also modify more than one level. Recalling our country-province-citizen d new_citizen_data <- fabricate( data = citizen_data, - countries = level(avg_temp = runif(N, 30, 80)), - provinces = level(conflict_zone = draw_discrete(N, - x=0.2 + has_nat_resources * 0.3, - type="binary"), - infant_mortality = runif(N, 0, 10) + - conflict_zone * 10 + - (avg_temp > 70) * 10), - citizens = level(college_degree = draw_discrete(N, - x=0.4 - (0.3 * conflict_zone), - type="binary")) + countries = modify_level(avg_temp = runif(N, 30, 80)), + provinces = modify_level(conflict_zone = draw_discrete(N, + x=0.2 + has_nat_resources * 0.3, + type="binary"), + infant_mortality = runif(N, 0, 10) + + conflict_zone * 10 + + (avg_temp > 70) * 10), + citizens = modify_level(college_degree = draw_discrete(N, + x=0.4 - (0.3 * conflict_zone), + type="binary")) ) ``` -Before assessing what this tells us about [`level()`](../reference/level.html), let's consider what the data simulated does. It creates a new variable at the country level, for a country level average temperature. Subsequently, it creates a province level binary indicator for whether the province is an active conflict site. Provinces that have natural resources are more likely to be in conflict in this simulation, drawing on conclusions from literature on "resource curses". The infant mortality rate for the province is able to depend both on province level data we have just generated, and country-level data: it is higher in high-temperature areas (reflecting literature on increased disease burden near the equator) and also higher in conflict zones. Citizens access to education is also random, but depends on whether they live in a conflict area. +Before assessing what this tells us about [`modify_level()`](../reference/modify_level.html), let's consider what the data simulated does. It creates a new variable at the country level, for a country level average temperature. Subsequently, it creates a province level binary indicator for whether the province is an active conflict site. Provinces that have natural resources are more likely to be in conflict in this simulation, drawing on conclusions from literature on "resource curses". The infant mortality rate for the province is able to depend both on province level data we have just generated, and country-level data: it is higher in high-temperature areas (reflecting literature on increased disease burden near the equator) and also higher in conflict zones. Citizens access to education is also random, but depends on whether they live in a conflict area. -There are a lot of things to learn from this example. First, it's possible to modify multiple levels. Any new variable created will automatically propagate to the lower level data according -- by setting an average temperature for a country, all provinces, and all citizens of those provinces, have the value for the country. Values created from one [`level()`](../reference/level.html) call can be used in subsequent variables of the same call, or subsequent calls. +There are a lot of things to learn from this example. First, it's possible to modify multiple levels. Any new variable created will automatically propagate to the lower level data according -- by setting an average temperature for a country, all provinces, and all citizens of those provinces, have the value for the country. Values created from one [`modify_level()`](../reference/level.html) call can be used in subsequent variables of the same call, or subsequent calls. Again, we see the use of [`draw_discrete()`](../reference/draw_discrete.html). Using this function is covered in our tutorial on [generating discrete random variables](variable_generation.html), linked below. diff --git a/vignettes/resampling.Rmd b/vignettes/resampling.Rmd index 5572404..8604e39 100644 --- a/vignettes/resampling.Rmd +++ b/vignettes/resampling.Rmd @@ -54,8 +54,8 @@ Consider this example, which takes a dataset containing 2 cities of 3 citizens, ```{r echo=TRUE, results="hide"} my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = 3, age = runif(N, 18, 70)) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = 3, age = runif(N, 18, 70)) ) my_data_2 <- resample_data(my_data, @@ -68,3 +68,20 @@ knitr::kable(my_data_2) ``` [`resample_data()`](../reference/resample_data.html) will first select the cities to be resampled. Then, for each city, it will continue by selecting the citizens to be resampled. If a higher level unit is used more than once (for example, the same city being chosen twice), and a lower level is subsequently resampled, the choices of which units to keep for the lower level will differ for each copy of the higher level. In this example, if city 1 is chosen twice, then the sets of five citizens chosen for each copy of the city 1 will differ. + +You can also specify the levels you wish to resample from using the name arguents to the `N` parameter, like in this example which does exactly the same thing as the previous example, but specifies the level names in a different way: + +```{r echo=TRUE, results="hide"} +my_data <- + fabricate( + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = 3, age = runif(N, 18, 70)) + ) + +my_data_2 <- resample_data(my_data, + N = c(cities=3, citizens=5)) +my_data_2 +``` +```{r echo=FALSE} +knitr::kable(my_data_2) +``` diff --git a/vignettes/variable_generation.Rmd b/vignettes/variable_generation.Rmd index 44f622e..f74b597 100644 --- a/vignettes/variable_generation.Rmd +++ b/vignettes/variable_generation.Rmd @@ -18,7 +18,7 @@ library(fabricatr) **fabricatr** provides a convenient helper function, [`draw_discrete()`](../reference/draw_discrete.html), which you can use to generate discrete random variables far more easily than using R's built-in data generation mechanisms. Below, we introduce you to the types of data you can generate using [`draw_discrete()`](../reference/draw_discrete.html). -# Binary and binomial outcomes +## Binary and binomial outcomes The simplest possible type of data, and [`draw_discrete()`](../reference/draw_discrete.html)'s default, is a binary random variable (also called a bernoulli random variable). Generating a binary random variable requires only one parameter `x` which specifies the probability that outcomes drawn from this variable are equal to 1. By default, [`draw_discrete()`](../reference/draw_discrete.html) will generate `N = length(x)` draws. `N` can also be specified explicitly. Consider these examples: @@ -59,7 +59,7 @@ bernoulli_probit = fabricate(N = 3, x = 10*rnorm(N), link = "probit")) ``` -# Ordered outcomes +## Ordered outcomes Some researchers may be interested in generating ordered outcomes -- for example, Likert scale outcomes. This can be done using the "ordered" type. Ordered variables require a vector of breakpoints, supplied as the argument `breaks` -- points at which the underlying latent variable switches from category to category. The first break should always be below the lower bound of the data, while the final break should always be above the upper bound of the data. @@ -88,7 +88,7 @@ ordered_probit_example = fabricate(N = 3, ) ``` -# Count outcomes +## Count outcomes [`draw_discrete()`](../reference/draw_discrete.html) supports Poisson-distributed count outcomes. These require that the user specify the parameter `x`, equal to the Poisson distribution mean (often referred to as `lambda`). @@ -98,7 +98,7 @@ count_outcome_example = fabricate(N = 3, count = draw_discrete(x, type = "count")) ``` -# Categorical data +## Categorical data [`draw_discrete()`](../reference/draw_discrete.html) can also generate non-ordered, categorical data. Users must provide a vector of probabilities for each category (or a matrix, if each observation should have separate probabilities), as well as setting `type` to be "categorical". @@ -127,3 +127,116 @@ warn_draw_discrete_example = fabricate(N = 6, ``` "categorical" variables can also use link functions, for example to generate multinomial probit data. + +# Fabricating cluster-correlated random variables. + +We also provide helper functions to generate cluster-correlated random variables with fixed intra-cluster correlation (ICC) values. Our two functions `draw_binary_icc()` and `draw_normal_icc()` allow you to generate both discrete binary data with fixed ICCs and normal data with fixed ICCs. + +## Binary data with fixed ICCs + +`draw_binary_icc()` takes three required arguments: `x`, a probability or vector of probabilities which determine the chance a given observation will be a 1; `cluster_ids`, a map of units to clusters (required to generate the correlation structure); and `rho`, the fixed intra-cluster correlation (from 0 to 1). Users may optionally specify `N`; if it is not specified, `draw_binary_icc()` will determine it based on the length of the `cluster_ids` vector. + +Consider the following example, which models whether individuals smoke: + +```{r echo=FALSE} +set.seed(19861108) +``` +```{r echo=TRUE, results="hide"} +# 100 individual population, 10 each in each of 10 clusters +cluster_ids = rep(1:10, 10) + +# Individuals have a 20% chance of smoking, but clusters are highly correlated +# in their tendency to smoke +smoker = draw_binary_icc(x = 0.2, + cluster_ids = cluster_ids, + rho = 0.7) + +# Observe distribution of smokers and non-smokers +table(smoker) +``` +```{r echo=FALSE} +knitr::kable(as.matrix(t(table(smoker)))) +``` + +We see that approximately 20% of the population smokes, in line with our specification, but what patterns of heterogeneity do we see by cluster? + +```{r echo=TRUE, results="hide"} +table(cluster_ids, smoker) +``` +```{r echo=FALSE} +knitr::kable(table(cluster_ids, smoker)) +``` + +We observe that 7 clusters have no smokers at all, two clusters are overwhelming smokers, and one cluster is overwhelmingly non-smokers. + +We can also specify separate means for each cluster; but it is worth noting that the higher the ICC, the more the cluster mean will depart from the nominal cluster mean. + +If you do not specify a vector of probabilities or a correlation coefficient, the default values are probability 0.5 for each cluster and ICC (rho) of 0.5. If you do not specify cluster IDs, the function will return an error. + +## Normal data with fixed ICCs + +`draw_normal_icc()` takes four required arguments: `x`, a mean or vector of means, one for each cluster; `cluster_ids`, a map of units to clusters (required to generate the correlation structure); `rho`, the fixed intra-cluster correlation coefficient; and `sd`, a standard deviation or vector of standard deviations, one for each cluster. Users can optionally specify `N`, a number of units, but if it is not supplied `draw_normal_icc()` will determine it based on the length of the `cluster_ids` vector. + +If `sd` is not supplied, each cluster will be assumed to have a within-cluster standard deviation of 1. If `x` is not supplied, each cluster will be assumed to be mean zero. If `rho` is not supplied, it will be set to 0.5. + +Here, we model student academic performance by cluster: +```{r echo=TRUE, results="hide"} +# 100 students, 10 each in 10 clusters +set.seed(19861108) +cluster_ids = rep(1:10, 10) + +numeric_grade = draw_normal_icc(x = 80, + cluster_ids = cluster_ids, + rho = 0.5, + sd = 15) + +letter_grade = draw_discrete(x = numeric_grade, + type = "ordered", + breaks = c(-Inf, 60, 70, 80, 90, Inf), + break_labels = c("F", "D", "C", "B", "A")) + +mean(numeric_grade) +``` +`r mean(numeric_grade) + +The mean grade matches the population mean. Now let's look at the relationship between cluster and letter grade to observe the cluster pattern: + +```{r echo=TRUE, results="hide"} +table(letter_grade, cluster_ids) +``` +```{r echo=FALSE} +knitr::kable(table(cluster_ids, letter_grade)) +``` + +It is obvious upon inspection that some clusters are higher performing than others despite having identical cluster means in expectation. + +## Technical Appendix + +When generating binary data with a fixed ICC, we follow this formula, where $i$ is a cluster and $j$ is a unit in a cluster: + +$$ +\begin{aligned} + z_i &\sim \text{Bern}(p_i) \\ + u_{ij} &\sim \text{Bern}(\sqrt{\rho}) \\ + x_{ij} &= + \begin{cases} + x_{ij} \sim \text{Bern}(p_i) & \quad \text{if } u_{ij} = 1 \\ + z_i & \quad \text{if } u_{ij} = 0 + \end{cases} +\end{aligned} +$$ + +In expectation, this guarantees an intra-cluster correlation of $\rho$ and a cluster proportion of $p_i$. This approach derives from Hossain, Akhtar and Chakraborti, Hrishikesh. "ICCBin: Facilitates Clustered Binary Data Generation, and Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data", available on [https://cran.r-project.org/web/packages/ICCbin/index.html](CRAN) or [https://github.com/akhtarh/ICCbin](GitHub) + +When generating normal data with a fixed ICC, we follow this formula, again with $i$ as a cluster and $j$ as a unit in the cluster: + +$$ +\begin{aligned} + \sigma^2_{\alpha i} &= \frac{(\rho * \sigma^2_{\epsilon i})}{(1 - \rho)} \\ + \alpha_i &\sim \mathcal{N}(0, \sigma^2_{\alpha i}) \\ + \mu_{ij} &\sim \mathcal{N}(\mu_i, \sigma^2_{\epsilon i}) \\ + x_{ij} &= \mu_{ij} + \alpha_i +\end{aligned} +$$ + +In expectation, this approach guarantees an intra-cluster correlation of $\rho$, a cluster mean of $\mu_{i}$, and a cluster-level variance in error terms of $\sigma^2_{\epsilon i}$. This approach is specified on [https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc](StatsExchange). From 354fd67465a70b44a9ec4bd910bdb3ddf662d8e6 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 12:55:41 -0800 Subject: [PATCH 25/47] Documentation push and fixed a bug in draw_normal_icc vignette. --- README.Rmd | 4 +- README.md | 4 +- docs/articles/advanced_features.html | 41 ++-- docs/articles/getting_started.html | 82 ++++---- docs/articles/resampling.html | 114 ++++++++++- docs/articles/variable_generation.html | 258 +++++++++++++++++++++++-- docs/index.html | 4 +- docs/reference/draw_binary_icc.html | 198 +++++++++++++++++++ docs/reference/draw_discrete.html | 68 ++++--- docs/reference/draw_normal_icc.html | 204 +++++++++++++++++++ docs/reference/fabricate.html | 53 +++-- docs/reference/index.html | 15 +- docs/reference/level.html | 49 +++-- docs/reference/resample_data.html | 137 +++++++------ man/draw_binary_icc.Rd | 19 +- man/draw_normal_icc.Rd | 14 +- vignettes/variable_generation.Rmd | 6 +- 17 files changed, 1029 insertions(+), 241 deletions(-) create mode 100644 docs/reference/draw_binary_icc.html create mode 100644 docs/reference/draw_normal_icc.html diff --git a/README.Rmd b/README.Rmd index 7d4d5eb..5182a42 100644 --- a/README.Rmd +++ b/README.Rmd @@ -35,12 +35,12 @@ Once the package is installed, it is easy to generate new data, or modify your o library(fabricatr) house_candidates = fabricate( - parties = level( + parties = add_level( N = 2, party_ideology = c(0.5, -0.5), in_power = c(1, 0), party_incumbents = c(241, 194)), - representatives = level( + representatives = add_level( N = party_incumbents, member_ideology = rnorm(N, party_ideology), terms_served = draw_discrete(N = N, x = 3, type = "count"), diff --git a/README.md b/README.md index 59d90da..10e9b11 100644 --- a/README.md +++ b/README.md @@ -24,12 +24,12 @@ Once the package is installed, it is easy to generate new data, or modify your o library(fabricatr) house_candidates = fabricate( - parties = level( + parties = add_level( N = 2, party_ideology = c(0.5, -0.5), in_power = c(1, 0), party_incumbents = c(241, 194)), - representatives = level( + representatives = add_level( N = party_incumbents, member_ideology = rnorm(N, party_ideology), terms_served = draw_discrete(N = N, x = 3, type = "count"), diff --git a/docs/articles/advanced_features.html b/docs/articles/advanced_features.html index 8d4b08c..c745f6b 100644 --- a/docs/articles/advanced_features.html +++ b/docs/articles/advanced_features.html @@ -107,11 +107,11 @@

    Aaron Rudkin

    More complicated level creation with variable numbers of observations

    -

    level() can be used to create more complicated patterns of nesting. For example, when creating lower level data, it is possible to use a different N for each of the values of the higher level data:

    +

    add_level() can be used to create more complicated patterns of nesting. For example, when creating lower level data, it is possible to use a different N for each of the values of the higher level data:

    variable_data <-
   fabricate(
-    cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
-    citizens = level(N = c(2, 4), age = runif(N, 18, 70))
+    cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
+    citizens = add_level(N = c(2, 4), age = runif(N, 18, 70))
   )
 variable_data
    @@ -160,13 +160,13 @@

    -

    Here, each city has a different number of citizens. And the value of N used to create the age variable automatically updates as needed. The result is a dataset with 6 citizens, 2 in the first city and 4 in the second. As long as N is either a number, or a vector of the same length of the current lowest level of the data, level() will know what to do.

    +

    Here, each city has a different number of citizens. And the value of N used to create the age variable automatically updates as needed. The result is a dataset with 6 citizens, 2 in the first city and 4 in the second. As long as N is either a number, or a vector of the same length of the current lowest level of the data, add_level() will know what to do.

    It is also possible to provide a function to N, enabling a random number of citizens per city:

    my_data <-
   fabricate(
-    cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
-    citizens = level(N = sample(1:6, size = 2, replace = TRUE), 
-                     age = runif(N, 18, 70))
+    cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
+    citizens = add_level(N = sample(1:6, size = 2, replace = TRUE), 
+                         age = runif(N, 18, 70))
   )
 my_data
    @@ -218,50 +218,43 @@

    Here, each city is given a random number of citizens between 1 and 6. Since the sample() function returns a vector of length 2, this is like specifying 2 separate Ns as in the example above.

    Finally, it is possible to define N on the basis of higher level variables themselves. Consider the following example:

    variable_n_function = fabricate(
-  cities = level(N = 5, population = runif(N, 10, 200)),
-  citizens = level(N = round(population * 0.3))
+  cities = add_level(N = 5, population = runif(N, 10, 200)),
+  citizens = add_level(N = round(population * 0.3))
 )
 head(variable_n_function)

    - - - - - - - @@ -275,10 +268,10 @@

    Averages within higher levels of hierarchy

    You may want to include the mean value of a variable within a group defined by a higher level of the hierarchy, for example the average income of citizens within city. You can do this with ave():

    ave_example = fabricate(
-    cities = level(N = 2),
-    citizens = level(N = 1:2, 
-                     income = rnorm(N), 
-                     income_mean_city = ave(income, cities))
+    cities = add_level(N = 2),
+    citizens = add_level(N = 1:2, 
+                         income = rnorm(N), 
+                         income_mean_city = ave(income, cities))
     ) 
 ave_example
    cities population citizens
    1 1 90 001
    1.1 1 90 002
    1.2 1 90 003
    1.3 1 90 004
    1.4 1 90 005
    1.5 1 90 006
    @@ -320,8 +313,8 @@

    my_data <- fabricate( - cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), - citizens = level(N = c(2, 3), age = runif(N, 18, 70)) + cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)), + citizens = add_level(N = c(2, 3), age = runif(N, 18, 70)) ) %>% group_by(cities) %>% mutate(pop = n()) @@ -374,8 +367,8 @@ 

    my_data <- 
-data_frame(Y = sample(1:10, 2)) %>%
-  fabricate(lower_level = level(N = 3, Y2 = Y + rnorm(N)))
+data_frame(Y = sample(1:10, 2)) %>% 
+  fabricate(lower_level = add_level(N = 3, Y2 = Y + rnorm(N)))
 my_data
    diff --git a/docs/articles/getting_started.html b/docs/articles/getting_started.html index a81f925..0f93217 100644 --- a/docs/articles/getting_started.html +++ b/docs/articles/getting_started.html @@ -172,6 +172,7 @@

    + @@ -182,6 +183,7 @@

    + @@ -191,6 +193,7 @@

    + @@ -200,6 +203,7 @@

    + @@ -209,6 +213,7 @@

    + @@ -218,6 +223,7 @@

    + @@ -227,6 +233,7 @@

    + @@ -240,10 +247,10 @@

    The most powerful use of fabricatr is to create hierarchical (“nested”) data. In the example below, we create 5 countries, each of which has 10 provinces:

    country_data <-
   fabricate(
-    countries = level(N = 5, 
+    countries = add_level(N = 5, 
                       gdp_per_capita = runif(N, min=10000, max=50000),
                       life_expectancy = 50 + runif(N, 10, 20) + ((gdp_per_capita > 30000) * 10)),
-    provinces = level(N = 10,
+    provinces = add_level(N = 10,
                       has_nat_resources = draw_discrete(x=0.3, N=N, type="bernoulli"),
                       has_manufacturing = draw_discrete(x=0.7, N=N, type="bernoulli"))
   )
@@ -308,7 +315,7 @@

    depth mag stationsID fatalities insurance_cost
    562 4.8 410001 611 1.0e+09
    650 4.2 150002 290 3.0e+08
    42 5.4 430003 427 7.8e+08
    626 4.1 190004 470 5.2e+08
    649 4.0 110005 456 7.2e+08
    195 4.0 120006 390 7.0e+08
    -

    Several things can be observed in this example. First, fabricate knows that your second level() command will be nested under the first level of data. Each level gets its own ID variable, in addition to the variables you create. Second, the meaning of the variable “N” changes. During the level() call for countries, N is 5. During the level() call for provinces, N is 10. And the resulting data, of course, has 50 observations.

    +

    Several things can be observed in this example. First, fabricate knows that your second add_level() command will be nested under the first level of data. Each level gets its own ID variable, in addition to the variables you create. Second, the meaning of the variable “N” changes. During the add_level() call for countries, N is 5. During the add_level() call for provinces, N is 10. And the resulting data, of course, has 50 observations.

    Finally, the province-level variables are created using the draw_discrete() function. This is a function provided by fabricatr to make simulating discrete random variables simple. When you simulate your own data, you can use fabricatr’s functions, R’s built-ins, or any custom functions you wish. draw_discrete() is explained in our tutorial on variable generation using fabricatr

    @@ -319,11 +326,11 @@ 

    citizen_data <- 
   fabricate(
     data = country_data,
-    citizens = level(N=10,
-                     salary = rnorm(N, 
-                                    mean = gdp_per_capita + 
-                                      has_nat_resources * 5000 + 
-                                      has_manufacturing * 5000,
+    citizens = add_level(N=10,
+                         salary = rnorm(N, 
+                                        mean = gdp_per_capita +
+                                          has_nat_resources * 5000 + 
+                                          has_manufacturing * 5000,
                                     sd = 10000)))
 head(citizen_data)
    @@ -406,101 +413,100 @@

    Modifying existing levels

    -

    Suppose you have hierarchical data, and wish to simulate variables at a higher level of aggregation. For example, imagine you import a dataset containing citizens within countries, but you wish to simulate additional country-level variables. In fabricatr, you can do this using the level() command.

    +

    Suppose you have hierarchical data, and wish to simulate variables at a higher level of aggregation. For example, imagine you import a dataset containing citizens within countries, but you wish to simulate additional country-level variables. In fabricatr, you can do this using the modify_level() command.

    Let’s use our country-province data from earlier:

    new_country_data <-
   fabricate(
     data = country_data,
-    countries = level(avg_temp = runif(N, 30, 80))
+    countries = modify_level(avg_temp = runif(N, 30, 80))
   )
 
 head(new_country_data)

    + + - - + + - - + + - - + + - - + + - - + + - - + + - -
    countriesgdp_per_capitalife_expectancy provinces has_nat_resources has_manufacturinggdp_per_capitalife_expectancy avg_temp
    139,39873 01 1 139,39873 33
    139,39873 02 1 139,39873 33
    139,39873 03 0 139,39873 33
    139,39873 04 0 139,39873 33
    139,39873 05 1 039,39873 33
    139,39873 06 0 139,39873 33
    -

    How does level() know whether to modify your data or add a new level? level() uses contextual information – if the name you provide to your level() call is already a field that exists in your data set, level() will treat this as a request to modify this level of data. If, on the other hand, you provide a name not used in the data set, level() will assume you mean to add nested data under the existing data.

    -

    We can observe that the new variable is created at the level of aggregation you chose – countries. Also, although N is not specified anywhere, level() knows how large N should be based on the number of countries it finds in the dataset. It is important, then, to ensure that the level() command is correctly assigned to the level of interest.

    +

    We can observe that the new variable is created at the level of aggregation you chose – countries. Also, although N is not specified anywhere, modify_level() knows how large N should be based on the number of countries it finds in the dataset. It is important, then, to ensure that the modify_level() command is correctly assigned to the level of interest.

    We can also modify more than one level. Recalling our country-province-citizen data from above, the following process is possible:

    new_citizen_data <-
   fabricate(
     data = citizen_data,
-    countries = level(avg_temp = runif(N, 30, 80)),
-    provinces = level(conflict_zone = draw_discrete(N, 
-                                                    x=0.2 + has_nat_resources * 0.3,
-                                                    type="binary"),
-                      infant_mortality = runif(N, 0, 10) + 
-                        conflict_zone * 10 + 
-                        (avg_temp > 70) * 10),
-    citizens = level(college_degree = draw_discrete(N, 
-                                                    x=0.4 - (0.3 * conflict_zone), 
-                                                    type="binary"))
+    countries = modify_level(avg_temp = runif(N, 30, 80)),
+    provinces = modify_level(conflict_zone = draw_discrete(N, 
+                                                           x=0.2 + has_nat_resources * 0.3,
+                                                           type="binary"),
+                             infant_mortality = runif(N, 0, 10) + 
+                               conflict_zone * 10 + 
+                               (avg_temp > 70) * 10),
+    citizens = modify_level(college_degree = draw_discrete(N, 
+                                                           x=0.4 - (0.3 * conflict_zone),
+                                                           type="binary"))
   )
    -

    Before assessing what this tells us about level(), let’s consider what the data simulated does. It creates a new variable at the country level, for a country level average temperature. Subsequently, it creates a province level binary indicator for whether the province is an active conflict site. Provinces that have natural resources are more likely to be in conflict in this simulation, drawing on conclusions from literature on “resource curses”. The infant mortality rate for the province is able to depend both on province level data we have just generated, and country-level data: it is higher in high-temperature areas (reflecting literature on increased disease burden near the equator) and also higher in conflict zones. Citizens access to education is also random, but depends on whether they live in a conflict area.

    -

    There are a lot of things to learn from this example. First, it’s possible to modify multiple levels. Any new variable created will automatically propagate to the lower level data according – by setting an average temperature for a country, all provinces, and all citizens of those provinces, have the value for the country. Values created from one level() call can be used in subsequent variables of the same call, or subsequent calls.

    +

    Before assessing what this tells us about modify_level(), let’s consider what the data simulated does. It creates a new variable at the country level, for a country level average temperature. Subsequently, it creates a province level binary indicator for whether the province is an active conflict site. Provinces that have natural resources are more likely to be in conflict in this simulation, drawing on conclusions from literature on “resource curses”. The infant mortality rate for the province is able to depend both on province level data we have just generated, and country-level data: it is higher in high-temperature areas (reflecting literature on increased disease burden near the equator) and also higher in conflict zones. Citizens access to education is also random, but depends on whether they live in a conflict area.

    +

    There are a lot of things to learn from this example. First, it’s possible to modify multiple levels. Any new variable created will automatically propagate to the lower level data according – by setting an average temperature for a country, all provinces, and all citizens of those provinces, have the value for the country. Values created from one modify_level() call can be used in subsequent variables of the same call, or subsequent calls.

    Again, we see the use of draw_discrete(). Using this function is covered in our tutorial on generating discrete random variables, linked below.

    diff --git a/docs/articles/resampling.html b/docs/articles/resampling.html index a2ba605..8925dce 100644 --- a/docs/articles/resampling.html +++ b/docs/articles/resampling.html @@ -180,8 +180,8 @@

    Consider this example, which takes a dataset containing 2 cities of 3 citizens, and resamples it into a dataset of 3 cities, each containing 5 citizens.

    my_data <-
   fabricate(
-    cities = level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
-    citizens = level(N = 3, age = runif(N, 18, 70))
+    cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
+    citizens = add_level(N = 3, age = runif(N, 18, 70))
   )
 
 my_data_2 <- resample_data(my_data, 
@@ -289,6 +289,116 @@ 
    
 
 
 
    resample_data() will first select the cities to be resampled. Then, for each city, it will continue by selecting the citizens to be resampled. If a higher level unit is used more than once (for example, the same city being chosen twice), and a lower level is subsequently resampled, the choices of which units to keep for the lower level will differ for each copy of the higher level. In this example, if city 1 is chosen twice, then the sets of five citizens chosen for each copy of the city 1 will differ.
    
+
    You can also specify the levels you wish to resample from using the name arguents to the N parameter, like in this example which does exactly the same thing as the previous example, but specifies the level names in a different way:
    
+
    my_data <-
+  fabricate(
+    cities = add_level(N = 2, elevation = runif(n = N, min = 1000, max = 2000)),
+    citizens = add_level(N = 3, age = runif(N, 18, 70))
+  )
+
+my_data_2 <- resample_data(my_data, 
+                           N = c(cities=3, citizens=5))
+my_data_2
    
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
    citieselevationcitizensage
    21014639
    21014551
    21014551
    21014639
    21014551
    21014441
    21014639
    21014551
    21014441
    21014551
    11421164
    11421266
    11421343
    11421343
    11421266

    diff --git a/docs/articles/variable_generation.html b/docs/articles/variable_generation.html index d0c0bb5..ccfac67 100644 --- a/docs/articles/variable_generation.html +++ b/docs/articles/variable_generation.html @@ -108,10 +108,9 @@

    Aaron Rudkin

    Fabricating discrete random variables.

    fabricatr provides a convenient helper function, draw_discrete(), which you can use to generate discrete random variables far more easily than using R’s built-in data generation mechanisms. Below, we introduce you to the types of data you can generate using draw_discrete().

    -
    -
    -

    -Binary and binomial outcomes

    +
    +

    +Binary and binomial outcomes

    The simplest possible type of data, and draw_discrete()’s default, is a binary random variable (also called a bernoulli random variable). Generating a binary random variable requires only one parameter x which specifies the probability that outcomes drawn from this variable are equal to 1. By default, draw_discrete() will generate N = length(x) draws. N can also be specified explicitly. Consider these examples:

    draw_discrete_ex = fabricate(N = 3, p = c(0, .5, 1), 
                              binary_1 = draw_discrete(x = p),
@@ -136,9 +135,9 @@ 
    
                                                     type = "bernoulli", 
                                                     link = "probit"))
    -
    -

    -Ordered outcomes

    +
    +

    +Ordered outcomes

    Some researchers may be interested in generating ordered outcomes – for example, Likert scale outcomes. This can be done using the “ordered” type. Ordered variables require a vector of breakpoints, supplied as the argument breaks – points at which the underlying latent variable switches from category to category. The first break should always be below the lower bound of the data, while the final break should always be above the upper bound of the data.

    In the following example, each of three observations has a latent variable x which is continuous and unbounded. The variable ordered transforms x into three numeric categories: 1, 2, and 3. All values of x below -1 result in ordered 1; all values of x between -1 and 1 result in ordered 2; all values of x above 1 result in ordered 3:

    ordered_example = fabricate(N = 3, 
@@ -158,17 +157,17 @@ 
    
                                                            )
                                    )
    -
    -

    -Count outcomes

    +
    +

    +Count outcomes

    draw_discrete() supports Poisson-distributed count outcomes. These require that the user specify the parameter x, equal to the Poisson distribution mean (often referred to as lambda).

    count_outcome_example = fabricate(N = 3, 
                                   x = c(0, 5, 100), 
                                   count = draw_discrete(x, type = "count"))
    -
    -

    -Categorical data

    +
    +

    +Categorical data

    draw_discrete() can also generate non-ordered, categorical data. Users must provide a vector of probabilities for each category (or a matrix, if each observation should have separate probabilities), as well as setting type to be “categorical”.

    If probabilities do not sum to exactly one, they will be normalized, but negative probabilities will cause an error.

    In the first example, each unit has a different set of probabilities and the probabilities are provided as a matrix:

    @@ -192,6 +191,225 @@

    ## category probabilities, identical for each observation.

    “categorical” variables can also use link functions, for example to generate multinomial probit data.

    +
    +
    +

    +Fabricating cluster-correlated random variables.

    +

    We also provide helper functions to generate cluster-correlated random variables with fixed intra-cluster correlation (ICC) values. Our two functions draw_binary_icc() and draw_normal_icc() allow you to generate both discrete binary data with fixed ICCs and normal data with fixed ICCs.

    +
    +

    +Binary data with fixed ICCs

    +

    draw_binary_icc() takes three required arguments: x, a probability or vector of probabilities which determine the chance a given observation will be a 1; cluster_ids, a map of units to clusters (required to generate the correlation structure); and rho, the fixed intra-cluster correlation (from 0 to 1). Users may optionally specify N; if it is not specified, draw_binary_icc() will determine it based on the length of the cluster_ids vector.

    +

    Consider the following example, which models whether individuals smoke:

    +
    # 100 individual population, 10 each in each of 10 clusters
+cluster_ids = rep(1:10, 10)
+
+# Individuals have a 20% chance of smoking, but clusters are highly correlated
+# in their tendency to smoke
+smoker = draw_binary_icc(x = 0.2,
+                         cluster_ids = cluster_ids,
+                         rho = 0.7)
+
+# Observe distribution of smokers and non-smokers
+table(smoker)
    + + + + + + + + + +
    01
    8317
    +

    We see that approximately 20% of the population smokes, in line with our specification, but what patterns of heterogeneity do we see by cluster?

    +
    table(cluster_ids, smoker)
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    01
    100
    100
    100
    100
    100
    19
    100
    91
    37
    100
    +

    We observe that 7 clusters have no smokers at all, two clusters are overwhelming smokers, and one cluster is overwhelmingly non-smokers.

    +

    We can also specify separate means for each cluster; but it is worth noting that the higher the ICC, the more the cluster mean will depart from the nominal cluster mean.

    +

    If you do not specify a vector of probabilities or a correlation coefficient, the default values are probability 0.5 for each cluster and ICC (rho) of 0.5. If you do not specify cluster IDs, the function will return an error.

    +
    +
    +

    +Normal data with fixed ICCs

    +

    draw_normal_icc() takes four required arguments: x, a mean or vector of means, one for each cluster; cluster_ids, a map of units to clusters (required to generate the correlation structure); rho, the fixed intra-cluster correlation coefficient; and sd, a standard deviation or vector of standard deviations, one for each cluster. Users can optionally specify N, a number of units, but if it is not supplied draw_normal_icc() will determine it based on the length of the cluster_ids vector.

    +

    If sd is not supplied, each cluster will be assumed to have a within-cluster standard deviation of 1. If x is not supplied, each cluster will be assumed to be mean zero. If rho is not supplied, it will be set to 0.5.

    +

    Here, we model student academic performance by cluster:

    +
    # 100 students, 10 each in 10 clusters
+cluster_ids = rep(1:10, 10)
+
+numeric_grade = draw_normal_icc(x = 80,
+                               cluster_ids = cluster_ids,
+                               rho = 0.5,
+                               sd = 15)
+
+letter_grade = draw_discrete(x = numeric_grade,
+                             type = "ordered",
+                             breaks = c(-Inf, 60, 70, 80, 90, Inf),
+                             break_labels = c("F", "D", "C", "B", "A"))
+
+mean(numeric_grade)
    +

    82.77

    +

    The mean grade matches the population mean. Now let’s look at the relationship between cluster and letter grade to observe the cluster pattern:

    +
    table(letter_grade, cluster_ids)
    + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
    ABCDF
    62200
    22420
    20404
    03052
    91000
    10441
    62110
    32401
    51121
    23410
    +

    It is obvious upon inspection that some clusters are higher performing than others despite having identical cluster means in expectation.

    +
    +
    +

    +Technical Appendix

    +

    When generating binary data with a fixed ICC, we follow this formula, where \(i\) is a cluster and \(j\) is a unit in a cluster:

    +

    \[ +\begin{aligned} + z_i &\sim \text{Bern}(p_i) \\ + u_{ij} &\sim \text{Bern}(\sqrt{\rho}) \\ + x_{ij} &= + \begin{cases} + x_{ij} \sim \text{Bern}(p_i) & \quad \text{if } u_{ij} = 1 \\ + z_i & \quad \text{if } u_{ij} = 0 + \end{cases} +\end{aligned} +\]

    +

    In expectation, this guarantees an intra-cluster correlation of \(\rho\) and a cluster proportion of \(p_i\). This approach derives from Hossain, Akhtar and Chakraborti, Hrishikesh. “ICCBin: Facilitates Clustered Binary Data Generation, and Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data”, available on https://cran.r-project.org/web/packages/ICCbin/index.html or https://github.com/akhtarh/ICCbin

    +

    When generating normal data with a fixed ICC, we follow this formula, again with \(i\) as a cluster and \(j\) as a unit in the cluster:

    +

    \[ +\begin{aligned} + \sigma^2_{\alpha i} &= \frac{(\rho * \sigma^2_{\epsilon i})}{(1 - \rho)} \\ + \alpha_i &\sim \mathcal{N}(0, \sigma^2_{\alpha i}) \\ + \mu_{ij} &\sim \mathcal{N}(\mu_i, \sigma^2_{\epsilon i}) \\ + x_{ij} &= \mu_{ij} + \alpha_i +\end{aligned} +\]

    +

    In expectation, this approach guarantees an intra-cluster correlation of \(\rho\), a cluster mean of \(\mu_{i}\), and a cluster-level variance in error terms of \(\sigma^2_{\epsilon i}\). This approach is specified on https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc.

    +
    +
    @@ -200,12 +418,22 @@

    Contents

    diff --git a/docs/index.html b/docs/index.html index 28b9b7e..94f791b 100644 --- a/docs/index.html +++ b/docs/index.html @@ -120,12 +120,12 @@ 

    library(fabricatr)
 
 house_candidates = fabricate(
-  parties = level(
+  parties = add_level(
     N = 2, 
     party_ideology = c(0.5, -0.5), 
     in_power = c(1, 0), 
     party_incumbents = c(241, 194)),
-  representatives = level(
+  representatives = add_level(
     N = party_incumbents, 
     member_ideology = rnorm(N, party_ideology),
     terms_served = draw_discrete(N = N, x = 3, type = "count"),
diff --git a/docs/reference/draw_binary_icc.html b/docs/reference/draw_binary_icc.html
new file mode 100644
index 0000000..198e3c2
--- /dev/null
+++ b/docs/reference/draw_binary_icc.html
@@ -0,0 +1,198 @@
+
+
+
+  
+  
+
+
+
+fabricatr - Draw binary data with fixed intra-cluster correlation. — draw_binary_icc
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+  
+  
+
+
+
+
+
+
+  
+
+  
+    
    
+      
    
+      
+
+      
+      
    
+
+      
    
+  
    
+    
    
+    
    Draw binary data with fixed intra-cluster correlation.
    
+    
    
+
+    
+    
    Data is generated to ensure inter-cluster correlation 0, intra-cluster
+correlation in expectation \(\rho\). Algorithm taken from Hossein,
+Akhtar. "ICCbin: An R Package Facilitating Clustered Binary Data
+Generation, and Estimation of Intracluster Correlation Coefficient (ICC)
+for Binary Data".
    
+    
+
+    
    draw_binary_icc(x = 0.5, N = NULL, cluster_ids, rho = 0.5)
    
+    
+    
     Arguments
    
+    
+    
+    
+      
+      
+    
+    
+      
+      
+    
+    
+      
+      
+    
+    
+      
+      
+    
+    
    x
    A number or vector of numbers, one probability per cluster.
    N
    (Optional) A number indicating the number of observations to be
+generated. Must be equal to length(cluster_ids) if provided.
    cluster_ids
    A vector of factors or items that can be coerced to
+clusters; the length will determine the length of the generated data.
    rho
    A number indicating the desired RCC.
    
+    
+    
    Value
    
+
+    
    A vector of binary numbers corresponding to the observations from
+the supplied cluster IDs.
    
+    
+
+    
    Examples
    
+    
    cluster_ids = rep(1:5, 10)
+draw_binary_icc(cluster_ids = cluster_ids)
    #>  [1] 0 1 0 0 0 1 1 1 0 0 0 0 1 0 0 0 1 1 0 0 0 1 1 1 0 0 1 1 0 0 0 1 1 0 0 1 1 1
+#> [39] 1 0 0 1 1 0 0 0 0 1 0 0
    draw_binary_icc(x = 0.5, cluster_ids = cluster_ids, rho = 0.5)
    #>  [1] 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 0 1 1 1 0 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 0
+#> [39] 1 1 1 0 1 1 1 0 1 1 1 1
    
+
    
+  
    
+  
+
    
+
+      
    
+      
    
+  
    Developed by Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys, Aaron Rudkin.
    
+  
    Code is licensed under MIT license.
    
+
    
+
+
    
+  
    Site built with pkgdown.
    
+
    
+
+      
    
+   
    
+
+  
+
diff --git a/docs/reference/draw_discrete.html b/docs/reference/draw_discrete.html
index 9c95dcc..3f0a0d0 100644
--- a/docs/reference/draw_discrete.html
+++ b/docs/reference/draw_discrete.html
@@ -6,7 +6,8 @@
 
 
 
-fabricatr - Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical — draw_discrete
+fabricatr - Draw discrete variables including binary, binomial count, poisson count,
+ordered, and categorical — draw_discrete
 
 
 
@@ -119,15 +120,19 @@
       
    
   
    
     
    
-    
    Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical
    
+    
    Draw discrete variables including binary, binomial count, poisson count,
+ordered, and categorical
    
     
    
 
     
-    
    Drawing discrete data based on probabilities or latent traits is a common task that can be cumbersome. draw_binary is an alias for draw_discrete(type = "binary") that allows you to draw binary outcomes more easily.
    
+    
    Drawing discrete data based on probabilities or latent traits is a common
+task that can be cumbersome. draw_binary is an alias for
+draw_discrete(type = "binary") that allows you to draw binary
+outcomes more easily.
    
     
 
     
    draw_discrete(x, N = length(x), type = "binary", link = "identity",
-  breaks = c(-Inf, 0, Inf), break_labels = FALSE, k = 1)
+  breaks = c(-Inf, 0, Inf), break_labels = NULL, k = 1)
 
 draw_binary(x, N = length(x), link = "identity")
    
     
@@ -136,19 +141,26 @@ 
     Ar
     
     
       x
-      
    vector representing either the latent variable used to draw the count outcome (if link is "logit" or "probit") or the probability for the count outcome (if link is "identity"). For cartegorical distributions x is a matrix with as many columns as possible outcomes.
    
+      
    vector representing either the latent variable used to draw the
+count outcome (if link is "logit" or "probit") or the probability for the
+count outcome (if link is "identity"). For cartegorical distributions x is
+a matrix with as many columns as possible outcomes.
    
     
     
       N
-      
    number of units to draw. Defaults to the length of the vector x
    
+      
    number of units to draw. Defaults to the length of the vector
+x
    
     
     
       type
-      
    type of discrete outcome to draw, one of 'binary' (or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count'
    
+      
    type of discrete outcome to draw, one of 'binary'
+(or 'bernoulli'), 'binomial', 'categorical', 'ordered' or 'count'
    
     
     
       link
-      
    link function between the latent variable and the probability of a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity" link, the latent variable must be a probability.
    
+      
    link function between the latent variable and the probability of
+a postiive outcome, i.e. "logit", "probit", or "identity". For the "identity"
+link, the latent variable must be a probability.
    
     
     
       breaks
@@ -156,7 +168,8 @@ 
     Ar
     
     
       break_labels
-      
    vector of labels for the breaks for an ordered latent outcome (must be the same length as breaks)
    
+      
    vector of labels for the breaks for an ordered latent
+outcome (must be the same length as breaks)
    
     
     
       k
@@ -180,37 +193,38 @@ 
    Examp
 #> 3  3 1.0      1
    
 fabricate(N = 3,
    x = 10*rnorm(N),
-   binary = draw_discrete(x, type = "bernoulli", link = "probit"))
    #>   ID            x binary
-#> 1  1   2.55317055      1
-#> 2  2 -24.37263611      0
-#> 3  3  -0.05571287      1
    
+   binary = draw_discrete(x, type = "bernoulli", link = "probit"))
    #>   ID    x binary
+#> 1  1 -5.6      0
+#> 2  2 -5.4      0
+#> 3  3  2.3      1
    
 fabricate(N = 3,
    p = c(0, .5, 1),
    binomial = draw_discrete(p, type = "binomial", k = 10))
    #>   ID   p binomial
 #> 1  1 0.0        0
-#> 2  2 0.5        4
+#> 2  2 0.5        3
 #> 3  3 1.0       10
    
 fabricate(N = 3,
    x = 5*rnorm(N),
-   ordered = draw_discrete(x, type = "ordered", breaks = c(-Inf, -1, 1, Inf)))
    #>   ID         x ordered
-#> 1  1 -9.109088       1
-#> 2  2 -1.236627       1
-#> 3  3 -1.220998       1
    
+   ordered = draw_discrete(x, type = "ordered",
+   breaks = c(-Inf, -1, 1, Inf)))
    #>   ID    x ordered
+#> 1  1 -7.0       1
+#> 2  2  1.3       3
+#> 3  3 -2.2       1
    
 fabricate(N = 3,
    x = c(0,5,100),
    count = draw_discrete(x, type = "count"))
    #>   ID   x count
 #> 1  1   0     0
-#> 2  2   5     4
-#> 3  3 100   119
    
+#> 2  2   5     6
+#> 3  3 100   111
    
 # Categorical
 fabricate(N = 6, p1 = runif(N), p2 = runif(N), p3 = runif(N),
-         cat = draw_discrete(cbind(p1, p2, p3), type = "categorical"))
    #>   ID         p1         p2        p3 cat
-#> 1  1 0.67838043 0.53021246 0.6364656   1
-#> 2  2 0.73531960 0.69582388 0.4790245   2
-#> 3  3 0.19595673 0.68855600 0.4321713   2
-#> 4  4 0.98053967 0.03123033 0.7064338   3
-#> 5  5 0.74152153 0.22556253 0.9485766   1
-#> 6  6 0.05144628 0.30083081 0.1803388   2
    + cat = draw_discrete(cbind(p1, p2, p3), type = "categorical"))
    #> ID p1 p2 p3 cat +#> 1 1 0.219 0.407 0.37 2 +#> 2 2 0.665 0.858 0.92 2 +#> 3 3 0.390 0.518 0.68 3 +#> 4 4 0.046 0.979 0.67 3 +#> 5 5 0.617 0.017 0.76 1 +#> 6 6 0.598 0.673 0.54 1
    -

    fabricate helps you simulate a dataset before you collect it. You can either start with your own data and add simulated variables to it (by passing data to fabricate()) or start from scratch by defining N. Create hierarchical data with multiple levels of data such as citizens within cities within states using add_level() or modify existing hierarchical data using modify_level(). You can use any R function to create each variable. We provide several built-in options to easily draw from binary and count outcomes, draw_binary and draw_discrete.

    +

    fabricate helps you simulate a dataset before you collect it. You can +either start with your own data and add simulated variables to it (by passing +data to fabricate()) or start from scratch by defining +N. Create hierarchical data with multiple levels of data such as +citizens within cities within states using add_level() or modify +existing hierarchical data using modify_level(). You can use any R +function to create each variable. We provide several built-in options to +easily draw from binary and count outcomes, draw_binary, +draw_binary_icc, and draw_discrete.

    fabricate(data = NULL, N = NULL, ID_label = NULL, ...)
@@ -139,11 +147,18 @@ 
     Ar
     
     
       data
-      
    (optional) user-provided data that forms the basis of the fabrication, i.e. you can add variables to existing data. Provide either N or data (N is the number of rows of the data if data is provided).
    
+      
    (optional) user-provided data that forms the basis of the
+fabrication, i.e. you can add variables to existing data. Provide either
+N or data (N is the number of rows of the data if
+data is provided).
    
     
     
       N
-      
    (optional) number of units to draw. If provided as fabricate(N = 5), this determines the number of units in the single-level data. If provided in level, i.e. fabricate(cities = level(N = 5)), N determines the number of units in a specific level of a hierarchical dataset.
    
+      
    (optional) number of units to draw. If provided as
+fabricate(N = 5), this determines the number of units in the
+single-level data. If provided in add_level, i.e.
+fabricate(cities = add_level(N = 5)), N determines the number
+of units in a specific level of a hierarchical dataset.
    
     
     
       ID_label
@@ -151,7 +166,10 @@ 
     Ar
     
     
       ...
-      
    Variable or level-generating arguments, such as my_var = rnorm(N). For fabricate, you may also pass add_level() or modify_level() arguments, which define a level of a multi-level dataset. See examples.
    
+      
    Variable or level-generating arguments, such as
+my_var = rnorm(N). For fabricate, you may also pass
+add_level() or modify_level() arguments, which define a level
+of a multi-level dataset. See examples.
    
     
     
       working_environment_
@@ -163,7 +181,8 @@ 
     Ar
     
     
       new_hierarchy
-      
    Reserved argument for future functionality to add cross-classified data. Not yet implemented.
    
+      
    Reserved argument for future functionality to add
+cross-classified data. Not yet implemented.
    
     
     
     
@@ -189,12 +208,12 @@ 
    Examp
   height_ft = runif(N, 3.5, 8)
 )
 head(df)
    #>    ID height_ft
-#> 1 001  6.945201
-#> 2 002  6.963537
-#> 3 003  7.958205
-#> 4 004  7.867344
-#> 5 005  5.251322
-#> 6 006  5.575339
    
+#> 1 001       4.2
+#> 2 002       7.7
+#> 3 003       7.9
+#> 4 004       6.7
+#> 5 005       7.5
+#> 6 006       7.9
    
 # Start with existing data
 df <- fabricate(
   data = df,
@@ -207,12 +226,12 @@ 
    Examp
  regions = add_level(N = 5),
  cities = add_level(N = 2, pollution = rnorm(N, mean = 5)))
 head(df)
    #>   regions cities pollution
-#> 1       1     01  5.239065
-#> 2       1     02  5.236321
-#> 3       2     03  4.740881
-#> 4       2     04  5.649046
-#> 5       3     05  3.782359
-#> 6       3     06  5.841970
    
+#> 1       1     01       5.3
+#> 2       1     02       6.4
+#> 3       2     03       4.8
+#> 4       2     04       5.7
+#> 5       3     05       5.1
+#> 6       3     06       5.0
    
 # Start with existing data and add variables to hierarchical data
 # at levels which are already present in the existing data.
 # Note: do not provide N when adding variables to an existing level
diff --git a/docs/reference/index.html b/docs/reference/index.html
index 032d97b..201f069 100644
--- a/docs/reference/index.html
+++ b/docs/reference/index.html
@@ -141,11 +141,24 @@ 
    draw_binary_icc 
    
+          
+          
    Draw binary data with fixed intra-cluster correlation.
    
+        
           
           
             
    draw_discrete draw_binary 
    
           
-          
    Draw discrete variables including binary, binomial count, poisson count, ordered, and categorical
    
+          
    Draw discrete variables including binary, binomial count, poisson count,
+ordered, and categorical
    
+        
+          
+          
+            
    draw_normal_icc 
    
+          
+          
    Draw normal data with fixed intra-cluster correlation.
    
         
           
           
diff --git a/docs/reference/level.html b/docs/reference/level.html
index bbb90ab..44fae84 100644
--- a/docs/reference/level.html
+++ b/docs/reference/level.html
@@ -6,7 +6,8 @@
 
 
 
-Deprecated level call function maintained to provide useful error for previous fabricatr code. — level • fabricatr
+fabricatr - Deprecated level call function maintained to provide useful error for
+previous fabricatr code. — level
 
 
 
@@ -47,16 +48,37 @@
         
         
       
-      fabricatr
+      fabricatr
     
    
     
@@ -104,11 +120,13 @@
       
    
   
    
     
    
-    
    Deprecated level call function maintained to provide useful error for previous fabricatr code.
    
+    
    Deprecated level call function maintained to provide useful error for
+previous fabricatr code.
    
     
    
 
     
-    
    Deprecated level call function maintained to provide useful error for previous fabricatr code.
    
+    
    Deprecated level call function maintained to provide useful error for
+previous fabricatr code.
    
     
 
     
    level(N = NULL, ID_label = NULL, ...)
    
@@ -124,8 +142,9 @@ 
    Contents
    
 
    
 
       
    
-      
    
-  
    Developed by Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys.
    
+      
    
+  
    Developed by Graeme Blair, Jasper Cooper, Alexander Coppock, Macartan Humphreys, Aaron Rudkin.
    
+  
    Code is licensed under MIT license.
    
 
    
 
 
    
diff --git a/docs/reference/resample_data.html b/docs/reference/resample_data.html
index 7296d8f..68c14f1 100644
--- a/docs/reference/resample_data.html
+++ b/docs/reference/resample_data.html
@@ -156,17 +156,17 @@ 
    Examp
 
 baseline_survey <- fabricate(N = 5, Y_pre = rnorm(N))
 bootsrapped_data <- resample_data(baseline_survey, N = 10)
-bootsrapped_data
    #>    ID     Y_pre
-#> 1   2 0.3764993
-#> 2   4 1.2412631
-#> 3   5 0.6120909
-#> 4   2 0.3764993
-#> 5   3 1.1387077
-#> 6   2 0.3764993
-#> 7   2 0.3764993
-#> 8   2 0.3764993
-#> 9   1 0.1329921
-#> 10  2 0.3764993
    
+bootsrapped_data
    #>    ID Y_pre
+#> 1   2 -0.38
+#> 2   2 -0.38
+#> 3   5 -0.87
+#> 4   1  1.52
+#> 5   4 -0.55
+#> 6   2 -0.38
+#> 7   5 -0.87
+#> 8   1  1.52
+#> 9   3  1.83
+#> 10  3  1.83
    
 # Resample by a single level of a hierarchical dataset (e.g. resampling clusters of observations)
 # N specifies a number of clusters to return
 
@@ -179,31 +179,31 @@ 
    Examp
 
 cluster_resample <- resample_data(clustered_survey, N = 5, ID_labels = "clusters")
 cluster_resample
    #>    clusters cities population
-#> 1        23     62   687021.1
-#> 2        23     63   424088.8
-#> 3        23     64   573726.1
-#> 4        23     65   280368.0
-#> 5        06     15   329063.3
-#> 6        06     16   896720.6
-#> 7        06     17   608674.7
-#> 8        07     18   651570.0
-#> 9        16     41   307428.9
-#> 10       16     42   881840.8
-#> 11       16     43   859156.0
-#> 12       12     31   431890.9
    
+#> 1        14     36     980082
+#> 2        14     37     673751
+#> 3        14     38     135356
+#> 4        14     39     649016
+#> 5        07     14     667784
+#> 6        07     15     197530
+#> 7        07     16     532894
+#> 8        07     17     131577
+#> 9        16     42     448512
+#> 10       16     43     520782
+#> 11       16     44     385069
+#> 12       08     18     527875
+#> 13       24     66     521043
    
 cluster_resample_2 <- resample_data(clustered_survey, N=c(clusters = 5))
 cluster_resample_2
    #>    clusters cities population
-#> 1        08     19  296534.00
-#> 2        03     08  496384.97
-#> 3        03     09  143638.07
-#> 4        07     18  651569.99
-#> 5        17     44   93556.85
-#> 6        24     66  243048.39
-#> 7        24     67  114924.62
-#> 8        24     68  341910.05
-#> 9        24     69  993462.19
-#> 10       24     70  160493.72
    
-
+#> 1        23     62     306210
+#> 2        23     63     513874
+#> 3        23     64      98509
+#> 4        23     65      52353
+#> 5        03     06     648891
+#> 6        19     48     239037
+#> 7        19     49     739971
+#> 8        15     40     882929
+#> 9        15     41     933767
+#> 10       18     47     391962
    
 # Resample a hierarchical dataset on multiple levels
 
 my_data <-
@@ -215,48 +215,47 @@ 
    Examp
 # Specify the levels you wish to resample one of two ways:
 my_data_2 <- resample_data(my_data, N = c(3, 5), ID_labels = c("cities", "citizens"))
 my_data_2
    #>    cities elevation citizens income
-#> 1       2  1559.491        5   5589
-#> 2       2  1559.491        5   5589
-#> 3       2  1559.491        5   5589
-#> 4       2  1559.491        6   8745
-#> 5       2  1559.491        5   5589
-#> 6       1  1026.625        2   4290
-#> 7       1  1026.625        1   6216
-#> 8       1  1026.625        3   4479
-#> 9       1  1026.625        2   4290
-#> 10      1  1026.625        3   4479
-#> 11      1  1026.625        2   4290
-#> 12      1  1026.625        2   4290
-#> 13      1  1026.625        2   4290
-#> 14      1  1026.625        1   6216
-#> 15      1  1026.625        3   4479
    
+#> 1       1      1701        3  10505
+#> 2       1      1701        3  10505
+#> 3       1      1701        1   8210
+#> 4       1      1701        3  10505
+#> 5       1      1701        1   8210
+#> 6       1      1701        2   8789
+#> 7       1      1701        2   8789
+#> 8       1      1701        2   8789
+#> 9       1      1701        3  10505
+#> 10      1      1701        3  10505
+#> 11      1      1701        3  10505
+#> 12      1      1701        1   8210
+#> 13      1      1701        1   8210
+#> 14      1      1701        2   8789
+#> 15      1      1701        3  10505
    
 my_data_3 <- resample_data(my_data, N = c(cities=3, citizens=5))
 my_data_3
    #>    cities elevation citizens income
-#> 1       2  1559.491        6   8745
-#> 2       2  1559.491        5   5589
-#> 3       2  1559.491        6   8745
-#> 4       2  1559.491        5   5589
-#> 5       2  1559.491        5   5589
-#> 6       2  1559.491        5   5589
-#> 7       2  1559.491        6   8745
-#> 8       2  1559.491        5   5589
-#> 9       2  1559.491        4   7559
-#> 10      2  1559.491        6   8745
-#> 11      2  1559.491        6   8745
-#> 12      2  1559.491        4   7559
-#> 13      2  1559.491        5   5589
-#> 14      2  1559.491        6   8745
-#> 15      2  1559.491        5   5589
    
-
+#> 1       2      1040        4   6786
+#> 2       2      1040        6   5508
+#> 3       2      1040        4   6786
+#> 4       2      1040        5   4613
+#> 5       2      1040        4   6786
+#> 6       2      1040        6   5508
+#> 7       2      1040        4   6786
+#> 8       2      1040        6   5508
+#> 9       2      1040        5   4613
+#> 10      2      1040        6   5508
+#> 11      1      1701        1   8210
+#> 12      1      1701        2   8789
+#> 13      1      1701        1   8210
+#> 14      1      1701        2   8789
+#> 15      1      1701        3  10505
    
 # Transparently pass through all units at a given level
 # This example will resample 2 citizens at each of the cities:
 
 passthrough_resample_data <- resample_data(my_data, N = c(cities=ALL, citizens=2))
 passthrough_resample_data
    #>   cities elevation citizens income
-#> 1      1  1026.625        3   4479
-#> 2      1  1026.625        3   4479
-#> 3      2  1559.491        4   7559
-#> 4      2  1559.491        4   7559
    
+#> 1      1      1701        1   8210
+#> 2      1      1701        1   8210
+#> 3      2      1040        4   6786
+#> 4      2      1040        5   4613
    diff --git a/man/draw_binary_icc.Rd b/man/draw_binary_icc.Rd index d361652..f7f8cb5 100644 --- a/man/draw_binary_icc.Rd +++ b/man/draw_binary_icc.Rd @@ -22,20 +22,11 @@ A vector of binary numbers corresponding to the observations from the supplied cluster IDs. } \description{ -Data is generated according to the following algorithm, where \eqn{i} is -the index of a cluster and \eqn{j} is the index of a unit: \deqn{z_i ~ -Bernoulli(p_i) \cr -y_{ij} ~ Bernoulli(p_{ij}) \cr -u_{ij} ~ Bernoulli(sqrt(\rho)) \cr -x_{ij} = (u_{ij}) z_i + (1 - u_{ij}) y_{ij}} -} -\details{ -This system of equations ensures inter-cluster correlation 0, intra-cluster -correlation in expectation \eqn{\rho}. Algorithm from Hossein, Akhtar. -"ICCbin: An R Package Facilitating Clustered Binary Data Generation, and -Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data". -We rederived the analytical properties of this data and did a simulation -study to confirm that the data generated ensured the ICC we mentioned. +Data is generated to ensure inter-cluster correlation 0, intra-cluster +correlation in expectation \eqn{\rho}. Algorithm taken from Hossein, +Akhtar. "ICCbin: An R Package Facilitating Clustered Binary Data +Generation, and Estimation of Intracluster Correlation Coefficient (ICC) +for Binary Data". } \examples{ cluster_ids = rep(1:5, 10) diff --git a/man/draw_normal_icc.Rd b/man/draw_normal_icc.Rd index 570f55a..990912f 100644 --- a/man/draw_normal_icc.Rd +++ b/man/draw_normal_icc.Rd @@ -25,17 +25,9 @@ A vector of numbers corresponding to the observations from the supplied cluster IDs. } \description{ -Data is generated according to the following algorithm, where \eqn{i} is -the index of a cluster and \eqn{j} is the index of a unit: -} -\details{ -\deqn{\sigma^2_{\alpha}(i) = (\rho \sigma^2_{\epsilon}(i)) / (1 - \rho) \cr -\mu_{ij} ~ \mathcall{N}(\mu_i, \sigma_{\epsilon}(i)) -\alpha_{i} ~ \mathcal{N}(0, \sigma_{\alpha}(i)) \cr -x_{ij} = \mu_{ij} + \alpha_{i}} - -This system of equations ensures inter-cluster correlation 0, intra-cluster -correlation in expectation \eqn{\rho}. Algorithm discussed at +Data is generated to ensure inter-cluster correlation 0, intra-cluster +correlation in expectation \eqn{\rho}{rho}. The data generating process +used in this function is specified at the following URL: \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} } \examples{ diff --git a/vignettes/variable_generation.Rmd b/vignettes/variable_generation.Rmd index f74b597..105d2ee 100644 --- a/vignettes/variable_generation.Rmd +++ b/vignettes/variable_generation.Rmd @@ -180,9 +180,11 @@ If you do not specify a vector of probabilities or a correlation coefficient, th If `sd` is not supplied, each cluster will be assumed to have a within-cluster standard deviation of 1. If `x` is not supplied, each cluster will be assumed to be mean zero. If `rho` is not supplied, it will be set to 0.5. Here, we model student academic performance by cluster: +```{r echo=FALSE} +set.seed(19861108) +``` ```{r echo=TRUE, results="hide"} # 100 students, 10 each in 10 clusters -set.seed(19861108) cluster_ids = rep(1:10, 10) numeric_grade = draw_normal_icc(x = 80, @@ -197,7 +199,7 @@ letter_grade = draw_discrete(x = numeric_grade, mean(numeric_grade) ``` -`r mean(numeric_grade) +`r mean(numeric_grade)` The mean grade matches the population mean. Now let's look at the relationship between cluster and letter grade to observe the cluster pattern: From e473942155ae649fc21ec9de81a2093a875ff5bf Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 15:38:08 -0800 Subject: [PATCH 26/47] Test additions to ICC data and fixed tests for draw_normal_icc --- tests/testthat/test-variables.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 03ece89..5cab35f 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -176,6 +176,8 @@ test_that("Binary ICCs", { expect_error(draw_binary_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) # X doesn't match cluster IDs expect_error(draw_binary_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + # X isn't a vector + expect_error(draw_binary_icc(x = data.frame(j = c(0.5, 0.8), k = c(0.2, 0.4)), cluster_ids = cluster_ids)) # X isn't numeric expect_error(draw_binary_icc(x = "hello", cluster_ids = cluster_ids)) # X isn't a probability @@ -226,18 +228,20 @@ test_that("Normal ICC", { expect_error(draw_normal_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) # X doesn't match cluster IDs expect_error(draw_normal_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + # X isn't a vector + expect_error(draw_normal_icc(x = data.frame(j = c(2, 3), k = c(2, 4)), cluster_ids = cluster_ids)) # X isn't numeric - expect_error(draw_binary_icc(x = "hello", cluster_ids = cluster_ids)) + expect_error(draw_normal_icc(x = "hello", cluster_ids = cluster_ids)) # rho isn't a single number - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) + expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) # rho isn't a probability - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = 2)) + expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = 2)) # rho isn't a number - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = "hello")) + expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = "hello")) # Non-numeric N - expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = "hello")) + expect_error(draw_normal_icc(cluster_ids = cluster_ids, N = "hello")) # N provided but doesn't match - expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = 20)) + expect_error(draw_normal_icc(cluster_ids = cluster_ids, N = 20)) # SD is wrong length expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = c(1, 2))) # SD is non-numeric From 472c508526fdb4320181c72b607dc8a193bee2d9 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 15:55:02 -0800 Subject: [PATCH 27/47] Renamed cluster_ids to clusters and patched up a few more tests --- R/draw_binary_icc.R | 28 ++++++++-------- R/draw_normal_icc.R | 28 ++++++++-------- man/draw_binary_icc.Rd | 12 +++---- man/draw_normal_icc.Rd | 10 +++--- tests/testthat/test-resampling.R | 41 +++++++++++++++++++++- tests/testthat/test-variables.R | 56 +++++++++++++++---------------- vignettes/variable_generation.Rmd | 20 +++++------ 7 files changed, 117 insertions(+), 78 deletions(-) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index 1ceb412..fb0f998 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -8,34 +8,34 @@ #' #' @param x A number or vector of numbers, one probability per cluster. #' @param N (Optional) A number indicating the number of observations to be -#' generated. Must be equal to length(cluster_ids) if provided. -#' @param cluster_ids A vector of factors or items that can be coerced to +#' generated. Must be equal to length(clusters) if provided. +#' @param clusters A vector of factors or items that can be coerced to #' clusters; the length will determine the length of the generated data. #' @param rho A number indicating the desired RCC. #' @return A vector of binary numbers corresponding to the observations from #' the supplied cluster IDs. #' @examples -#' cluster_ids = rep(1:5, 10) -#' draw_binary_icc(cluster_ids = cluster_ids) -#' draw_binary_icc(x = 0.5, cluster_ids = cluster_ids, rho = 0.5) +#' clusters = rep(1:5, 10) +#' draw_binary_icc(clusters = clusters) +#' draw_binary_icc(x = 0.5, clusters = clusters, rho = 0.5) #' #' @importFrom stats rbinom #' #' @export -draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { - # Let's not worry about how cluster_ids are provided +draw_binary_icc = function(x = 0.5, N = NULL, clusters, rho = 0.5) { + # Let's not worry about how clusters are provided tryCatch({ - cluster_ids = as.numeric(as.factor(cluster_ids)) + clusters = as.numeric(as.factor(clusters)) }, error=function(e) { stop("Error coercing cluster IDs to factor levels.") }) - number_of_clusters = length(unique(cluster_ids)) + number_of_clusters = length(unique(clusters)) # Sanity check N if(!is.null(N) && !is.numeric(N)) { stop("If you provide an N, it must be numeric.") } - if(!is.null(N) && N != length(cluster_ids)) { + if(!is.null(N) && N != length(clusters)) { stop("If you provide an N, it must be equal to the length of provided ", "cluster ids") } @@ -71,22 +71,22 @@ draw_binary_icc = function(x = 0.5, N = NULL, cluster_ids, rho = 0.5) { cluster_prob = x } # Individual probabilities: subset operator maps cluster probs to units. - individual_prob = cluster_prob[cluster_ids] + individual_prob = cluster_prob[clusters] # Draw the z_ijs cluster_draw = rbinom(n = number_of_clusters, size = 1, - prob = cluster_prob)[cluster_ids] + prob = cluster_prob)[clusters] # Draw the y_ijs - individual_draw = rbinom(n = length(cluster_ids), + individual_draw = rbinom(n = length(clusters), size = 1, prob = individual_prob) # Draw the u_ijs -- sqrt(rho) because the actual ICC for this data will be # rho^2 -- sqrt(rho^2) = rho, to ensure users can enter in the terms they feel # most comfortable in - switch_draw = rbinom(n = length(cluster_ids), + switch_draw = rbinom(n = length(clusters), size = 1, prob = sqrt(rho)) diff --git a/R/draw_normal_icc.R b/R/draw_normal_icc.R index 0c68813..ee74ba4 100644 --- a/R/draw_normal_icc.R +++ b/R/draw_normal_icc.R @@ -7,8 +7,8 @@ #' #' @param x A number or vector of numbers, one mean per cluster. #' @param N (Optional) A number indicating the number of observations to be -#' generated. Must be equal to length(cluster_ids) if provided. -#' @param cluster_ids A vector of factors or items that can be coerced to +#' generated. Must be equal to length(clusters) if provided. +#' @param clusters A vector of factors or items that can be coerced to #' clusters; the length will determine the length of the generated data. #' @param sd A number or vector of numbers, indicating the standard deviation of #' each cluster's error terms @@ -16,31 +16,31 @@ #' @return A vector of numbers corresponding to the observations from #' the supplied cluster IDs. #' @examples -#' cluster_ids = rep(1:5, 10) -#' draw_normal_icc(cluster_ids = cluster_ids) +#' clusters = rep(1:5, 10) +#' draw_normal_icc(clusters = clusters) #' #' @importFrom stats rnorm #' #' @export draw_normal_icc = function(x = 0, N = NULL, - cluster_ids, + clusters, sd = 1, rho = 0.5) { - # Let's not worry about how cluster_ids are provided + # Let's not worry about how clusters are provided tryCatch({ - cluster_ids = as.numeric(as.factor(cluster_ids)) + clusters = as.numeric(as.factor(clusters)) }, error=function(e) { stop("Error coercing cluster IDs to factor levels.") }) - number_of_clusters = length(unique(cluster_ids)) + number_of_clusters = length(unique(clusters)) # Sanity check N if(!is.null(N) && !is.numeric(N)) { stop("If you provide an N, it must be numeric.") } - if(!is.null(N) && N != length(cluster_ids)) { + if(!is.null(N) && N != length(clusters)) { stop("If you provide an N, it must be equal to the length of provided ", "cluster ids") } @@ -79,7 +79,7 @@ draw_normal_icc = function(x = 0, } # Get number of clusters - number_of_clusters = length(unique(cluster_ids)) + number_of_clusters = length(unique(clusters)) # Convert rho to implied variance per cluster recover_var_cluster = (rho * sd^2) / (1 - rho) @@ -90,16 +90,16 @@ draw_normal_icc = function(x = 0, cluster_mean = x } # Expand to individual means - individual_mean = cluster_mean[cluster_ids] + individual_mean = cluster_mean[clusters] # Cluster level draws, expanded to individual level draws alpha_cluster = rnorm(n=number_of_clusters, mean=0, - sd=sqrt(recover_var_cluster))[cluster_ids] - alpha_individual = alpha_cluster[cluster_ids] + sd=sqrt(recover_var_cluster))[clusters] + alpha_individual = alpha_cluster[clusters] # And error terms, which are truly individual - epsilon_ij = rnorm(length(cluster_ids), 0, sd) + epsilon_ij = rnorm(length(clusters), 0, sd) individual_mean + alpha_individual + epsilon_ij } diff --git a/man/draw_binary_icc.Rd b/man/draw_binary_icc.Rd index f7f8cb5..7b2b519 100644 --- a/man/draw_binary_icc.Rd +++ b/man/draw_binary_icc.Rd @@ -4,15 +4,15 @@ \alias{draw_binary_icc} \title{Draw binary data with fixed intra-cluster correlation.} \usage{ -draw_binary_icc(x = 0.5, N = NULL, cluster_ids, rho = 0.5) +draw_binary_icc(x = 0.5, N = NULL, clusters, rho = 0.5) } \arguments{ \item{x}{A number or vector of numbers, one probability per cluster.} \item{N}{(Optional) A number indicating the number of observations to be -generated. Must be equal to length(cluster_ids) if provided.} +generated. Must be equal to length(clusters) if provided.} -\item{cluster_ids}{A vector of factors or items that can be coerced to +\item{clusters}{A vector of factors or items that can be coerced to clusters; the length will determine the length of the generated data.} \item{rho}{A number indicating the desired RCC.} @@ -29,8 +29,8 @@ Generation, and Estimation of Intracluster Correlation Coefficient (ICC) for Binary Data". } \examples{ -cluster_ids = rep(1:5, 10) -draw_binary_icc(cluster_ids = cluster_ids) -draw_binary_icc(x = 0.5, cluster_ids = cluster_ids, rho = 0.5) +clusters = rep(1:5, 10) +draw_binary_icc(clusters = clusters) +draw_binary_icc(x = 0.5, clusters = clusters, rho = 0.5) } diff --git a/man/draw_normal_icc.Rd b/man/draw_normal_icc.Rd index 990912f..9275822 100644 --- a/man/draw_normal_icc.Rd +++ b/man/draw_normal_icc.Rd @@ -4,15 +4,15 @@ \alias{draw_normal_icc} \title{Draw normal data with fixed intra-cluster correlation.} \usage{ -draw_normal_icc(x = 0, N = NULL, cluster_ids, sd = 1, rho = 0.5) +draw_normal_icc(x = 0, N = NULL, clusters, sd = 1, rho = 0.5) } \arguments{ \item{x}{A number or vector of numbers, one mean per cluster.} \item{N}{(Optional) A number indicating the number of observations to be -generated. Must be equal to length(cluster_ids) if provided.} +generated. Must be equal to length(clusters) if provided.} -\item{cluster_ids}{A vector of factors or items that can be coerced to +\item{clusters}{A vector of factors or items that can be coerced to clusters; the length will determine the length of the generated data.} \item{sd}{A number or vector of numbers, indicating the standard deviation of @@ -31,7 +31,7 @@ used in this function is specified at the following URL: \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} } \examples{ -cluster_ids = rep(1:5, 10) -draw_normal_icc(cluster_ids = cluster_ids) +clusters = rep(1:5, 10) +draw_normal_icc(clusters = clusters) } diff --git a/tests/testthat/test-resampling.R b/tests/testthat/test-resampling.R index 4bbd6d1..b81171d 100644 --- a/tests/testthat/test-resampling.R +++ b/tests/testthat/test-resampling.R @@ -36,8 +36,12 @@ test_that("Error handling of Resampling", { expect_error(resample_data(two_levels, c(100, 10), ID_labels = c("regions"))) # Negative N expect_error(resample_data(two_levels, c(-1), ID_labels = c("regions"))) - # Non-numeric + # Non-numeric N expect_error(resample_data(two_levels, c("hello world"), ID_labels = c("regions"))) + # Non-numeric N in direct call of resample_single_level. This is unlikely to + # arise normally since we don't export it and the code paths that call it have + # separate error handling + expect_error(resample_single_level(two_levels, N=1.5, ID_labels = c("regions"))) }) test_that("Direct resample_single_level", { @@ -55,6 +59,36 @@ test_that("Direct resample_single_level", { expect_error(resample_single_level(two_levels, ID_label="invalid-id", N=10)) }) +test_that("Extremely deep resampling", { + rect_data = fabricate( + N = 10, + xA = 1:10, + xB = 11:20, + xC = 21:30, + xD = 31:40, + xE = 41:50, + xF = 51:60, + xG = 61:70, + xH = 71:80, + xI = 81:90, + xJ = 91:100, + xK = 101:110 + ) + + expect_error(resample_data(rect_data, + N = c(xA = 5, + xB = 3, + xC = 6, + xD = 7, + xE = 3, + xF = 1, + xG = 2, + xH = ALL, + xI = 2, + xJ = 4, + xK = 9))) +}) + test_that("Extremely high volume data creation.", { skip("Slows build substantially.") deep_dive_data = fabricate( @@ -85,6 +119,9 @@ test_that("Providing ID_labels through names of N.", { expect_error(resample_data(two_levels, N=c(invalidid=3, cities=5))) + expect_error(resample_data(two_levels, + N=c(3, cities=5))) + expect_error(resample_data(two_levels, N=c(3, 5))) }) @@ -99,4 +136,6 @@ test_that("Passthrough resampling.", { # Warning when final level resampled has passthrough -- this is superfluous expect_warning(resample_data(two_levels, N=c(regions=ALL, cities=ALL))) + + }) diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 5cab35f..8b5b4e6 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -166,32 +166,32 @@ test_that("Ordered data valid tests", { }) test_that("Binary ICCs", { - cluster_ids = rep(1:5, 10) + clusters = rep(1:5, 10) # Single probability - draw_binary_icc(cluster_ids = cluster_ids) + draw_binary_icc(clusters = clusters) # Probability = length(cluster ids) - draw_binary_icc(x = c(0.3, 0.5, 0.7, 0.8, 0.9), cluster_ids = cluster_ids) + draw_binary_icc(x = c(0.3, 0.5, 0.7, 0.8, 0.9), clusters = clusters) # Invalid cluster IDs - expect_error(draw_binary_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) + expect_error(draw_binary_icc(clusters = data.frame(X=1:10, Y=1:10))) # X doesn't match cluster IDs - expect_error(draw_binary_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + expect_error(draw_binary_icc(x = c(0.5, 0.8), clusters = clusters)) # X isn't a vector - expect_error(draw_binary_icc(x = data.frame(j = c(0.5, 0.8), k = c(0.2, 0.4)), cluster_ids = cluster_ids)) + expect_error(draw_binary_icc(x = data.frame(j = c(0.5, 0.8), k = c(0.2, 0.4)), clusters = clusters)) # X isn't numeric - expect_error(draw_binary_icc(x = "hello", cluster_ids = cluster_ids)) + expect_error(draw_binary_icc(x = "hello", clusters = clusters)) # X isn't a probability - expect_error(draw_binary_icc(x = -0.5, cluster_ids = cluster_ids)) + expect_error(draw_binary_icc(x = -0.5, clusters = clusters)) # rho isn't a single number - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) + expect_error(draw_binary_icc(clusters = clusters, rho = c(0.5, 0.8))) # rho isn't a probability - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = 2)) + expect_error(draw_binary_icc(clusters = clusters, rho = 2)) # rho isn't a number - expect_error(draw_binary_icc(cluster_ids = cluster_ids, rho = "hello")) + expect_error(draw_binary_icc(clusters = clusters, rho = "hello")) # Non-numeric N - expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = "hello")) + expect_error(draw_binary_icc(clusters = clusters, N = "hello")) # N provided but doesn't match - expect_error(draw_binary_icc(cluster_ids = cluster_ids, N = 20)) + expect_error(draw_binary_icc(clusters = clusters, N = 20)) }) test_that("Likert data example", { @@ -218,35 +218,35 @@ test_that("Likert data example", { }) test_that("Normal ICC", { - cluster_ids = rep(1:5, 10) + clusters = rep(1:5, 10) # Single mean - draw_normal_icc(cluster_ids = cluster_ids) + draw_normal_icc(clusters = clusters) # Means = length(cluster ids) - draw_normal_icc(x = c(-1, -0.5, 0, 0.5, 1), cluster_ids = cluster_ids) + draw_normal_icc(x = c(-1, -0.5, 0, 0.5, 1), clusters = clusters) # Invalid cluster IDs - expect_error(draw_normal_icc(cluster_ids = data.frame(X=1:10, Y=1:10))) + expect_error(draw_normal_icc(clusters = data.frame(X=1:10, Y=1:10))) # X doesn't match cluster IDs - expect_error(draw_normal_icc(x = c(0.5, 0.8), cluster_ids = cluster_ids)) + expect_error(draw_normal_icc(x = c(0.5, 0.8), clusters = clusters)) # X isn't a vector - expect_error(draw_normal_icc(x = data.frame(j = c(2, 3), k = c(2, 4)), cluster_ids = cluster_ids)) + expect_error(draw_normal_icc(x = data.frame(j = c(2, 3), k = c(2, 4)), clusters = clusters)) # X isn't numeric - expect_error(draw_normal_icc(x = "hello", cluster_ids = cluster_ids)) + expect_error(draw_normal_icc(x = "hello", clusters = clusters)) # rho isn't a single number - expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = c(0.5, 0.8))) + expect_error(draw_normal_icc(clusters = clusters, rho = c(0.5, 0.8))) # rho isn't a probability - expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = 2)) + expect_error(draw_normal_icc(clusters = clusters, rho = 2)) # rho isn't a number - expect_error(draw_normal_icc(cluster_ids = cluster_ids, rho = "hello")) + expect_error(draw_normal_icc(clusters = clusters, rho = "hello")) # Non-numeric N - expect_error(draw_normal_icc(cluster_ids = cluster_ids, N = "hello")) + expect_error(draw_normal_icc(clusters = clusters, N = "hello")) # N provided but doesn't match - expect_error(draw_normal_icc(cluster_ids = cluster_ids, N = 20)) + expect_error(draw_normal_icc(clusters = clusters, N = 20)) # SD is wrong length - expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = c(1, 2))) + expect_error(draw_normal_icc(clusters = clusters, sd = c(1, 2))) # SD is non-numeric - expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = "hello")) + expect_error(draw_normal_icc(clusters = clusters, sd = "hello")) # SD is not a vector - expect_error(draw_normal_icc(cluster_ids = cluster_ids, sd = data.frame(X=1:10, Y=1:10))) + expect_error(draw_normal_icc(clusters = clusters, sd = data.frame(X=1:5, Y=1:5))) }) diff --git a/vignettes/variable_generation.Rmd b/vignettes/variable_generation.Rmd index 105d2ee..5dcd66e 100644 --- a/vignettes/variable_generation.Rmd +++ b/vignettes/variable_generation.Rmd @@ -134,7 +134,7 @@ We also provide helper functions to generate cluster-correlated random variables ## Binary data with fixed ICCs -`draw_binary_icc()` takes three required arguments: `x`, a probability or vector of probabilities which determine the chance a given observation will be a 1; `cluster_ids`, a map of units to clusters (required to generate the correlation structure); and `rho`, the fixed intra-cluster correlation (from 0 to 1). Users may optionally specify `N`; if it is not specified, `draw_binary_icc()` will determine it based on the length of the `cluster_ids` vector. +`draw_binary_icc()` takes three required arguments: `x`, a probability or vector of probabilities which determine the chance a given observation will be a 1; `clusters`, a map of units to clusters (required to generate the correlation structure); and `rho`, the fixed intra-cluster correlation (from 0 to 1). Users may optionally specify `N`; if it is not specified, `draw_binary_icc()` will determine it based on the length of the `clusters` vector. Consider the following example, which models whether individuals smoke: @@ -143,12 +143,12 @@ set.seed(19861108) ``` ```{r echo=TRUE, results="hide"} # 100 individual population, 10 each in each of 10 clusters -cluster_ids = rep(1:10, 10) +clusters = rep(1:10, 10) # Individuals have a 20% chance of smoking, but clusters are highly correlated # in their tendency to smoke smoker = draw_binary_icc(x = 0.2, - cluster_ids = cluster_ids, + clusters = clusters, rho = 0.7) # Observe distribution of smokers and non-smokers @@ -161,10 +161,10 @@ knitr::kable(as.matrix(t(table(smoker)))) We see that approximately 20% of the population smokes, in line with our specification, but what patterns of heterogeneity do we see by cluster? ```{r echo=TRUE, results="hide"} -table(cluster_ids, smoker) +table(clusters, smoker) ``` ```{r echo=FALSE} -knitr::kable(table(cluster_ids, smoker)) +knitr::kable(table(clusters, smoker)) ``` We observe that 7 clusters have no smokers at all, two clusters are overwhelming smokers, and one cluster is overwhelmingly non-smokers. @@ -175,7 +175,7 @@ If you do not specify a vector of probabilities or a correlation coefficient, th ## Normal data with fixed ICCs -`draw_normal_icc()` takes four required arguments: `x`, a mean or vector of means, one for each cluster; `cluster_ids`, a map of units to clusters (required to generate the correlation structure); `rho`, the fixed intra-cluster correlation coefficient; and `sd`, a standard deviation or vector of standard deviations, one for each cluster. Users can optionally specify `N`, a number of units, but if it is not supplied `draw_normal_icc()` will determine it based on the length of the `cluster_ids` vector. +`draw_normal_icc()` takes four required arguments: `x`, a mean or vector of means, one for each cluster; `clusters`, a map of units to clusters (required to generate the correlation structure); `rho`, the fixed intra-cluster correlation coefficient; and `sd`, a standard deviation or vector of standard deviations, one for each cluster. Users can optionally specify `N`, a number of units, but if it is not supplied `draw_normal_icc()` will determine it based on the length of the `clusters` vector. If `sd` is not supplied, each cluster will be assumed to have a within-cluster standard deviation of 1. If `x` is not supplied, each cluster will be assumed to be mean zero. If `rho` is not supplied, it will be set to 0.5. @@ -185,10 +185,10 @@ set.seed(19861108) ``` ```{r echo=TRUE, results="hide"} # 100 students, 10 each in 10 clusters -cluster_ids = rep(1:10, 10) +clusters = rep(1:10, 10) numeric_grade = draw_normal_icc(x = 80, - cluster_ids = cluster_ids, + clusters = clusters, rho = 0.5, sd = 15) @@ -204,10 +204,10 @@ mean(numeric_grade) The mean grade matches the population mean. Now let's look at the relationship between cluster and letter grade to observe the cluster pattern: ```{r echo=TRUE, results="hide"} -table(letter_grade, cluster_ids) +table(letter_grade, clusters) ``` ```{r echo=FALSE} -knitr::kable(table(cluster_ids, letter_grade)) +knitr::kable(table(clusters, letter_grade)) ``` It is obvious upon inspection that some clusters are higher performing than others despite having identical cluster means in expectation. From ce912cafab3c3150ef2fb85ff12374480dccb524 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 16:30:33 -0800 Subject: [PATCH 28/47] Fixed bug in error handling in handle_n and added more tests. --- R/helper_functions.R | 6 ++++- tests/testthat/test-helper-functions.R | 35 ++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/test-helper-functions.R diff --git a/R/helper_functions.R b/R/helper_functions.R index 4014675..ee98913 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -204,7 +204,7 @@ handle_n = function(N, add_level=TRUE, working_environment=NULL, } # If any N is non-numeric or non-integer or negative or zero, fail. - if(is.numeric(N) & any(N%%1 | N<=0)) { + if(all(is.numeric(N)) && any(N%%1 | N<=0)) { stop( "Provided N must be a single positive integer." ) @@ -218,6 +218,10 @@ handle_n = function(N, add_level=TRUE, working_environment=NULL, stop( "Provided values for N must be integer numbers" ) + }, warning=function(e) { + stop( + "Provided values for N must be integer numbers" + ) }) } } diff --git a/tests/testthat/test-helper-functions.R b/tests/testthat/test-helper-functions.R new file mode 100644 index 0000000..a6682c4 --- /dev/null +++ b/tests/testthat/test-helper-functions.R @@ -0,0 +1,35 @@ +context("Helper functions") + +test_that("Error handlers", { + # User passed in data that isn't a data frame (no dimensionality) + expect_error(handle_data(1:10)) + + # Data has dimensionality + #df = handle_data(matrix(1:9, nrow=3, ncol=3)) +}) + +test_that("Error handlers: handle_id", { + # Cartoon scenario where we're asked to generate an ID + # but our 6 default variables are all taken + data = data.frame(ID = 1:10, + fab_ID_1 = 11:20, + fab_ID_2 = 21:30, + fab_ID_3 = 31:40, + fab_ID_4 = 41:50, + fab_ID_5 = 51:60) + expect_error(handle_id(NULL, data)) + + # And verify that the waterfall works as expected + ID = handle_id(NULL, data[, 1:2]) + expect_equal(ID, "fab_ID_2") +}) + +test_that("Error handlers: handle_n", { + # Passed closure as N, didn't evaluate it + expect_error(handle_n(N = function(x) { x*2 })) + + func = function(x) { x*2 } + handle_n(N = func(4)) + + expect_error(handle_n(N = "hello")) +}) From 1521ba7266b69b6561228d20ce0e3f87f54d6ea3 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 16:50:16 -0800 Subject: [PATCH 29/47] More test coverage. --- R/draw_binary_icc.R | 1 + R/resample_data.R | 6 +++++- tests/testthat/test-resampling.R | 4 +++- tests/testthat/test-variables.R | 7 ++++++- 4 files changed, 15 insertions(+), 3 deletions(-) diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index fb0f998..3033e4f 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -39,6 +39,7 @@ draw_binary_icc = function(x = 0.5, N = NULL, clusters, rho = 0.5) { stop("If you provide an N, it must be equal to the length of provided ", "cluster ids") } + # Sanity check x if(!length(x) %in% c(1, number_of_clusters)) { stop("x must be either one number or one number per cluster.") diff --git a/R/resample_data.R b/R/resample_data.R index 755ae32..cebf19b 100644 --- a/R/resample_data.R +++ b/R/resample_data.R @@ -200,10 +200,14 @@ resample_single_level <- function(data, ID_label = NULL, N) { stop("ID label provided (", ID_label, ") is not a column in the data being resampled.") } - if(length(N) > 1 | !is.numeric(N) | N%%1 | (N<=0 & N!=ALL)) { + if(length(N) > 1) { stop("For a single resample level, N should be a single positive integer. N was ", N) } + if(!is.numeric(N) || (N%%1 | (N<=0 & N!=ALL))) { + stop("For a single resample level, N should be a positive integer. N was ", N) + } + # Split data by cluster ID, storing all row indices associated with that cluster ID # nrow passes through transparently to dim, so this is slightly faster indices_split = split(seq_len(dim(data)[1]), data[[ID_label]]) diff --git a/tests/testthat/test-resampling.R b/tests/testthat/test-resampling.R index b81171d..0b69fba 100644 --- a/tests/testthat/test-resampling.R +++ b/tests/testthat/test-resampling.R @@ -41,7 +41,9 @@ test_that("Error handling of Resampling", { # Non-numeric N in direct call of resample_single_level. This is unlikely to # arise normally since we don't export it and the code paths that call it have # separate error handling - expect_error(resample_single_level(two_levels, N=1.5, ID_labels = c("regions"))) + expect_error(resample_single_level(two_levels, N=c(1, 2), ID_label = "regions")) + expect_error(resample_single_level(two_levels, N=1.5, ID_label = "regions")) + expect_error(resample_single_level(two_levels, N="hello", ID_label = "regions")) }) test_that("Direct resample_single_level", { diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 8b5b4e6..6503a08 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -177,7 +177,12 @@ test_that("Binary ICCs", { # X doesn't match cluster IDs expect_error(draw_binary_icc(x = c(0.5, 0.8), clusters = clusters)) # X isn't a vector - expect_error(draw_binary_icc(x = data.frame(j = c(0.5, 0.8), k = c(0.2, 0.4)), clusters = clusters)) + expect_error(draw_binary_icc(x = data.frame(j = c(0.1, 0.2), + k = c(0.2, 0.4), + m = c(0.3, 0.6), + o = c(0.4, 0.8), + p = c(0.5, 1.0)), + clusters = clusters)) # X isn't numeric expect_error(draw_binary_icc(x = "hello", clusters = clusters)) # X isn't a probability From 49782c1b99bf33495afb5d03722cf052c6c1351c Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 16:56:26 -0800 Subject: [PATCH 30/47] Remaining test coverage for draw_normal_icc --- tests/testthat/test-variables.R | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-variables.R b/tests/testthat/test-variables.R index 6503a08..f31d435 100644 --- a/tests/testthat/test-variables.R +++ b/tests/testthat/test-variables.R @@ -234,7 +234,12 @@ test_that("Normal ICC", { # X doesn't match cluster IDs expect_error(draw_normal_icc(x = c(0.5, 0.8), clusters = clusters)) # X isn't a vector - expect_error(draw_normal_icc(x = data.frame(j = c(2, 3), k = c(2, 4)), clusters = clusters)) + expect_error(draw_normal_icc(x = data.frame(j = c(0.1, 0.2), + k = c(0.2, 0.4), + m = c(0.3, 0.6), + o = c(0.4, 0.8), + p = c(0.5, 1.0)), + clusters = clusters)) # X isn't numeric expect_error(draw_normal_icc(x = "hello", clusters = clusters)) # rho isn't a single number @@ -252,6 +257,10 @@ test_that("Normal ICC", { # SD is non-numeric expect_error(draw_normal_icc(clusters = clusters, sd = "hello")) # SD is not a vector - expect_error(draw_normal_icc(clusters = clusters, sd = data.frame(X=1:5, Y=1:5))) - + expect_error(draw_normal_icc(sd = data.frame(j = c(0.1, 0.2), + k = c(0.2, 0.4), + m = c(0.3, 0.6), + o = c(0.4, 0.8), + p = c(0.5, 1.0)), + clusters = clusters)) }) From 288361945a789bcdf077b628f25e2d29e61458c9 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 17:26:13 -0800 Subject: [PATCH 31/47] Test coverage for helper functions including symbol lookahead and get unique variables by level. --- tests/testthat/test-helper-functions.R | 46 ++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-helper-functions.R b/tests/testthat/test-helper-functions.R index a6682c4..fc7ba96 100644 --- a/tests/testthat/test-helper-functions.R +++ b/tests/testthat/test-helper-functions.R @@ -1,11 +1,26 @@ context("Helper functions") -test_that("Error handlers", { +test_that("Error handlers: handle_data", { # User passed in data that isn't a data frame (no dimensionality) expect_error(handle_data(1:10)) - # Data has dimensionality - #df = handle_data(matrix(1:9, nrow=3, ncol=3)) + # It's not a data frame and the user didn't specify the argument name + # this is a weird case involving arguments being interpreted by position + # from fabricate and weird stuff flipping through to handle_data + expect_error(handle_data(matrix(1:9, nrow=3, ncol=3))) + + # Test coercion of dimensional but non-df objects -- a matrix is most common + # example -- this is also a working use case. + handle_data(data = matrix(1:9, nrow=3, ncol=3)) + + # Really stupid test -- object has dimensionality but won't coerce to df + # this should almost never happen except for very poorly behaved objects + X = 1:10 + Y = X*2 + rnorm(10) + df = data.frame(X = X, Y=Y) + model = lm(Y ~ X, df) + dim(model) = c(3, 4) # This will break the model object, but fine for test + expect_error(handle_data(data = model)) }) test_that("Error handlers: handle_id", { @@ -33,3 +48,28 @@ test_that("Error handlers: handle_n", { expect_error(handle_n(N = "hello")) }) + +test_that("Error handlers: check_rectangular", { + # Everything is either length N or length 1 + test = list(X = 1:10, + Y = 11:20, + Z = 4) + N = 10 + check_rectangular(test, N) + + test[["K"]] = 5:7 + expect_error(check_rectangular(test, N)) +}) + +test_that("get_unique_variables_by_level", { + df = datasets::ChickWeight + expect_equal(length(get_unique_variables_by_level(df, "Diet")), 0) + + df$DietVar = as.numeric(df$Diet) * 3 + expect_equal(length(get_unique_variables_by_level(df, "Diet")), 1) +}) + +test_that("Advance lookahead symbol evaluator", { + my_quos = rlang::quos(J = KK * LMNOP * max(F, G, H, 20, (((K))))) + expect_equal(length(get_symbols_from_quosure(my_quos)[[1]]), 6) +}) From 284980d94992b2b04875f4ff4d90b198348f2320 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 18:26:22 -0800 Subject: [PATCH 32/47] Test coverage for main fabricate and level methods. --- R/fabricate.R | 59 ++++++++++--------- R/helper_functions.R | 8 ++- man/fabricate.Rd | 12 ++-- tests/testthat/test-fabrication.R | 24 ++++++-- tests/testthat/test-helper-functions.R | 5 ++ .../testthat/test-start-with-existing-data.R | 7 +++ 6 files changed, 74 insertions(+), 41 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 7a73915..ea33f34 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -70,7 +70,7 @@ #' is_lang get_expr #' #' @export -fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) +fabricate <- function(data = NULL, ..., N = NULL, ID_label = NULL) { # Store all data generation arguments in a quosure for future evaluation # A quosure contains unevaluated formulae and function calls. @@ -90,10 +90,10 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) (!is.null(N) & !missing(N)), all_levels) != 1) { stop( - "Fabricate can be called in one of three ways: \n - 1) Provide one or more level calls, with or without existing data \n - 2) Provide existing data and add new variables without adding a level \n - 3) Provide an \"N\" and add new variables" + "Fabricate can be called in one of three ways: \n", + "1) Provide one or more level calls, with or without existing data \n", + "2) Provide existing data and add new variables without adding a level \n", + "3) Provide an \"N\" and add new variables" ) } @@ -153,11 +153,7 @@ fabricate <- function(data = NULL, N = NULL, ID_label = NULL, ...) } # Confirm data can be a data frame - tryCatch({ - data = data.frame(data) - }, error=function(e) { - stop("User supplied data must be convertible into a data frame.") - }) + data = handle_data(data) # Single level -- maybe the user provided an ID_label, maybe they didn't. # Sanity check and/or construct an ID label for the new data. @@ -409,13 +405,14 @@ nest_level = function(N = NULL, ID_label = NULL, # If there's a non-even multiple that's an indication something is badly # wrong with the data here. if((N/inner_N) %% 1) { - stop("Variable ", i, " has inappropriate length for nested level ", - ID_label, ". \n", - " If the nested level has a fixed length, please generate data of - the length of either the inner level or the entire data frame. - If the nested level has a variable length, please generate data - equal to the length of the entire data frame using the N - argument.") + stop( + "Variable ", i, " has inappropriate length for nested level ", + ID_label, ". \n", + " If the nested level has a fixed length, please generate data of ", + "the length of either the inner level or the entire data frame. ", + "If the nested level has a variable length, please generate data ", + "equal to the length of the entire data frame using the N argument." + ) } # Do the repetition working_data_list[[i]] = rep(working_data_list[[i]], (N/inner_N)) @@ -466,8 +463,8 @@ modify_level = function(N = NULL, # Need to supply an ID_label, otherwise we have no idea what to modify. # You actually can, though! It'd just be per unit if(is.null(ID_label)) { - stop("You can't modify a level without a known level ID variable. If you - are adding nested data, please use add_level") + stop("You can't modify a level without a known level ID variable. If you", + "are adding nested data, please use add_level") } # First, establish that if we have no working data frame, we can't continue @@ -481,9 +478,11 @@ modify_level = function(N = NULL, stop("User supplied data must be convertible into a data frame.") }) } else { - stop("You can't modify a level if there is no working data frame to - modify: you must either load pre-existing data or generate some data - before modifying.") + stop( + "You can't modify a level if there is no working data frame to ", + "modify: you must either load pre-existing data or generate some data ", + "before modifying." + ) } } @@ -559,13 +558,15 @@ modify_level = function(N = NULL, # Error if we try to write using a variable that's not unique to the level. if(length(level_unique_variables) != length(write_variables) & length(write_variables) != 0) { - stop("Your modify_level command attempts to generate a new variable at the - level \"", ID_label, "\" - but requires reading from the existing variable(s) [", - paste(setdiff(write_variables, level_unique_variables), collapse=", "), - "] which are not defined at the level \"", ID_label, - "\"\n\n To prevent this error, you may modify the data at the level of - interest, or change the definition of your new variables.") + stop( + "Your modify_level command attempts to generate a new variable at the level \"", + ID_label, + "\" but requires reading from the existing variable(s) [", + paste(setdiff(write_variables, level_unique_variables), collapse=", "), + "] which are not defined at the level \"", ID_label, "\"\n\n", + "To prevent this error, you may modify the data at the level of interest, ", + "or change the definition of your new variables." + ) } # Our subset needs these columns -- the level variable, all the unique diff --git a/R/helper_functions.R b/R/helper_functions.R index ee98913..57f63c2 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -242,9 +242,13 @@ handle_data = function(data) { # User provided data, but it's not a data frame, and they didn't provide it explicitly, # so this is probably a mess-up with an implicit argument - if(!"data" %in% names(sys.call())) { + if(!"data" %in% names(sys.call()) && + !"data" %in% names(sys.call(-1))) { stop( - "The data argument must be a data object. The argument call, ", deparse(substitute(data)), ", was not a data object (e.g. a data.frame, tibble, sf object, or convertible matrix)." + "The data argument must be a data object. The argument call, ", + deparse(substitute(data)), + ", was not a data object (e.g. a data.frame, tibble, sf object, or ", + "convertible matrix)." ) } diff --git a/man/fabricate.Rd b/man/fabricate.Rd index 47a5928..c4599bc 100644 --- a/man/fabricate.Rd +++ b/man/fabricate.Rd @@ -6,7 +6,7 @@ \alias{modify_level} \title{Fabricate data} \usage{ -fabricate(data = NULL, N = NULL, ID_label = NULL, ...) +fabricate(data = NULL, ..., N = NULL, ID_label = NULL) add_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments = quos(...), new_hierarchy = FALSE) @@ -20,6 +20,11 @@ fabrication, i.e. you can add variables to existing data. Provide either \code{N} or \code{data} (\code{N} is the number of rows of the data if \code{data} is provided).} +\item{...}{Variable or level-generating arguments, such as +\code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass +\code{add_level()} or \code{modify_level()} arguments, which define a level +of a multi-level dataset. See examples.} + \item{N}{(optional) number of units to draw. If provided as \code{fabricate(N = 5)}, this determines the number of units in the single-level data. If provided in \code{add_level}, i.e. @@ -28,11 +33,6 @@ of units in a specific level of a hierarchical dataset.} \item{ID_label}{(optional) variable name for ID variable, i.e. citizen_ID} -\item{...}{Variable or level-generating arguments, such as -\code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass -\code{add_level()} or \code{modify_level()} arguments, which define a level -of a multi-level dataset. See examples.} - \item{working_environment_}{Internal argument, not intended for end-user use.} \item{data_arguments}{Internal argument, not intended for end-user use.} diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index bd2468d..97f49c0 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -42,7 +42,10 @@ test_that("Fabricate", { ) # User provides matrix, test conversion. - fabricate(data = matrix(rep(c(1, 2, 3), 3), byrow=TRUE, ncol=3, nrow=3)) + fabricate(data = matrix(rep(c(1, 2, 3), 3), + byrow=TRUE, + ncol=3, + nrow=3)) }) test_that("choose N of a level based on data from higher levels", { @@ -57,6 +60,15 @@ test_that("choose N of a level based on data from higher levels", { test_that("trigger errors", { + # User didn't provide a name for a level, and let's make sure that we also + # didn't interpret the unnamed level as any of the special arguments contextually + expect_error(fabricate( + data = NULL, + N = NULL, + ID_label = NULL, + countries = add_level(N = 10), + add_level(N = 5, population = rnorm(N)))) + expect_error(fabricate( regions = add_level(), cities = add_level(N = sample(1:5), subways = rnorm(N, mean = 5)) @@ -106,9 +118,8 @@ test_that("trigger errors", { # Negative N expect_error(fabricate(N = -1, test1=runif(10))) - # Sending a scalar will coerce to a data.frame - fabricate(data = c(5)) - + # Scalar as data + expect_error(fabricate(data = c(5))) # Vector as ID_label expect_error(fabricate(N=10, test1=rnorm(10), test2=rpois(10, lambda=2), ID_label=c("invalid", "id"))) # Matrix as ID_label @@ -124,9 +135,14 @@ test_that("trigger errors", { # Unusual test with implicit data argument expect_error(fabricate(N=10, 1:N)) + }) test_that("unusual pass of add_level call to single level generation as data matrix", { expect_error(fabricate(add_level(N = 5, gdp = rnorm(N)))) }) + +test_that("modify_level call when you probably meant add_level", { + expect_error(fabricate(countries = modify_level(N = 10, new_var = rnorm(N)))) +}) diff --git a/tests/testthat/test-helper-functions.R b/tests/testthat/test-helper-functions.R index fc7ba96..56f5c74 100644 --- a/tests/testthat/test-helper-functions.R +++ b/tests/testthat/test-helper-functions.R @@ -43,10 +43,15 @@ test_that("Error handlers: handle_n", { # Passed closure as N, didn't evaluate it expect_error(handle_n(N = function(x) { x*2 })) + # Passed closure as N, did evaluate it func = function(x) { x*2 } handle_n(N = func(4)) + # Non-numeric type where coercion gives a warning expect_error(handle_n(N = "hello")) + + # Non-numeric type where coercion gives an explicit error + expect_error(handle_n(N = list(Z = Y ~ X))) }) test_that("Error handlers: check_rectangular", { diff --git a/tests/testthat/test-start-with-existing-data.R b/tests/testthat/test-start-with-existing-data.R index 2353b34..350d18a 100644 --- a/tests/testthat/test-start-with-existing-data.R +++ b/tests/testthat/test-start-with-existing-data.R @@ -47,3 +47,10 @@ test_that("Start with existing multi-level data and add variables",{ }) + +test_that("Modify var at wrong level", { + df = fabricate(country = add_level(N = 50, population = runif(N, 10000, 20000)), + state = add_level(N = 10, latitude = runif(N, 40, 50)), + town = add_level(N = 5, stop_lights = draw_binary(x = 0.7, N=N))) + expect_error(fabricate(df, state = modify_level(crime = 0.5 + stop_lights + latitude))) +}) From 385883834bc49648ece1f4e4cab6ef31ea25eac9 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 18:37:34 -0800 Subject: [PATCH 33/47] Moved data frame sanity check for imported data into fabricate call rather than level calls. --- R/fabricate.R | 36 +++++++++++++----------------------- 1 file changed, 13 insertions(+), 23 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index ea33f34..5b0b0e8 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -110,6 +110,8 @@ fabricate <- function(data = NULL, ..., N = NULL, ID_label = NULL) # User provided data, if any, should be preloaded into working environment if(!is.null(data) & !missing(data)) { + # Ensure data is sane. + data = handle_data(data) working_environment$imported_data_ = data } @@ -241,14 +243,11 @@ add_level = function(N = NULL, ID_label = NULL, # When this is done, trash the imported data, because the working data frame # contains it. if("imported_data_" %in% names(working_environment_)) { - tryCatch({ - num_obs_imported = nrow(working_environment_$imported_data_) - working_data_list = as.list(working_environment_$imported_data_) - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL - }, error = function(e) { - stop("User supplied data must be convertible into a data frame.") - }) + num_obs_imported = nrow(working_environment_$imported_data_) + working_data_list = as.list(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL + # User didn't specify an N, so get it from the current data. if(is.null(N)) { N = num_obs_imported @@ -332,14 +331,9 @@ nest_level = function(N = NULL, ID_label = NULL, # Check to make sure we have a data frame to nest on. if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - tryCatch({ - working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL - }, error = function(e) { - stop("User supplied data must be convertible into a data frame.") - }) - + working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL } else { stop("You can't nest a level if there is no level to nest inside") } @@ -470,13 +464,9 @@ modify_level = function(N = NULL, # First, establish that if we have no working data frame, we can't continue if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { - tryCatch({ - working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) - working_environment_$variable_names_ = names(working_environment_$imported_data_) - working_environment_$imported_data_ = NULL - }, error=function(e) { - stop("User supplied data must be convertible into a data frame.") - }) + working_environment_$data_frame_output_ = data.frame(working_environment_$imported_data_) + working_environment_$variable_names_ = names(working_environment_$imported_data_) + working_environment_$imported_data_ = NULL } else { stop( "You can't modify a level if there is no working data frame to ", From a91e053edc79d232172e8b286c20d7d71cf61ad7 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 19:05:49 -0800 Subject: [PATCH 34/47] Removed an error handler code could never reach and added a few minor tests. --- R/fabricate.R | 17 ++--------------- tests/testthat/test-fabrication.R | 27 +++++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 5b0b0e8..3372da3 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -360,8 +360,8 @@ nest_level = function(N = NULL, ID_label = NULL, else rep_indices = rep(indices, times=N) # Update N to the new length. - inner_N = N - N = length(rep_indices) + inner_N = N # Length specified for this level + N = length(rep_indices) # Length of overall data frame # Expand the data frame by duplicating the indices and then coerce the data # frame to a list -- we do this to basically make variables accessible in the @@ -396,19 +396,6 @@ nest_level = function(N = NULL, ID_label = NULL, # We need to expand this to each setting of the outer level. # Only evaluate if inner_N is a single number if(length(inner_N) == 1 && length(working_data_list[[i]]) == inner_N) { - # If there's a non-even multiple that's an indication something is badly - # wrong with the data here. - if((N/inner_N) %% 1) { - stop( - "Variable ", i, " has inappropriate length for nested level ", - ID_label, ". \n", - " If the nested level has a fixed length, please generate data of ", - "the length of either the inner level or the entire data frame. ", - "If the nested level has a variable length, please generate data ", - "equal to the length of the entire data frame using the N argument." - ) - } - # Do the repetition working_data_list[[i]] = rep(working_data_list[[i]], (N/inner_N)) } diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index 97f49c0..60d463e 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -58,6 +58,20 @@ test_that("choose N of a level based on data from higher levels", { ) }) +test_that("Import data, single level var modification, with/without ID", { + expect_equal( + ncol(fabricate(datasets::BOD, dd = demand * 2, ID_label="Time")), + 3) + + expect_equal( + ncol(fabricate(datasets::BOD, dd = demand * 2)), + 4) + + expect_equal( + ncol(fabricate(datasets::BOD, dd = demand * 2, ID_label="Jello")), + 4) +}) + test_that("trigger errors", { # User didn't provide a name for a level, and let's make sure that we also @@ -146,3 +160,16 @@ test_that("unusual pass of add_level call to single level generation as data mat test_that("modify_level call when you probably meant add_level", { expect_error(fabricate(countries = modify_level(N = 10, new_var = rnorm(N)))) }) + +test_that("modify_level call where you don't specify which level", { + expect_error(fabricate(countries = add_level(N=20), + modify_level(ID_new = as.numeric(ID) * 2))) +}) + +test_that("nest_level call when there was no data to nest", { + # No import data, nest level + expect_error(fabricate(countries = nest_level(N = 10, new_var = rnorm(N)))) + + # Import data, should be able to nest level + fabricate(datsets::BOD, units = nest_level(N = 2, dd = demand * 2)) +}) From bd28cc239aa09af3cabd1f1693a3fc33b0366d76 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Fri, 1 Dec 2017 19:19:35 -0800 Subject: [PATCH 35/47] Forgot to commit one character typo fix, broke build. --- tests/testthat/test-fabrication.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index 60d463e..64bb38c 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -171,5 +171,5 @@ test_that("nest_level call when there was no data to nest", { expect_error(fabricate(countries = nest_level(N = 10, new_var = rnorm(N)))) # Import data, should be able to nest level - fabricate(datsets::BOD, units = nest_level(N = 2, dd = demand * 2)) + fabricate(datasets::BOD, units = nest_level(N = 2, dd = demand * 2)) }) From 351fa3ba576ebdbc723f722ab2f9cab4977efae1 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Mon, 4 Dec 2017 10:53:11 -0800 Subject: [PATCH 36/47] Removed superfluous data checking code in nest, modify, and add --- R/fabricate.R | 35 ++--------------------------------- 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index 3372da3..3a35a88 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -191,18 +191,13 @@ add_level = function(N = NULL, ID_label = NULL, new_hierarchy = FALSE) { # Copy the working environment out of the data_arguments quosure and into - # the root. + # the root. This happens when we have a single non-nested fabricate call + # and we don't want to double-quosure the working environmented. if("working_environment_" %in% names(data_arguments)) { working_environment_ = data_arguments[["working_environment_"]] data_arguments[["working_environment_"]] = NULL } - # Copy ID_label out of the data_arguments quosure and into the root - if("ID_label" %in% names(data_arguments)) { - ID_label = data_arguments[["ID_label_"]] - data_arguments[["ID_label"]] = NULL - } - # Pass-through mapper to nest_level. # This needs to be done after we read the working environment and # before we check N or do the shelving procedure. @@ -315,19 +310,6 @@ nest_level = function(N = NULL, ID_label = NULL, ..., data_arguments=quos(...)) { - # Copy the working environment out of the data_arguments quosure and into the - # root. - if("working_environment_" %in% names(data_arguments)) { - working_environment_ = data_arguments[["working_environment_"]] - data_arguments[["working_environment_"]] = NULL - } - - # Copy ID_label out of the data_arguments quosure and into the root - if("ID_label" %in% names(data_arguments)) { - ID_label = data_arguments[["ID_label_"]] - data_arguments[["ID_label"]] = NULL - } - # Check to make sure we have a data frame to nest on. if(is.null(dim(working_environment_$data_frame_output_))) { if("imported_data_" %in% names(working_environment_)) { @@ -428,19 +410,6 @@ modify_level = function(N = NULL, ..., data_arguments=quos(...)) { - # Copy the working environment out of the data_arguments quosure and into - # the root. - if("working_environment_" %in% names(data_arguments)) { - working_environment_ = data_arguments[["working_environment_"]] - data_arguments[["working_environment_"]] = NULL - } - - # Copy ID_label out of the data_arguments quosure and into the root - if("ID_label" %in% names(data_arguments)) { - ID_label = data_arguments[["ID_label_"]] - data_arguments[["ID_label"]] = NULL - } - # Need to supply an ID_label, otherwise we have no idea what to modify. # You actually can, though! It'd just be per unit if(is.null(ID_label)) { From 593dedc18d4bd4e9e044a5a24e44c062942e97fa Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Thu, 14 Dec 2017 15:16:47 -0800 Subject: [PATCH 37/47] cross_classify implementation first pass. This build will generate a warning due to a documentation issue. --- DESCRIPTION | 5 +- NAMESPACE | 2 + R/cross_classify_helpers.R | 134 +++++++++++++++++++++++++++++++++++++ R/fabricate.R | 104 +++++++++++++++++++++++++++- R/helper_functions.R | 3 +- 5 files changed, 243 insertions(+), 5 deletions(-) create mode 100644 R/cross_classify_helpers.R diff --git a/DESCRIPTION b/DESCRIPTION index f31b42a..d75ba30 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,6 +22,7 @@ Suggests: dplyr, knitr, rmarkdown, - data.table -FasterWith: data.table + data.table, + mvnfast +FasterWith: data.table, mvnfast VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index ddb4f09..ec10039 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,6 +2,7 @@ export(ALL) export(add_level) +export(cross_classify) export(draw_binary) export(draw_binary_icc) export(draw_discrete) @@ -18,6 +19,7 @@ importFrom(rlang,lang_modify) importFrom(rlang,lang_name) importFrom(rlang,quo) importFrom(rlang,quo_name) +importFrom(rlang,quo_text) importFrom(rlang,quos) importFrom(stats,median) importFrom(stats,pnorm) diff --git a/R/cross_classify_helpers.R b/R/cross_classify_helpers.R new file mode 100644 index 0000000..b78ae66 --- /dev/null +++ b/R/cross_classify_helpers.R @@ -0,0 +1,134 @@ +join_dfs = function(dfs, variables, N, sigma=NULL, rho=0) { + # Error handling + if(is.data.frame(dfs)) { + stop("You need at least two data frames.") + } + if(length(dfs) != length(variables)) { + stop("You must define which variables to join on.") + } + if(length(variables) < 2) { + stop("You must define at least two variables to join on.") + } + + # Create the data list -- the subset from the dfs of the variables we're + # joining on -- for each df in dfs, map it to a variable. Subset the df to + # that variable. Unlist and unname, creating a vector. Plonk that in a + # data_list + data_list = Map(function(x, y) { + unname(unlist(x[y])) + }, dfs, variables) + + # Do the joint draw + result = joint_draw_ecdf(data_list=data_list, + N=N, + sigma=sigma, + rho=rho) + + # result now contains a matrix of indices. Each column of this matrix is + # the indices for each df of dfs. Subset by row the df. This will return + # a list of new dfs. We need to cbind these dfs to make the merged data. + merged_data = do.call("cbind", + Map(function(df, indices) { df[indices, ] }, + dfs, + result)) + + # Cleanup: remove row names + rownames(merged_data) = NULL + # Re-write the column names to be the original column names from the original + # dfs. + colnames(merged_data) = unname(unlist(lapply(dfs, colnames))) + + merged_data +} + +joint_draw_ecdf = function (data_list, N, ndim=length(data_list), + sigma=NULL, rho=0, use_f = TRUE) { + + # We don't modify data_list, but this is useful to ensure the + # argument is evaluated anyway + force(ndim) + + # Error handling for N + if(is.null(N) || is.na(N) || !is.atomic(N) || length(N) > 1 || N <= 0) { + stop("N must be a single integer that is positive.") + } + + # Error handling for rho, if specified + if(is.atomic(rho)) { + if(ndim>2 & rho<0) { + stop("The correlation matrix must be positive semi-definite. In specific, ", + "if the number of variables being drawn from jointly is 3 or more, ", + "then the correlation coefficient rho must be non-negative.") + } + + if(rho == 0) { + # Uncorrelated draw would be way faster; just sample each column + return(lapply(seq_along(data_list), + function(vn) { + sample.int(length(data_list[[vn]]), N, replace=TRUE) + })) + } + sigma = matrix(rho, ncol=ndim, nrow=ndim) + diag(sigma) = 1 + } else { + stop("If specified, rho should be a single number") + } + + # Error handling for sigma + if(ncol(sigma) != ndim | nrow(sigma) != ndim | any(diag(sigma) != 1)) { + stop("The correlation matrix must be square, with the number of dimensions ", + "equal to the number of dimensions you are drawing from. In addition, ", + "the diagonal of the matrix must be equal to 1.") + } + + # Can we use the fast package or are we stuck with the slow one? + use_f = use_f && requireNamespace("mvnfast", quietly = TRUE) + + # Standard normal = all dimensions mean 0. + mu = rep(0, ndim) + + # Possible options for the joint normal draw + if(!use_f) { + # Below code is a reimplementation of the operative parts of rmvnorm from + # the mvtnorm package so that we don't induce a dependency + + # Right cholesky decomposition (i.e. LR = sigma s.t. L is lower triang, R + # is upper triang.) + right_chol = chol(sigma, pivot=TRUE) + # Order columns by the pivot attribute -- induces numerical stability? + right_chol = right_chol[, order(attr(right_chol, "pivot"))] + # Generate standard normal data and right-multiply by decomposed matrix + # with right_chol to make it correlated. + correlated_sn <- matrix(rnorm(N * ndim), + nrow = N, + byrow = TRUE) %*% right_chol + + } else { + # Using mvnfast + correlated_sn = mvnfast::rmvn(N, ncores = 2, mu, sigma) + } + + # Z-scores to quantiles + quantiles = pnorm(correlated_sn) + colnames(quantiles) = names(data_list) + + # Quantiles to inverse eCDF. + result = lapply( + seq_along(data_list), + function(vn) { + # What would the indices of the quantiles be if our data was ordered -- + # if the answer is below 0, set it to 1. round will ensure the tie- + # breaking behaviour is random with respect to outcomes + ordered_indices = pmax(1, + round(quantiles[, vn] * length(data_list[[vn]])) + ) + + # Now get the order permutation vector and map that to the ordered indices + # to get the indices in the original space + indices = order(data_list[[vn]])[ordered_indices] + }) + + + # Set up response + result +} diff --git a/R/fabricate.R b/R/fabricate.R index 3a35a88..7369159 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -222,7 +222,8 @@ add_level = function(N = NULL, ID_label = NULL, # Append it to the existing shelf if("shelved_df" %in% names(working_environment_)) { - working_environment_$shelved_df = append(working_environment_$shelved_df, package_df) + working_environment_$shelved_df = append(working_environment_$shelved_df, + list(package_df)) } else { # Create a shelf just for this working_environment_$shelved_df = list(package_df) @@ -411,7 +412,6 @@ modify_level = function(N = NULL, data_arguments=quos(...)) { # Need to supply an ID_label, otherwise we have no idea what to modify. - # You actually can, though! It'd just be per unit if(is.null(ID_label)) { stop("You can't modify a level without a known level ID variable. If you", "are adding nested data, please use add_level") @@ -571,6 +571,106 @@ modify_level = function(N = NULL, return(working_environment_) } +#' @importFrom rlang quos quo_text +#' +#' @rdname fabricate +#' @export +cross_classify = function(N = NULL, + ID_label = NULL, + working_environment_ = NULL, + ..., + rho = 0, + sigma = NULL, + data_arguments=quos(...)) { + + + if(any(!c("data_frame_output_", "shelved_df") %in% + names(working_environment_))) { + stop("You require at least two separate level hierarchies to create ", + "cross-classified data.") + } + + # Move the current working data frame into a package + package_df = list(data_frame_output_ = working_environment_$data_frame_output_, + level_ids_ = working_environment_$level_ids_, + variable_names_ = names(working_environment_$data_frame_output_)) + + # Stuff it in the shelved df + working_environment_$shelved_df = append(working_environment_$shelved_df, + list(package_df)) + + # Clear the active working data frame. + working_environment_$data_frame_output_ = + working_environment_$level_ids_ = + working_environment_$variable_names_ = NULL + + # Loop over the variable name + data_frame_indices = numeric(length(data_arguments)) + variable_names = unlist(lapply(data_arguments, function(x) { quo_text(x) })) + + if(anyDuplicated(variable_names)) { + stop("Variables names for joining cross-classified data must be unique. ", + "Currently, you are joining on a variable named \"", + variable_names[anyDuplicated(variable_names)[1]], + "\" more than once.") + } + + # Figure out which dfs we're joining on which variables + for(i in seq_along(variable_names)) { + for(j in seq_along(working_environment_$shelved_df)) { + if(variable_names[i] %in% + working_environment_$shelved_df[[j]]$variable_names_) { + + # If we've already found this one, that's bad news for us... + if(data_frame_indices[i]) { + stop("Variable name ", + names(data_arguments)[i], + " is ambiguous and appears in at least two level hierarchies.") + } + + data_frame_indices[i] = j + } + } + + # If we didn't find this one, that's bad news for us... + if(!data_frame_indices[i]) { + stop("Variable name ", + variable_names[i], + " was not found in any of the level hierarchies.") + } + } + + if(anyDuplicated(data_frame_indices)) { + stop("You can't join a level hierarchy to itself.") + } + + # Actually fetch the df objects + data_frame_objects = sapply(data_frame_indices, + function(x) { + working_environment_$shelved_df[[x]]$data_frame_output_ + }, + simplify = FALSE + ) + + # Do the join. + out = join_dfs(data_frame_objects, variable_names, N, sigma, rho) + working_environment_$variable_names_ = names(out) + + # Staple in an ID column onto the data list. + if(!is.null(ID_label) && (!ID_label %in% names(out))) { + out[, ID_label ] = generate_id_pad(N) + + add_level_id(working_environment_, ID_label) + add_variable_name(working_environment_, ID_label) + } + + # Overwrite the working data frame. + working_environment_$data_frame_output_ = out + + # Return results + return(working_environment_) +} + #' Deprecated level call function maintained to provide useful error for #' previous fabricatr code. #' @keywords internal diff --git a/R/helper_functions.R b/R/helper_functions.R index 57f63c2..a04eb70 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -287,7 +287,8 @@ check_all_levels <- function(options){ is_level = sapply(func_names, function(i) { i %in% c("level", "add_level", "nest_level", - "modify_level") }) + "modify_level", + "cross_classify") }) # Return false if we have no level calls if(length(is_level) == 0) return(FALSE) From 99b6344e69441f3ea347e176c457369c18d3b5a4 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Mon, 18 Dec 2017 19:33:21 -0800 Subject: [PATCH 38/47] Changes to cross_level syntax and documentation for cross-classified data. --- NAMESPACE | 3 +- R/fabricate.R | 76 ++++++++++++++++++++++++++++++-------------- R/helper_functions.R | 2 +- man/cross_level.Rd | 27 ++++++++++++++++ man/fabricate.Rd | 5 ++- man/join.Rd | 22 +++++++++++++ 6 files changed, 107 insertions(+), 28 deletions(-) create mode 100644 man/cross_level.Rd create mode 100644 man/join.Rd diff --git a/NAMESPACE b/NAMESPACE index ec10039..dbc814e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -2,12 +2,13 @@ export(ALL) export(add_level) -export(cross_classify) +export(cross_level) export(draw_binary) export(draw_binary_icc) export(draw_discrete) export(draw_normal_icc) export(fabricate) +export(join) export(level) export(modify_level) export(resample_data) diff --git a/R/fabricate.R b/R/fabricate.R index 7369159..7c05a85 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -24,8 +24,7 @@ #' \code{my_var = rnorm(N)}. For \code{fabricate}, you may also pass #' \code{add_level()} or \code{modify_level()} arguments, which define a level #' of a multi-level dataset. See examples. -#' @param new_hierarchy Reserved argument for future functionality to add -#' cross-classified data. Not yet implemented. +#' @param nest (Default TRUE) Boolean determining whether data in an \code{add_level()} call will be nested under the current working data frame or create a separate hierarchy of levels. See our vignette for cross-classified, non-nested data for details. #' @param working_environment_ Internal argument, not intended for end-user use. #' @param data_arguments Internal argument, not intended for end-user use. #' @@ -175,7 +174,7 @@ fabricate <- function(data = NULL, ..., N = NULL, ID_label = NULL) add_level(N = N, ID_label = ID_label, data_arguments = data_arguments, - new_hierarchy=TRUE) + nest=TRUE) ) ) } @@ -188,7 +187,7 @@ add_level = function(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments=quos(...), - new_hierarchy = FALSE) { + nest = TRUE) { # Copy the working environment out of the data_arguments quosure and into # the root. This happens when we have a single non-nested fabricate call @@ -201,7 +200,7 @@ add_level = function(N = NULL, ID_label = NULL, # Pass-through mapper to nest_level. # This needs to be done after we read the working environment and # before we check N or do the shelving procedure. - if(!new_hierarchy & + if(nest & ("data_frame_output_" %in% names(working_environment_) | "imported_data_" %in% names(working_environment_))) { return(nest_level(N=N, ID_label=ID_label, @@ -406,10 +405,10 @@ nest_level = function(N = NULL, ID_label = NULL, #' @rdname fabricate #' @export modify_level = function(N = NULL, - ID_label = NULL, - working_environment_ = NULL, - ..., - data_arguments=quos(...)) { + ID_label = NULL, + working_environment_ = NULL, + ..., + data_arguments=quos(...)) { # Need to supply an ID_label, otherwise we have no idea what to modify. if(is.null(ID_label)) { @@ -571,18 +570,23 @@ modify_level = function(N = NULL, return(working_environment_) } -#' @importFrom rlang quos quo_text +#' Creates cross-classified (partially non-nested, joined data) with a fixed +#' correlation structure. #' -#' @rdname fabricate +#' @param N (required) The number of observations in the resulting data frame +#' @param by The result of a call to \code{join()} which specifies how the cross-classified data will be created +#' @param ... A variable or series of variables to add to the resulting data frame after the cross-classified data is created. +#' @param ID_label Internal keyword used to sepcify the name of the ID variable created for the new level. If left empty, this will be the name the level is assigned to as part of a \code{fabricate()} call. +#' @param working_environment_ Internal keyword not for end user use. +#' @param data_arguments Internal keyword not for end user use. +#' @importFrom rlang quos quo_text #' @export -cross_classify = function(N = NULL, - ID_label = NULL, - working_environment_ = NULL, - ..., - rho = 0, - sigma = NULL, - data_arguments=quos(...)) { - +cross_level = function(N = NULL, + ID_label = NULL, + working_environment_ = NULL, + by = NULL, + ..., + data_arguments=quos(...)) { if(any(!c("data_frame_output_", "shelved_df") %in% names(working_environment_))) { @@ -590,6 +594,10 @@ cross_classify = function(N = NULL, "cross-classified data.") } + if(is.null(by) || !length(by$variable_names)) { + stop("You must specify a join structure to create cross-classified data.") + } + # Move the current working data frame into a package package_df = list(data_frame_output_ = working_environment_$data_frame_output_, level_ids_ = working_environment_$level_ids_, @@ -605,8 +613,9 @@ cross_classify = function(N = NULL, working_environment_$variable_names_ = NULL # Loop over the variable name - data_frame_indices = numeric(length(data_arguments)) - variable_names = unlist(lapply(data_arguments, function(x) { quo_text(x) })) + + variable_names = by$variable_names + data_frame_indices = numeric(length(variable_names)) if(anyDuplicated(variable_names)) { stop("Variables names for joining cross-classified data must be unique. ", @@ -653,12 +662,12 @@ cross_classify = function(N = NULL, ) # Do the join. - out = join_dfs(data_frame_objects, variable_names, N, sigma, rho) + out = join_dfs(data_frame_objects, variable_names, N, by$sigma, by$rho) working_environment_$variable_names_ = names(out) # Staple in an ID column onto the data list. if(!is.null(ID_label) && (!ID_label %in% names(out))) { - out[, ID_label ] = generate_id_pad(N) + out[, ID_label] = generate_id_pad(N) add_level_id(working_environment_, ID_label) add_variable_name(working_environment_, ID_label) @@ -667,10 +676,31 @@ cross_classify = function(N = NULL, # Overwrite the working data frame. working_environment_$data_frame_output_ = out + if(length(data_arguments)) { + print(data_arguments) + working_environment_ = modify_level(ID_label = ID_label, + working_environment_ = working_environment_, + data_arguments = data_arguments) + } + # Return results return(working_environment_) } +#' Helper function handling specification of which variables to join a +#' cross-classified data on, and what kind of correlation structure needed +#' @param ... A series of two or more variable names, unquoted, to join on in order to create cross-classified data. +#' @param rho A fixed (Spearman's rank) correlation coefficient between the variables being joined on: note that if it is not possible to make a correlation matrix from this coefficient (i.e. if you are joining on three or more variables and rho is negative) then the \code{cross_level()} call will fail. +#' @param sigma A matrix with dimensions equal to the number of variables you are joining on, specifying the correlation for the resulting joined data. Only one of rho and sigma should be provided. +#' @param data_arguments Internal, not for end-user use. +#' @export +join = function(..., rho=0, sigma=NULL, data_arguments=quos(...)) { + variable_names = unlist(lapply(data_arguments, function(x) { quo_text(x) })) + return(list(variable_names = variable_names, + rho = rho, + sigma = sigma)) +} + #' Deprecated level call function maintained to provide useful error for #' previous fabricatr code. #' @keywords internal diff --git a/R/helper_functions.R b/R/helper_functions.R index a04eb70..8525270 100644 --- a/R/helper_functions.R +++ b/R/helper_functions.R @@ -288,7 +288,7 @@ check_all_levels <- function(options){ "add_level", "nest_level", "modify_level", - "cross_classify") }) + "cross_level") }) # Return false if we have no level calls if(length(is_level) == 0) return(FALSE) diff --git a/man/cross_level.Rd b/man/cross_level.Rd new file mode 100644 index 0000000..17cc716 --- /dev/null +++ b/man/cross_level.Rd @@ -0,0 +1,27 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fabricate.R +\name{cross_level} +\alias{cross_level} +\title{Creates cross-classified (partially non-nested, joined data) with a fixed +correlation structure.} +\usage{ +cross_level(N = NULL, ID_label = NULL, working_environment_ = NULL, + by = NULL, ..., data_arguments = quos(...)) +} +\arguments{ +\item{N}{(required) The number of observations in the resulting data frame} + +\item{ID_label}{Internal keyword used to sepcify the name of the ID variable created for the new level. If left empty, this will be the name the level is assigned to as part of a \code{fabricate()} call.} + +\item{working_environment_}{Internal keyword not for end user use.} + +\item{by}{The result of a call to \code{join()} which specifies how the cross-classified data will be created} + +\item{...}{A variable or series of variables to add to the resulting data frame after the cross-classified data is created.} + +\item{data_arguments}{Internal keyword not for end user use.} +} +\description{ +Creates cross-classified (partially non-nested, joined data) with a fixed +correlation structure. +} diff --git a/man/fabricate.Rd b/man/fabricate.Rd index c4599bc..e0c0ba0 100644 --- a/man/fabricate.Rd +++ b/man/fabricate.Rd @@ -9,7 +9,7 @@ fabricate(data = NULL, ..., N = NULL, ID_label = NULL) add_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., - data_arguments = quos(...), new_hierarchy = FALSE) + data_arguments = quos(...), nest = TRUE) modify_level(N = NULL, ID_label = NULL, working_environment_ = NULL, ..., data_arguments = quos(...)) @@ -37,8 +37,7 @@ of units in a specific level of a hierarchical dataset.} \item{data_arguments}{Internal argument, not intended for end-user use.} -\item{new_hierarchy}{Reserved argument for future functionality to add -cross-classified data. Not yet implemented.} +\item{nest}{(Default TRUE) Boolean determining whether data in an \code{add_level()} call will be nested under the current working data frame or create a separate hierarchy of levels. See our vignette for cross-classified, non-nested data for details.} } \value{ data.frame diff --git a/man/join.Rd b/man/join.Rd new file mode 100644 index 0000000..48536b5 --- /dev/null +++ b/man/join.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fabricate.R +\name{join} +\alias{join} +\title{Helper function handling specification of which variables to join a +cross-classified data on, and what kind of correlation structure needed} +\usage{ +join(..., rho = 0, sigma = NULL, data_arguments = quos(...)) +} +\arguments{ +\item{...}{A series of two or more variable names, unquoted, to join on in order to create cross-classified data.} + +\item{rho}{A fixed (Spearman's rank) correlation coefficient between the variables being joined on: note that if it is not possible to make a correlation matrix from this coefficient (i.e. if you are joining on three or more variables and rho is negative) then the \code{cross_level()} call will fail.} + +\item{sigma}{A matrix with dimensions equal to the number of variables you are joining on, specifying the correlation for the resulting joined data. Only one of rho and sigma should be provided.} + +\item{data_arguments}{Internal, not for end-user use.} +} +\description{ +Helper function handling specification of which variables to join a +cross-classified data on, and what kind of correlation structure needed +} From bd367895982ec7a7a87a2723385b7adb3e20bf9d Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 09:43:25 -0800 Subject: [PATCH 39/47] First test pass at cross-classified data, fixed a bug in specifying sigma --- R/cross_classify_helpers.R | 36 ++++++++-------- R/fabricate.R | 1 - tests/testthat/test-crossclassified.R | 61 +++++++++++++++++++++++++++ 3 files changed, 80 insertions(+), 18 deletions(-) create mode 100644 tests/testthat/test-crossclassified.R diff --git a/R/cross_classify_helpers.R b/R/cross_classify_helpers.R index b78ae66..6ff5259 100644 --- a/R/cross_classify_helpers.R +++ b/R/cross_classify_helpers.R @@ -54,24 +54,26 @@ joint_draw_ecdf = function (data_list, N, ndim=length(data_list), } # Error handling for rho, if specified - if(is.atomic(rho)) { - if(ndim>2 & rho<0) { - stop("The correlation matrix must be positive semi-definite. In specific, ", - "if the number of variables being drawn from jointly is 3 or more, ", - "then the correlation coefficient rho must be non-negative.") + if(is.null(sigma)) { + if(is.atomic(rho)) { + if(ndim>2 & rho<0) { + stop("The correlation matrix must be positive semi-definite. In specific, ", + "if the number of variables being drawn from jointly is 3 or more, ", + "then the correlation coefficient rho must be non-negative.") + } + + if(rho == 0) { + # Uncorrelated draw would be way faster; just sample each column + return(lapply(seq_along(data_list), + function(vn) { + sample.int(length(data_list[[vn]]), N, replace=TRUE) + })) + } + sigma = matrix(rho, ncol=ndim, nrow=ndim) + diag(sigma) = 1 + } else { + stop("If specified, rho should be a single number") } - - if(rho == 0) { - # Uncorrelated draw would be way faster; just sample each column - return(lapply(seq_along(data_list), - function(vn) { - sample.int(length(data_list[[vn]]), N, replace=TRUE) - })) - } - sigma = matrix(rho, ncol=ndim, nrow=ndim) - diag(sigma) = 1 - } else { - stop("If specified, rho should be a single number") } # Error handling for sigma diff --git a/R/fabricate.R b/R/fabricate.R index 7c05a85..6b4dc1b 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -677,7 +677,6 @@ cross_level = function(N = NULL, working_environment_$data_frame_output_ = out if(length(data_arguments)) { - print(data_arguments) working_environment_ = modify_level(ID_label = ID_label, working_environment_ = working_environment_, data_arguments = data_arguments) diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R new file mode 100644 index 0000000..d31adce --- /dev/null +++ b/tests/testthat/test-crossclassified.R @@ -0,0 +1,61 @@ +context("Fabricate") + +test_that("Cross-classified data", { + # Example draw setup + students = fabricate( + primary_schools = add_level(N = 100, + ps_quality = runif(n=N, 1, 100), + ps_hasband = draw_binary(0.5, N=N), + ps_testscores = ps_quality * 5 + rnorm(N, 30, 5)), + secondary_schools = add_level(N = 50, + ss_quality = runif(n=N, 1, 100), + ss_hascomputers = draw_binary(ss_quality/100, N=N), + ss_testscores = ss_quality * 5 + rnorm(N, 30, 5), + nest = FALSE), + students = cross_level(N = 1000, + by = join(ps_quality, ss_quality, rho=0.5), + student_score = ps_testscores * 5 + ss_testscores * 10 + rnorm(N, 10, 5), + student_score_2 = student_score * 2, + extracurricular = ps_hasband + ss_hascomputers + ) + ) + + # Within a reasonable "tolerance" + expect_gte(cor(students$ps_quality, students$ss_quality), 0.3) + expect_lte(cor(students$ps_quality, students$ss_quality), 0.7) + + # Uncorrelated + students_uncorr = fabricate( + primary_schools = add_level(N = 100, + ps_quality = runif(n=N, 1, 100), + ps_hasband = draw_binary(0.5, N=N), + ps_testscores = ps_quality * 5 + rnorm(N, 30, 5)), + secondary_schools = add_level(N = 50, + ss_quality = runif(n=N, 1, 100), + ss_hascomputers = draw_binary(ss_quality/100, N=N), + ss_testscores = ss_quality * 5 + rnorm(N, 30, 5), + nest = FALSE), + students = cross_level(N = 1000, + by = join(ps_quality, ss_quality, rho=0), + student_score = ps_testscores * 5 + ss_testscores * 10 + rnorm(N, 10, 5), + student_score_2 = student_score * 2, + extracurricular = ps_hasband + ss_hascomputers + ) + ) + + # Again, within tolerance + expect_gte(cor(students_uncorr$ps_quality, students_uncorr$ss_quality), -0.1) + expect_lte(cor(students_uncorr$ps_quality, students_uncorr$ss_quality), 0.1) + + + # Specifying sigma in lieu of rho + test_next = fabricate( + l1 = add_level(N = 50, j1 = rnorm(N)), + l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), + joined = cross_level(N = 200, + by = join(j1, j2, sigma=matrix(c(1, 0.5, 0.5, 1), ncol=2))) + ) + + expect_gte(cor(test_next$j1, test_next$j2), 0.3) + expect_lte(cor(test_next$j1, test_next$j2), 0.7) +}) From ff97198432e0ae3d086b6f1fe840f98e79f0f58b Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 10:16:11 -0800 Subject: [PATCH 40/47] Fix a bug in specifying rho, added tests for all the cross-classifying helpers. --- R/cross_classify_helpers.R | 2 +- tests/testthat/test-crossclassified.R | 33 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/R/cross_classify_helpers.R b/R/cross_classify_helpers.R index 6ff5259..02e10fc 100644 --- a/R/cross_classify_helpers.R +++ b/R/cross_classify_helpers.R @@ -55,7 +55,7 @@ joint_draw_ecdf = function (data_list, N, ndim=length(data_list), # Error handling for rho, if specified if(is.null(sigma)) { - if(is.atomic(rho)) { + if(is.atomic(rho) & length(rho)==1) { if(ndim>2 & rho<0) { stop("The correlation matrix must be positive semi-definite. In specific, ", "if the number of variables being drawn from jointly is 3 or more, ", diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index d31adce..1f6e10c 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -59,3 +59,36 @@ test_that("Cross-classified data", { expect_gte(cor(test_next$j1, test_next$j2), 0.3) expect_lte(cor(test_next$j1, test_next$j2), 0.7) }) + +test_that("Code path without mvnfast", { + # Need to directly call joint_draw_ecdf because we don't let users voluntarily + # override the use_f argument + dl = list(j1 = rnorm(100), + j2 = rnorm(500)) + result = fabricatr:::joint_draw_ecdf(dl, N = 100, rho = 0.25, use_f = FALSE) + data = cbind(dl$j1[result[[1]]], + dl$j2[result[[2]]]) + expect_gte(cor(data[, 1], data[, 2]), 0.1) + expect_lte(cor(data[, 1], data[, 2]), 0.4) +}) + +test_that("Deliberate failures", { + df1 = fabricate(N=100, j1 = rnorm(100)) + df2 = fabricate(N=100, j2 = rnorm(100)) + df3 = fabricate(N=100, j3 = rnorm(100)) + + expect_error(fabricatr::join_dfs(df1, c("j1"), N=100, rho=0.5)) + expect_error(fabricatr::join_dfs(list(df1, df2), c("j1"), N=100, rho=0.5)) + expect_error(fabricatr::join_dfs(list(df1), c("j1"), N=100, rho=0.5)) + expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), N=-1, rho=0.5)) + expect_error(fabricatr::join_dfs(list(df1, df2), c("j1"), N=c(3, 10), rho=0.5)) + expect_error(fabricatr::join_dfs(list(df1, df2, df3), c("j1", "j2", "j3"), N=100, rho=-0.5)) + expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), N=100, rho=c(0.5, 0.3))) + + expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), + N=100, + sigma=matrix(c(1, 0.3, 0.3, 0.3, 1, 0.3, 0.3, 0.3, 1), + ncol = 3 + ))) + +}) From 6e441180195b30ffce8536d148e6e351296b4b61 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 10:34:40 -0800 Subject: [PATCH 41/47] Fixed a bug that made all the tests I just wrote not work. --- tests/testthat/test-crossclassified.R | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index 1f6e10c..1078408 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -77,18 +77,17 @@ test_that("Deliberate failures", { df2 = fabricate(N=100, j2 = rnorm(100)) df3 = fabricate(N=100, j3 = rnorm(100)) - expect_error(fabricatr::join_dfs(df1, c("j1"), N=100, rho=0.5)) - expect_error(fabricatr::join_dfs(list(df1, df2), c("j1"), N=100, rho=0.5)) - expect_error(fabricatr::join_dfs(list(df1), c("j1"), N=100, rho=0.5)) - expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), N=-1, rho=0.5)) - expect_error(fabricatr::join_dfs(list(df1, df2), c("j1"), N=c(3, 10), rho=0.5)) - expect_error(fabricatr::join_dfs(list(df1, df2, df3), c("j1", "j2", "j3"), N=100, rho=-0.5)) - expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), N=100, rho=c(0.5, 0.3))) + expect_error(fabricatr:::join_dfs(df1, c("j1"), N=100, rho=0.5)) + expect_error(fabricatr:::join_dfs(list(df1, df2), c("j1"), N=100, rho=0.5)) + expect_error(fabricatr:::join_dfs(list(df1), c("j1"), N=100, rho=0.5)) + expect_error(fabricatr:::join_dfs(list(df1, df2), c("j1", "j2"), N=-1, rho=0.5)) + expect_error(fabricatr:::join_dfs(list(df1, df2), c("j1"), N=c(3, 10), rho=0.5)) + expect_error(fabricatr:::join_dfs(list(df1, df2, df3), c("j1", "j2", "j3"), N=100, rho=-0.5)) + expect_error(fabricatr:::join_dfs(list(df1, df2), c("j1", "j2"), N=100, rho=c(0.5, 0.3))) - expect_error(fabricatr::join_dfs(list(df1, df2), c("j1", "j2"), + expect_error(fabricatr:::join_dfs(list(df1, df2), c("j1", "j2"), N=100, sigma=matrix(c(1, 0.3, 0.3, 0.3, 1, 0.3, 0.3, 0.3, 1), ncol = 3 ))) - }) From 7990a47a78950c931fd3c7f25997d43e31d7b69e Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 11:24:01 -0800 Subject: [PATCH 42/47] Added additional testing for outer wrapper of cross_level --- R/fabricate.R | 2 +- tests/testthat/test-crossclassified.R | 33 +++++++++++++++++++++++++++ 2 files changed, 34 insertions(+), 1 deletion(-) diff --git a/R/fabricate.R b/R/fabricate.R index 6b4dc1b..b01bb2a 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -633,7 +633,7 @@ cross_level = function(N = NULL, # If we've already found this one, that's bad news for us... if(data_frame_indices[i]) { stop("Variable name ", - names(data_arguments)[i], + variable_names[i], " is ambiguous and appears in at least two level hierarchies.") } diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index 1078408..9fb76a0 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -90,4 +90,37 @@ test_that("Deliberate failures", { sigma=matrix(c(1, 0.3, 0.3, 0.3, 1, 0.3, 0.3, 0.3, 1), ncol = 3 ))) + + expect_error( + test_next = fabricate( + l1 = add_level(N = 50, j1 = rnorm(N)), + l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), + joined = cross_level(N = 200, + by = join(j1, j_error, sigma=matrix(c(1, 0.5, 0.5, 1), ncol=2))) + ) + ) + + expect_error( + test_next = fabricate( + l1 = add_level(N = 50, j1 = rnorm(N)), + l2 = add_level(N = 50, j_var = rnorm(N), j1 = runif(N, 1, 3), nest=FALSE), + joined = cross_level(N = 200, + by = join(j1, j_var, sigma=matrix(c(1, 0.5, 0.5, 1), ncol=2))) + ) + ) + + expect_error( + test_next = fabricate( + l1 = add_level(N = 50, j1 = rnorm(N)), + l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), + joined = cross_level(N = 200) + ) + ) + + expect_error( + test_next = fabricate( + l1 = add_level(N = 50), + joined = cross_level(N = 200) + ) + ) }) From 8fc19f86485e93e2d54693ac9b55928d0f5b8e5f Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 11:50:50 -0800 Subject: [PATCH 43/47] A little bit of test coverage in my life, a little bit of bug fixing by my side, a little bit of optimization is all I need, a little bit of CI bugs is what I see --- tests/testthat/test-crossclassified.R | 11 +++++++++-- tests/testthat/test-fabrication.R | 18 ++++++++++++++++++ 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index 9fb76a0..d63675a 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -72,7 +72,7 @@ test_that("Code path without mvnfast", { expect_lte(cor(data[, 1], data[, 2]), 0.4) }) -test_that("Deliberate failures", { +test_that("Deliberate failures in join_dfs", { df1 = fabricate(N=100, j1 = rnorm(100)) df2 = fabricate(N=100, j2 = rnorm(100)) df3 = fabricate(N=100, j3 = rnorm(100)) @@ -90,13 +90,20 @@ test_that("Deliberate failures", { sigma=matrix(c(1, 0.3, 0.3, 0.3, 1, 0.3, 0.3, 0.3, 1), ncol = 3 ))) +}) +test_that("Deliberate failures in cross_level", { expect_error( test_next = fabricate( l1 = add_level(N = 50, j1 = rnorm(N)), l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), joined = cross_level(N = 200, - by = join(j1, j_error, sigma=matrix(c(1, 0.5, 0.5, 1), ncol=2))) + by = join(j1, + j_error, + sigma=matrix(c(1, 0.5, 0.5, 1), + ncol=2) + ) + ) ) ) diff --git a/tests/testthat/test-fabrication.R b/tests/testthat/test-fabrication.R index 64bb38c..cb93181 100644 --- a/tests/testthat/test-fabrication.R +++ b/tests/testthat/test-fabrication.R @@ -173,3 +173,21 @@ test_that("nest_level call when there was no data to nest", { # Import data, should be able to nest level fabricate(datasets::BOD, units = nest_level(N = 2, dd = demand * 2)) }) + + +test_that("multiple non-nested data frames, again and again", { + fabricate( + l1 = add_level(N = 100), + l2 = add_level(N = 200, nest=FALSE), + l3 = add_level(N = 100, nest=FALSE), + l4 = add_level(N = 300, nest=FALSE) + ) +}) + +test_that("importing data and then specifying a level ID variable that is in data.", { + df = fabricate(N = 100, d1 = rnorm(N), ID_label = "hello") + df2 = fabricate(df, ID_label = "hello", new_var1 = d1 * 2) + expect_equal(length(colnames(df2)), 3) + df3 = fabricate(df, new_var1 = d1 * 2) + expect_equal(length(colnames(df3)), 4) +}) From 7c6c3072291d811087a8dff8b3a9c30950a10ab7 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 12:09:59 -0800 Subject: [PATCH 44/47] Version bump due to breaking syntax change. --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index d75ba30..9d94a6b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: fabricatr Type: Package Title: Imagine your data before you collect it -Version: 1.0.0 +Version: 1.0.1 Authors@R: c(person("Graeme", "Blair", email = "graeme.blair@ucla.edu", role = c("aut", "cre")), person("Jasper", "Cooper", email = "jjc2247@columbia.edu", role = c("aut")), person("Alexander", "Coppock", email = "alex.coppock@yale.edu", role = c("aut")), From 289693b44b4157cff5babf864d4dd955cff146b1 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 21:21:05 -0800 Subject: [PATCH 45/47] Fixes for test apparatus to work with testthat 2.0.0 --- tests/testthat/test-crossclassified.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index d63675a..bdb7a57 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -94,7 +94,7 @@ test_that("Deliberate failures in join_dfs", { test_that("Deliberate failures in cross_level", { expect_error( - test_next = fabricate( + fabricate( l1 = add_level(N = 50, j1 = rnorm(N)), l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), joined = cross_level(N = 200, @@ -108,7 +108,7 @@ test_that("Deliberate failures in cross_level", { ) expect_error( - test_next = fabricate( + fabricate( l1 = add_level(N = 50, j1 = rnorm(N)), l2 = add_level(N = 50, j_var = rnorm(N), j1 = runif(N, 1, 3), nest=FALSE), joined = cross_level(N = 200, @@ -117,7 +117,7 @@ test_that("Deliberate failures in cross_level", { ) expect_error( - test_next = fabricate( + fabricate( l1 = add_level(N = 50, j1 = rnorm(N)), l2 = add_level(N = 50, j2 = rnorm(N), nest=FALSE), joined = cross_level(N = 200) @@ -125,7 +125,7 @@ test_that("Deliberate failures in cross_level", { ) expect_error( - test_next = fabricate( + fabricate( l1 = add_level(N = 50), joined = cross_level(N = 200) ) From f33c26da4824ca52d58f5e3f0700e058f743d7ee Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 22:21:48 -0800 Subject: [PATCH 46/47] A few more tests and fixed a bug in adding variables after importing data. --- R/fabricate.R | 2 +- tests/testthat/test-crossclassified.R | 20 +++++++++++++++++-- .../testthat/test-start-with-existing-data.R | 5 +++++ 3 files changed, 24 insertions(+), 3 deletions(-) diff --git a/R/fabricate.R b/R/fabricate.R index b01bb2a..409992a 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -174,7 +174,7 @@ fabricate <- function(data = NULL, ..., N = NULL, ID_label = NULL) add_level(N = N, ID_label = ID_label, data_arguments = data_arguments, - nest=TRUE) + nest=FALSE) ) ) } diff --git a/tests/testthat/test-crossclassified.R b/tests/testthat/test-crossclassified.R index bdb7a57..8a570a1 100644 --- a/tests/testthat/test-crossclassified.R +++ b/tests/testthat/test-crossclassified.R @@ -65,11 +65,11 @@ test_that("Code path without mvnfast", { # override the use_f argument dl = list(j1 = rnorm(100), j2 = rnorm(500)) - result = fabricatr:::joint_draw_ecdf(dl, N = 100, rho = 0.25, use_f = FALSE) + result = fabricatr:::joint_draw_ecdf(dl, N = 100, rho = 0.3, use_f = FALSE) data = cbind(dl$j1[result[[1]]], dl$j2[result[[2]]]) expect_gte(cor(data[, 1], data[, 2]), 0.1) - expect_lte(cor(data[, 1], data[, 2]), 0.4) + expect_lte(cor(data[, 1], data[, 2]), 0.5) }) test_that("Deliberate failures in join_dfs", { @@ -130,4 +130,20 @@ test_that("Deliberate failures in cross_level", { joined = cross_level(N = 200) ) ) + + expect_error( + fabricate( + l1 = add_level(N = 50, v1 = rnorm(N), v2 = rnorm(N), v3 = rnorm(N)), + l2 = add_level(N = 30, v4 = rnorm(N), nest=FALSE), + joined = cross_level(N = 100, by=join(v1, v2)) + ) + ) + + expect_error( + fabricate( + l1 = add_level(N = 50, v1 = rnorm(N), v2 = rnorm(N), v3 = rnorm(N)), + l2 = add_level(N = 30, v4 = rnorm(N), nest=FALSE), + joined = cross_level(N = 100, by=join(v1, v4, v1)) + ) + ) }) diff --git a/tests/testthat/test-start-with-existing-data.R b/tests/testthat/test-start-with-existing-data.R index 350d18a..32f348f 100644 --- a/tests/testthat/test-start-with-existing-data.R +++ b/tests/testthat/test-start-with-existing-data.R @@ -1,5 +1,10 @@ context("Start with existing multi-level data and add variables") +test_that("Import data plus single-level add variables.", { + result = fabricate(mtcars, zort = drat * 2) + expect_equal(dim(result), c(32, 13)) +}) + test_that("Start with existing multi-level data and add variables",{ user_data <- From ce4080ab9d3b8a4d47849c73e1a9efb4b4b07095 Mon Sep 17 00:00:00 2001 From: Aaron Rudkin Date: Tue, 19 Dec 2017 22:56:59 -0800 Subject: [PATCH 47/47] Fixes from nfultz's code review. --- R/cross_classify_helpers.R | 7 +++---- R/draw_binary_icc.R | 8 +++++--- R/draw_normal_icc.R | 8 +++++--- R/fabricate.R | 17 ++++++++--------- man/draw_binary_icc.Rd | 8 +++++--- man/draw_normal_icc.Rd | 8 +++++--- 6 files changed, 31 insertions(+), 25 deletions(-) diff --git a/R/cross_classify_helpers.R b/R/cross_classify_helpers.R index 02e10fc..bb3ed1d 100644 --- a/R/cross_classify_helpers.R +++ b/R/cross_classify_helpers.R @@ -57,7 +57,7 @@ joint_draw_ecdf = function (data_list, N, ndim=length(data_list), if(is.null(sigma)) { if(is.atomic(rho) & length(rho)==1) { if(ndim>2 & rho<0) { - stop("The correlation matrix must be positive semi-definite. In specific, ", + stop("The correlation matrix must be positive semi-definite. Specifically, ", "if the number of variables being drawn from jointly is 3 or more, ", "then the correlation coefficient rho must be non-negative.") } @@ -102,12 +102,11 @@ joint_draw_ecdf = function (data_list, N, ndim=length(data_list), # Generate standard normal data and right-multiply by decomposed matrix # with right_chol to make it correlated. correlated_sn <- matrix(rnorm(N * ndim), - nrow = N, - byrow = TRUE) %*% right_chol + nrow = N) %*% right_chol } else { # Using mvnfast - correlated_sn = mvnfast::rmvn(N, ncores = 2, mu, sigma) + correlated_sn = mvnfast::rmvn(N, ncores = getOption("mc.cores", 2L), mu, sigma) } # Z-scores to quantiles diff --git a/R/draw_binary_icc.R b/R/draw_binary_icc.R index 3033e4f..92a3389 100644 --- a/R/draw_binary_icc.R +++ b/R/draw_binary_icc.R @@ -6,12 +6,14 @@ #' Generation, and Estimation of Intracluster Correlation Coefficient (ICC) #' for Binary Data". #' -#' @param x A number or vector of numbers, one probability per cluster. +#' @param x A number or vector of numbers, one probability per cluster. If none +#' is provided, will default to 0.5. #' @param N (Optional) A number indicating the number of observations to be #' generated. Must be equal to length(clusters) if provided. #' @param clusters A vector of factors or items that can be coerced to #' clusters; the length will determine the length of the generated data. -#' @param rho A number indicating the desired RCC. +#' @param rho A number indicating the desired ICC, if none is provided will +#' default to 0. #' @return A vector of binary numbers corresponding to the observations from #' the supplied cluster IDs. #' @examples @@ -22,7 +24,7 @@ #' @importFrom stats rbinom #' #' @export -draw_binary_icc = function(x = 0.5, N = NULL, clusters, rho = 0.5) { +draw_binary_icc = function(x = 0.5, N = NULL, clusters, rho = 0) { # Let's not worry about how clusters are provided tryCatch({ clusters = as.numeric(as.factor(clusters)) diff --git a/R/draw_normal_icc.R b/R/draw_normal_icc.R index ee74ba4..d944443 100644 --- a/R/draw_normal_icc.R +++ b/R/draw_normal_icc.R @@ -5,14 +5,16 @@ #' used in this function is specified at the following URL: #' \url{https://stats.stackexchange.com/questions/263451/create-synthetic-data-with-a-given-intraclass-correlation-coefficient-icc} #' -#' @param x A number or vector of numbers, one mean per cluster. +#' @param x A number or vector of numbers, one mean per cluster. If none is +#' provided, will default to 0. #' @param N (Optional) A number indicating the number of observations to be #' generated. Must be equal to length(clusters) if provided. #' @param clusters A vector of factors or items that can be coerced to #' clusters; the length will determine the length of the generated data. #' @param sd A number or vector of numbers, indicating the standard deviation of #' each cluster's error terms -#' @param rho A number indicating the desired RCC. +#' @param rho A number indicating the desired ICC. If none is provided, +#' will default to 0. #' @return A vector of numbers corresponding to the observations from #' the supplied cluster IDs. #' @examples @@ -26,7 +28,7 @@ draw_normal_icc = function(x = 0, N = NULL, clusters, sd = 1, - rho = 0.5) { + rho = 0) { # Let's not worry about how clusters are provided tryCatch({ diff --git a/R/fabricate.R b/R/fabricate.R index 409992a..a10c6f2 100644 --- a/R/fabricate.R +++ b/R/fabricate.R @@ -85,19 +85,19 @@ fabricate <- function(data = NULL, ..., N = NULL, ID_label = NULL) # 1) One or more level calls (with or without importing their own data) # 2) Import their own data and do not involve level calls # 3) Provide an N without importing their own data - if(sum((!is.null(data) & !missing(data) & !all_levels), + if(sum((!missing(data) && !is.null(data) & !all_levels), (!is.null(N) & !missing(N)), all_levels) != 1) { stop( - "Fabricate can be called in one of three ways: \n", - "1) Provide one or more level calls, with or without existing data \n", - "2) Provide existing data and add new variables without adding a level \n", - "3) Provide an \"N\" and add new variables" + "You must do exactly one of: \n", + "1) One or more level calls, with or without existing data \n", + "2) Import existing data and optionally, add new variables without adding a level \n", + "3) Provide an \"N\" without importing data and optionally, add new variables" ) } # Create a blank working environment. - working_environment = new.env() + working_environment = new.env(parent = emptyenv()) # User provided level calls if(all_levels) { @@ -200,7 +200,7 @@ add_level = function(N = NULL, ID_label = NULL, # Pass-through mapper to nest_level. # This needs to be done after we read the working environment and # before we check N or do the shelving procedure. - if(nest & + if(nest && ("data_frame_output_" %in% names(working_environment_) | "imported_data_" %in% names(working_environment_))) { return(nest_level(N=N, ID_label=ID_label, @@ -613,9 +613,8 @@ cross_level = function(N = NULL, working_environment_$variable_names_ = NULL # Loop over the variable name - variable_names = by$variable_names - data_frame_indices = numeric(length(variable_names)) + data_frame_indices = integer(length(variable_names)) if(anyDuplicated(variable_names)) { stop("Variables names for joining cross-classified data must be unique. ", diff --git a/man/draw_binary_icc.Rd b/man/draw_binary_icc.Rd index 7b2b519..4486dfe 100644 --- a/man/draw_binary_icc.Rd +++ b/man/draw_binary_icc.Rd @@ -4,10 +4,11 @@ \alias{draw_binary_icc} \title{Draw binary data with fixed intra-cluster correlation.} \usage{ -draw_binary_icc(x = 0.5, N = NULL, clusters, rho = 0.5) +draw_binary_icc(x = 0.5, N = NULL, clusters, rho = 0) } \arguments{ -\item{x}{A number or vector of numbers, one probability per cluster.} +\item{x}{A number or vector of numbers, one probability per cluster. If none +is provided, will default to 0.5.} \item{N}{(Optional) A number indicating the number of observations to be generated. Must be equal to length(clusters) if provided.} @@ -15,7 +16,8 @@ generated. Must be equal to length(clusters) if provided.} \item{clusters}{A vector of factors or items that can be coerced to clusters; the length will determine the length of the generated data.} -\item{rho}{A number indicating the desired RCC.} +\item{rho}{A number indicating the desired ICC, if none is provided will +default to 0.} } \value{ A vector of binary numbers corresponding to the observations from diff --git a/man/draw_normal_icc.Rd b/man/draw_normal_icc.Rd index 9275822..8b0e57e 100644 --- a/man/draw_normal_icc.Rd +++ b/man/draw_normal_icc.Rd @@ -4,10 +4,11 @@ \alias{draw_normal_icc} \title{Draw normal data with fixed intra-cluster correlation.} \usage{ -draw_normal_icc(x = 0, N = NULL, clusters, sd = 1, rho = 0.5) +draw_normal_icc(x = 0, N = NULL, clusters, sd = 1, rho = 0) } \arguments{ -\item{x}{A number or vector of numbers, one mean per cluster.} +\item{x}{A number or vector of numbers, one mean per cluster. If none is +provided, will default to 0.} \item{N}{(Optional) A number indicating the number of observations to be generated. Must be equal to length(clusters) if provided.} @@ -18,7 +19,8 @@ clusters; the length will determine the length of the generated data.} \item{sd}{A number or vector of numbers, indicating the standard deviation of each cluster's error terms} -\item{rho}{A number indicating the desired RCC.} +\item{rho}{A number indicating the desired ICC. If none is provided, +will default to 0.} } \value{ A vector of numbers corresponding to the observations from