diff --git a/DESCRIPTION b/DESCRIPTION index 0db6a7c..ad285f0 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: syntheval Title: A set of tools for evaluating synthetic data utility and disclosure risk -Version: 0.0.4 +Version: 0.0.5 Authors@R: c( person(given = "Aaron R.", family = "Williams", @@ -22,9 +22,10 @@ License: AGPL (>= 3) BugReports: https://github.com/UI-Research/syntheval/issues Encoding: UTF-8 Roxygen: list(markdown = TRUE) -RoxygenNote: 7.3.2 +RoxygenNote: 8.0.0 Suggests: forcats, + glmnet, stringr, testthat (>= 3.0.0) Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index da8de60..2067fa9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -30,9 +30,7 @@ export(util_ks_distance) export(util_moments) export(util_percentiles) export(util_proportions) -export(util_tails) export(util_totals) -export(weighted_skewness) importFrom(magrittr,"%>%") importFrom(rlang,":=") importFrom(rlang,.data) diff --git a/NEWS.md b/NEWS.md index 80549e8..882dfbd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,9 @@ +# syntheval 0.0.5 + +* Remove `util_tails()` +* Update deprecated dplyr code. +* Move all functions to use `eval_data` (#106). + # syntheval 0.0.4 * Add empirical disclosure risk metrics. diff --git a/R/co_occurence.R b/R/co_occurrence.R similarity index 77% rename from R/co_occurence.R rename to R/co_occurrence.R index 316c49c..9b723ee 100644 --- a/R/co_occurence.R +++ b/R/co_occurrence.R @@ -11,9 +11,9 @@ co_occurrence <- function(data, na.rm = FALSE) { data_names <- names(data) # create a p by p matrix - co_occurence_matrix <- matrix(nrow = ncol(data), ncol = ncol(data)) - rownames(co_occurence_matrix) <- data_names - colnames(co_occurence_matrix) <- data_names + co_occurrence_matrix <- matrix(nrow = ncol(data), ncol = ncol(data)) + rownames(co_occurrence_matrix) <- data_names + colnames(co_occurrence_matrix) <- data_names # iterate through the variables and assign the co-occurrences for (row_name in data_names) { @@ -32,13 +32,13 @@ co_occurrence <- function(data, na.rm = FALSE) { } - co_occurence_matrix[row_name, col_name] <- + co_occurrence_matrix[row_name, col_name] <- mean(row_var != 0 & col_var != 0) } } - return(co_occurence_matrix) + return(co_occurrence_matrix) } diff --git a/R/discrimination.R b/R/discrimination.R index 3d710da..ef0b0f5 100644 --- a/R/discrimination.R +++ b/R/discrimination.R @@ -1,7 +1,6 @@ #' Combine synthetic data and data for a discriminant based metric #' -#' @param postsynth A postsynth object from tidysynthesis or a tibble -#' @param data an original (observed) data set. +#' @param eval_data An `eval_data` object. #' #' @return A list of class discrimination #' @@ -9,17 +8,22 @@ #' #' @export #' -discrimination <- function(postsynth, data) { +discrimination <- function(eval_data) { - if (is_postsynth(postsynth)) { + stopifnot(is_eval_data(eval_data)) + + if (eval_data$n_rep > 1 ) { - synthetic_data <- postsynth$synthetic_data + synthetic_data <- eval_data[["synth_data"]][[1]] + message("Creating discriminator object using 1 synthetic data replicate.") } else { - synthetic_data <- postsynth + synthetic_data <- eval_data[["synth_data"]] } + data <- eval_data[["conf_data"]] + mismatched_variables <- c( setdiff(names(synthetic_data), names(data)), diff --git a/R/eval_data.R b/R/eval_data.R index facc73c..babea60 100644 --- a/R/eval_data.R +++ b/R/eval_data.R @@ -4,12 +4,19 @@ #' @param synth_data A single (or list of) dataframe(s) or `postsynth` object(s). #' @param holdout_data An optional holdout dataframe containing the same columns #' as the confidential dataframe +#' @param synth_vars An optional list of variables synthesized (if not using +#' full synthesis). If `synth_data` uses `postsynth` object(s), then these +#' are inherited from `jth_synthesis_time`. #' #' @return An `eval_data` object. #' #' @export #' -eval_data <- function(conf_data, synth_data, holdout_data = NULL) { +eval_data <- function( + conf_data, + synth_data, + holdout_data = NULL, + synth_vars = NULL) { stopifnot(inherits(conf_data, "data.frame")) @@ -23,7 +30,12 @@ eval_data <- function(conf_data, synth_data, holdout_data = NULL) { # single replicate logic if (is_postsynth(synth_data)) { + synth_vars <- synth_data[["jth_synthesis_time"]] %>% + dplyr::pull("variable") %>% + levels() + synth_data <- synth_data[["synthetic_data"]] + n_rep <- 1 } else if (inherits(synth_data, "data.frame")) { @@ -48,6 +60,10 @@ eval_data <- function(conf_data, synth_data, holdout_data = NULL) { ) ) + synth_vars <- synth_data[[1]][["jth_synthesis_time"]] %>% + dplyr::pull("variable") %>% + levels() + synth_data <- purrr::map( .x = synth_data, .f = ~ .x[["synthetic_data"]] @@ -72,7 +88,8 @@ eval_data <- function(conf_data, synth_data, holdout_data = NULL) { conf_data = conf_data, synth_data = synth_data, holdout_data = holdout_data, - n_rep = n_rep + n_rep = n_rep, + synth_vars = synth_vars ) eval_data <- structure(eval_data, class = "eval_data") @@ -93,6 +110,7 @@ is_eval_data <- function(x) { inherits(x, "eval_data") } + #' @export print.eval_data <- function(x, ...) { diff --git a/R/util_ci_overlap.R b/R/util_ci_overlap.R index 903c131..fb1f3b4 100644 --- a/R/util_ci_overlap.R +++ b/R/util_ci_overlap.R @@ -1,7 +1,7 @@ -#' Regression confidence interval overlap +#' Regression confidence interval overlap for one synthetic data replicate #' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data #' @param formula A formula for a linear regression model #' #' @return A list of two dataframes: @@ -21,37 +21,14 @@ #' synthetic) listing parameter estimates, standard errors, test statistics, #' p-values for null hypothesis tests, and 95% confidence interval bounds. #' -#' @examples -#' conf_data <- mtcars -#' synth_data <- mtcars %>% -#' dplyr::slice_sample(n = nrow(mtcars) / 2) -#' -#' util_ci_overlap( -#' conf_data, -#' synth_data, -#' mpg ~ disp + vs + am -#' ) -#' -#' @family Utility metrics -#' -#' @export -util_ci_overlap <- function(postsynth, data, formula) { +.util_ci_overlap <- function(synth_data, conf_data, formula) { - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - } else { - - synthetic_data <- postsynth - - } # original model ------------------------------------------------------ - lm_original <- stats::lm(formula = formula, data = data) + lm_original <- stats::lm(formula = formula, data = conf_data) # synthetic model --------------------------------------------------------- - lm_synth <- stats::lm(formula = formula, data = synthetic_data) + lm_synth <- stats::lm(formula = formula, data = synth_data) coefficients <- dplyr::bind_rows( `original` = broom::tidy(lm_original, conf.int = TRUE), @@ -100,3 +77,76 @@ util_ci_overlap <- function(postsynth, data, formula) { ) } + +#' Regression confidence interval overlap +#' +#' @param eval_data An `eval_data` object +#' @param formula A formula for a linear regression model +#' +#' @return A list of two dataframes (one per each synthetic data replicate): +#' * `ci_overlap`: one row per model parameter with utility metrics. +#' * `overlap `: symmetric overlap metric, calculated as the average of the +#' interval overlap contained in the synthetic confidence interval and the +#' interval overlap contained in the confidential confidence interval. +#' * `coef_diff`: synthetic parameter estimate - confidential parameter estimate +#' * `std_coef_diff`: `coef_diff` divided by the standard error for the confidential data. +#' * `sign_match`: boolean if the synthetic and confidential parameter estimates have the same sign. +#' * `significance_match`: boolean if the null hypothesis test where the +#' parameter is 0 has p-value less than .05 agrees in both confidential and +#' synthetic data. +#' * `ss`: boolean if both `sign_match` and `significance_match` are true. +#' * `sso`: boolean if `sign_match` is true and `overlap` is positive. +#' * `coef_diff`: one row per model parameter and data source (confidential or +#' synthetic) listing parameter estimates, standard errors, test statistics, +#' p-values for null hypothesis tests, and 95% confidence interval bounds. +#' +#' @family Utility metrics +#' +#' @examples +#' conf_data <- mtcars +#' synth_data <- mtcars %>% +#' dplyr::slice_sample(n = nrow(mtcars) / 2) +#' +#' eval_data <- eval_data(conf_data, synth_data) +#' +#' util_ci_overlap( +#' eval_data, +#' mpg ~ disp + vs + am +#' ) +#' +#' @export +#' +util_ci_overlap <- function(eval_data, formula) { + + stopifnot(is_eval_data(eval_data)) + + if (eval_data$n_rep == 1) { + + return( + .util_ci_overlap( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + formula = formula + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_ci_overlap( + conf_data = eval_data$conf_data, + synth_data = sd, + formula = formula + ) + + } + ) + + return(result) + + } + +} diff --git a/R/util_co_ocurrence.R b/R/util_co_ocurrence.R index 87ae2e4..f040548 100644 --- a/R/util_co_ocurrence.R +++ b/R/util_co_ocurrence.R @@ -1,7 +1,8 @@ -#' Calculate the co-occurrence fit metric of a confidential data set. #' -#' @param postsynth a postsynth object from tidysynthesis or a tibble -#' @param data an original (observed) data set. +#' Compare the co-occurrence fit metric of a confidential and synthetic dataset +#' +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data #' @param na.rm a logical indicating whether missing values should be removed. #' Note: values are jointly removed for each pair of variables even if only one #' value is missing. @@ -17,28 +18,14 @@ #' `co_occurrence_original` and `co_occurrence_synthetic` #' - `co_occurrence_difference_rmse`: Root mean squared error between #' `co_occurrence_original` and `co_occurrence_synthetic` -#' -#' @family utility metrics -#' -#' @export #' -util_co_occurrence <- function(postsynth, data, na.rm = FALSE) { +.util_co_occurrence <- function(synth_data, conf_data, na.rm = FALSE) { - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - } else { - - synthetic_data <- postsynth - - } - - synthetic_data <- dplyr::select_if(synthetic_data, is.numeric) - data <- dplyr::select_if(data, is.numeric) + synth_data <- dplyr::select(synth_data, tidyselect::where(is.numeric)) + conf_data <- dplyr::select(conf_data, tidyselect::where(is.numeric)) # reorder data names - data <- dplyr::select(data, names(synthetic_data)) + conf_data <- dplyr::select(conf_data, names(synth_data)) # helper function to find a co-occurrence matrix with the upper tri set to zeros lower_triangle <- function(x) { @@ -46,7 +33,7 @@ util_co_occurrence <- function(postsynth, data, na.rm = FALSE) { # find the linear co-occurrence matrix of numeric variables from a data set co_occurrence_matrix <- x %>% - dplyr::select_if(is.numeric) %>% + dplyr::select(tidyselect::where(is.numeric)) %>% co_occurrence(na.rm = na.rm) # set the values in the upper triangle to zero to avoid double counting @@ -56,10 +43,10 @@ util_co_occurrence <- function(postsynth, data, na.rm = FALSE) { } # find the lower triangle of the original data linear co_occurrence matrix - original_lt <- lower_triangle(data) + original_lt <- lower_triangle(conf_data) # find the lower triangle of the synthetic data linear co_occurrence matrix - synthetic_lt <- lower_triangle(synthetic_data) + synthetic_lt <- lower_triangle(synth_data) # compare names if (any(rownames(original_lt) != rownames(synthetic_lt))) { @@ -96,4 +83,63 @@ util_co_occurrence <- function(postsynth, data, na.rm = FALSE) { ) ) +} + +#' +#' Compare the co-occurrence fit metric of a confidential and synthetic dataset +#' +#' @param eval_data An `eval_data` object +#' @param na.rm a logical indicating whether missing values should be removed. +#' Note: values are jointly removed for each pair of variables even if only one +#' value is missing. +#' +#' @return A `list` of fit metrics (one per each synthetic data replicate):: +#' - `co_occurrence_original`: co-occurrence matrix of the original data. +#' - `co_occurrence_synthetic`: co-occurrence matrix of the synthetic data. +#' - `co_occurrence_difference`: difference between `co_occurrence_synthetic` and +#' `co_occurrence_original`. +#' `co_occurrence_synthetic` and `co_occurrence_original`, divided by the number of +#' cells in the co-occurrence matrix. +#' - `co_occurrence_difference_mae`: Mean absolute error between +#' `co_occurrence_original` and `co_occurrence_synthetic` +#' - `co_occurrence_difference_rmse`: Root mean squared error between +#' `co_occurrence_original` and `co_occurrence_synthetic` +#' +#' @family Utility metrics +#' +#' @export +#' +util_co_occurrence <- function(eval_data, na.rm = FALSE) { + + stopifnot(is_eval_data(eval_data)) + + if (eval_data$n_rep == 1) { + + return( + .util_co_occurrence( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_co_occurrence( + conf_data = eval_data$conf_data, + synth_data = sd, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + } \ No newline at end of file diff --git a/R/util_corr_fit.R b/R/util_corr_fit.R index 5c21209..1f4b0d5 100644 --- a/R/util_corr_fit.R +++ b/R/util_corr_fit.R @@ -1,7 +1,8 @@ +#' #' Calculate the correlation fit metric of a confidential data set. #' -#' @param postsynth A postsynth object from tidysynthesis or a tibble -#' @param data an original (observed) data set. +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data #' @param use optional character string giving a method for computing #' covariances in the presence of missing values. This must be (an abbreviation #' of) one of the strings "everything", "all.obs", "complete.obs", @@ -15,28 +16,15 @@ #' - `correlation_fit`: square root of the sum of squared differences between #' `correlation_synthetic` and `correlation_original`, divided by the number of #' cells in the correlation matrix. -#' -#' @family utility metrics -#' -#' @export - -util_corr_fit <- function(postsynth, data, use = "everything") { - - if (is_postsynth(postsynth)) { +#' +.util_corr_fit <- function(synth_data, conf_data, use = "everything") { - synthetic_data <- postsynth$synthetic_data - - } else { - - synthetic_data <- postsynth - - } - synthetic_data <- dplyr::select_if(synthetic_data, is.numeric) - data <- dplyr::select_if(data, is.numeric) + synth_data <- dplyr::select(synth_data, tidyselect::where(is.numeric)) + conf_data <- dplyr::select(conf_data, tidyselect::where(is.numeric)) # reorder data names - data <- dplyr::select(data, names(synthetic_data)) + conf_data <- dplyr::select(conf_data, names(synth_data)) # helper function to find a correlation matrix with the upper tri set to zeros lower_triangle <- function(x, use) { @@ -44,7 +32,7 @@ util_corr_fit <- function(postsynth, data, use = "everything") { # find the linear correlation matrix of numeric variables from a data set correlation_matrix <- x %>% - dplyr::select_if(is.numeric) %>% + dplyr::select(tidyselect::where(is.numeric)) %>% stats::cor(use = use) # set the values in the upper triangle to zero to avoid double counting @@ -54,10 +42,10 @@ util_corr_fit <- function(postsynth, data, use = "everything") { } # find the lower triangle of the original data linear correlation matrix - original_lt <- lower_triangle(data, use = use) + original_lt <- lower_triangle(conf_data, use = use) # find the lower triangle of the synthetic data linear correlation matrix - synthetic_lt <- lower_triangle(synthetic_data, use = use) + synthetic_lt <- lower_triangle(synth_data, use = use) # compare names if (any(rownames(original_lt) != rownames(synthetic_lt))) { @@ -101,4 +89,61 @@ util_corr_fit <- function(postsynth, data, use = "everything") { ) ) +} + +#' +#' Calculate the correlation fit metric of a confidential data set. +#' +#' @param eval_data An `eval_data` object +#' @param use optional character string giving a method for computing +#' covariances in the presence of missing values. This must be (an abbreviation +#' of) one of the strings "everything", "all.obs", "complete.obs", +#' "na.or.complete", or "pairwise.complete.obs". +#' +#' @return A `list` of fit metrics (one per each synthetic data replicate): +#' - `correlation_original`: correlation matrix of the original data. +#' - `correlation_synthetic`: correlation matrix of the synthetic data. +#' - `correlation_difference`: difference between `correlation_synthetic` and +#' `correlation_original`. +#' - `correlation_fit`: square root of the sum of squared differences between +#' `correlation_synthetic` and `correlation_original`, divided by the number of +#' cells in the correlation matrix. +#' +#' @family utility metrics +#' +#' @export +#' +util_corr_fit <- function(eval_data, use = "everything") { + + stopifnot(is_eval_data(eval_data)) + + if (eval_data$n_rep == 1) { + + return( + .util_corr_fit( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + use = use + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_corr_fit( + conf_data = eval_data$conf_data, + synth_data = sd, + use = use + ) + + } + ) + + return(result) + + } + } \ No newline at end of file diff --git a/R/util_ks_distance.R b/R/util_ks_distance.R index 19a787a..38c28b1 100644 --- a/R/util_ks_distance.R +++ b/R/util_ks_distance.R @@ -1,40 +1,26 @@ #' Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in #' the synthetic and confidential data #' -#' @param postsynth a postsynth object or tibble with synthetic data -#' @param data a data frame with the original data +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data #' @param na.rm a logical indicating whether missing values should be removed. #' #' @return A tibble with the D and location of the largest distance for each #' numeric variable #' -#' @family Utility metrics -#' -#' @export -#' -util_ks_distance <- function(postsynth, data, na.rm = FALSE) { - - if ("postsynth" %in% class(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - } else { - - synthetic_data <- postsynth - - } +.util_ks_distance <- function(synth_data, conf_data, na.rm = FALSE) { # drop non-numeric variables - data <- data %>% + conf_data <- conf_data %>% dplyr::select(tidyselect::where(is.numeric)) - synthetic_data <- synthetic_data %>% + synth_data <- synth_data %>% dplyr::select(tidyselect::where(is.numeric)) # find common variables - variables <- intersect(names(synthetic_data), names(data)) + variables <- intersect(names(synth_data), names(conf_data)) - var_not_in_synthetic <- setdiff(names(data), names(synthetic_data)) + var_not_in_synthetic <- setdiff(names(conf_data), names(synth_data)) if (length(var_not_in_synthetic) > 0) { warning("The following variables are in the confidential data but not the synthetic data: ", @@ -42,7 +28,7 @@ util_ks_distance <- function(postsynth, data, na.rm = FALSE) { } - var_not_in_conf <- setdiff(names(synthetic_data), names(data)) + var_not_in_conf <- setdiff(names(synth_data), names(conf_data)) if (length(var_not_in_conf) > 0) { warning("The following variables are in the synthetic data but not the confidential data: ", @@ -56,8 +42,8 @@ util_ks_distance <- function(postsynth, data, na.rm = FALSE) { names(distances) <- variables for (var in variables) { - var_synth <- dplyr::pull(synthetic_data, var) - var_data <- dplyr::pull(data, var) + var_synth <- dplyr::pull(synth_data, var) + var_data <- dplyr::pull(conf_data, var) # drop missing values if (na.rm) { @@ -100,4 +86,52 @@ util_ks_distance <- function(postsynth, data, na.rm = FALSE) { return(D) +} + +#' Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in +#' the synthetic and confidential data +#' +#' @param eval_data An `eval_data` object +#' @param na.rm a logical indicating whether missing values should be removed. +#' +#' @return A tibble with the D and location of the largest distance for each +#' numeric variable, one per synthetic data replicate +#' +#' @family Utility metrics +#' +#' @export +#' +util_ks_distance <- function(eval_data, na.rm = FALSE) { + + stopifnot(is_eval_data(eval_data)) + + if (eval_data$n_rep == 1) { + + return( + .util_ks_distance( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_ks_distance( + conf_data = eval_data$conf_data, + synth_data = sd, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + } \ No newline at end of file diff --git a/R/util_moments.R b/R/util_moments.R index 0a047db..4a4755f 100644 --- a/R/util_moments.R +++ b/R/util_moments.R @@ -1,98 +1,64 @@ #' Calculate summary statistics for original and synthetic data. #' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data -#' @param weight_var An unquoted name of a weight variable -#' @param group_by The unquoted name of a (or multiple) grouping variable(s) +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data +#' @param weight_var_q A quoted name of a weight variable +#' @param group_by_q The quoted name(s) of a (or multiple) grouping variable(s) #' @param drop_zeros A logical for if zeros should be dropped #' @param common_vars A logical for if only common variables should be kept -#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param synth_varnames A list of variables synthesized to filter on, else `NULL` #' @param na.rm A logical for ignoring `NA` values in computations. #' #' @return A `tibble` of summary statistics. #' -#' @family utility metrics -#' -#' @export -#' -util_moments <- function(postsynth, - data, - weight_var = 1, - group_by = NULL, - drop_zeros = FALSE, - common_vars = TRUE, - synth_vars = TRUE, - na.rm = FALSE) { +.util_moments <- function( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE) { # catch binding error . <- NULL - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - variable_order <- - levels(postsynth$jth_synthesis_time$variable) - - # filter to only synthesized variables - # keep group_by variables - if (synth_vars) { - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - data <- data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - } - - } else { - - synthetic_data <- postsynth - - } - - # only keep variables in both data sets - # keep group_by variables - if (common_vars) { - - common_vars <- intersect(names(data), names(synthetic_data)) - - data <- data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) - - } - - # drop non-numeric variables - data <- data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - synthetic_data <- synthetic_data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - # combine both data sources - combined_data <- dplyr::bind_rows( - `original` = data, - `synthetic` = synthetic_data, - .id = "source" + # create combined data + combined_data <- .create_combined_data_pointwise( + synth_data = synth_data, + conf_data = conf_data, + group_by_q = group_by_q, + weight_var_q = weight_var_q, + common_vars = common_vars, + synth_varnames = synth_varnames ) # prep data for NA handling - combined_data <- prep_combined_data_for_na.rm( + combined_data <- .prep_combined_data_for_na.rm_q( combined_data, na.rm = na.rm, drop_zeros = drop_zeros, - drop_zeros_exclude = group_by + drop_zeros_exclude = group_by_q ) na.rm_flag <- (na.rm | drop_zeros) + # add weight var + if (weight_var_q == "NULL") { + + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = 1) + + } else { + + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = .data[[weight_var_q]]) + + } + # calculate summary statistics summary_stats <- combined_data %>% - dplyr::mutate(.temp_weight = {{ weight_var }}) %>% - dplyr::group_by(source, dplyr::across({{ group_by }})) %>% + dplyr::group_by(source, dplyr::across(dplyr::all_of(group_by_q))) %>% dplyr::summarise( dplyr::across( .cols = -".temp_weight", @@ -105,7 +71,7 @@ util_moments <- function(postsynth, ) ) ) %>% - tidyr::gather(key = "variable", value = "value", -source, - {{ group_by }}) %>% + tidyr::gather(key = "variable", value = "value", -source, -dplyr::any_of(group_by_q)) %>% tidyr::separate(col = .data$variable, into = c("variable", "statistic"), sep = "_(?!.*_)") %>% @@ -121,9 +87,7 @@ util_moments <- function(postsynth, statistics_order <- c("count", "mean", "sd", "skewness", "kurtosis") - # sort table by synthesis order and keep factor levels for variables that - # weren't synthesized - if (!is_postsynth(postsynth)) { + if (is.null(synth_varnames)) { variable_order <- names(dplyr::select(combined_data, -source)) @@ -131,9 +95,9 @@ util_moments <- function(postsynth, all_vars <- names(dplyr::select(combined_data, -source)) - other_vars <- setdiff(all_vars, variable_order) + other_vars <- setdiff(all_vars, synth_varnames) - variable_order <- c(variable_order, other_vars) + variable_order <- c(synth_varnames, other_vars) } @@ -147,3 +111,81 @@ util_moments <- function(postsynth, return(summary_stats) } + + + +#' Calculate summary statistics for original and synthetic data. +#' +#' @param eval_data An `eval_data` object +#' @param weight_var An unquoted name of a weight variable +#' @param group_by The unquoted name of a (or multiple) grouping variable(s) +#' @param drop_zeros A logical for if zeros should be dropped +#' @param common_vars A logical for if only common variables should be kept +#' @param synth_vars A logical for if *only* synthesized variables should be kept +#' @param na.rm A logical for ignoring `NA` values in computations. +#' +#' @return A `tibble` of summary statistics. +#' +#' @family utility metrics +#' +#' @export +#' +#' +util_moments <- function( + eval_data, + weight_var = NULL, + group_by = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_vars = TRUE, + na.rm = FALSE) { + + stopifnot(is_eval_data(eval_data)) + + # argument parsing + weight_var_q <- base::deparse(rlang::enexpr(weight_var)) + group_by_q <- purrr::map_chr(as.list(rlang::enexpr(group_by)), base::deparse) + group_by_q <- group_by_q[2:length(group_by_q)] %>% purrr::discard(is.na) + synth_varnames <- if (identical(synth_vars, TRUE)) eval_data$synth_vars else NULL + + if (eval_data$n_rep == 1) { + + return( + .util_moments( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + drop_zeros = drop_zeros, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_moments( + conf_data = eval_data$conf_data, + synth_data = sd, + weight_var_q = weight_var, + group_by_q = group_by, + drop_zeros = drop_zeros, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + +} + diff --git a/R/util_na_helper.R b/R/util_na_helper.R index c0e3bb7..ef80ebc 100644 --- a/R/util_na_helper.R +++ b/R/util_na_helper.R @@ -70,6 +70,136 @@ prep_combined_data_for_na.rm <- function( } +#' +#' Check whether na.rm is compatible with univariate utilty metrics +#' +#' @param combined_data A data frame or tibble +#' @param na.rm A boolean for whether to ignore missing values +#' @param drop_zeros A boolean for whether to ignore zero values in utility metrics +#' @param drop_zeros_exclude An optional set of quoted columns on which to drop zeros +#' +#' @return A data frame or tibble with missing and/or zero values set to NA +#' +.prep_combined_data_for_na.rm_q <- function( + combined_data, + na.rm = FALSE, + drop_zeros = FALSE, + drop_zeros_exclude = NULL) { + + # raise warning if missing values present + if (na.rm == FALSE) { + + na_cols <- combined_data %>% + purrr::map_lgl(.f = ~ any(is.na(.x))) + + if (any(na_cols)) { + + message( + paste( + "Some variables contain missing data: ", + paste(names(combined_data)[na_cols], collapse=", ") + ) + ) + + # stop if drop_zeros incompatible with keeping NAs + if (drop_zeros) { + + stop("Cannot set na.rm == FALSE and drop_zeros == TRUE with missing data") + + } + + } + + } + + if (drop_zeros) { + + if (is.null(drop_zeros_exclude)) { + + combined_data[combined_data == 0] <- NA + + } + + else { + + combined_data <- combined_data %>% + dplyr::mutate( + dplyr::across( + -dplyr::any_of(drop_zeros_exclude), + \(x) { + dplyr::if_else(x == 0, NA, x) + } + ) + ) + + } + + } + + return(combined_data) + +} + + +#' +#' Convert `NA` values to `"NA"` for categorical variables +#' +#' @param data A data frame or tibble +#' +#' @return A data frame or tibble with `NA` converted to `"NA"` +#' +#' @export +#' +convert_na_to_level <- function(data) { + + na_to_level <- function(x) { + + # do nothing if x isn't a character or factor + if (!pillar::type_sum(x) %in% c("chr", "ord", "fct")) return(x) + + # test if NA is already a level + if (sum(x == "NA", na.rm = TRUE) > 0) { + stop("ERROR: can't convert NA to 'NA' because 'NA' already exists") + } + + # replace `NA` with `"NA"` + if (all(!is.na(x))) { + + return(x) + + } else if (pillar::type_sum(x) == "chr") { + + x <- tidyr::replace_na(data = x, replace = "NA") + + } else if (pillar::type_sum(x) %in% c("ord", "fct")) { + + ordinal_flag <- pillar::type_sum(x) == "ord" + + # store the factor levels + x_levels <- c(levels(x), "NA") + + # convert to character and replace the NA + x_chr <- as.character(x) + + x_chr <- tidyr::replace_na(data = x_chr, replace = "NA") + + # convert back to a factor + x <- factor(x_chr, levels = x_levels, ordered = ordinal_flag) + + } + + return(x) + + } + + data_converted <- data %>% + dplyr::mutate(dplyr::across(.cols = dplyr::everything(), .fns = na_to_level)) + + return(data_converted) + +} + + #' #' Convert `NA` values to `"NA"` for categorical variables diff --git a/R/util_nse_helper.R b/R/util_nse_helper.R new file mode 100644 index 0000000..db15156 --- /dev/null +++ b/R/util_nse_helper.R @@ -0,0 +1,94 @@ +#' +#' Create combined data for pointwise utility statistic evaluation +#' +#' @param synth_data A synthetic data.frame +#' @param conf_data A confidential data.frame +#' @param keep_numeric A boolean, if TRUE keeps only numeric variables, else keeps +#' factors and characters. Defaults to TRUE. +#' @param weight_var_q A quoted name of a weight variable +#' @param group_by_q The quoted name(s) of a (or multiple) grouping variable(s) +#' @param common_vars A logical for if only common variables should be kept +#' @param synth_varnames A list of variables synthesized to filter on, else `NULL` +#' +#' @return A tibble +#' +.create_combined_data_pointwise <- function( + synth_data, + conf_data, + keep_numeric = TRUE, + group_by_q = NULL, + weight_var_q = NULL, + common_vars = FALSE, + synth_varnames = NULL) { + + # if provided, filter to synthesized variables + if (!is.null(synth_varnames)) { + + synthetic_data <- synth_data %>% + dplyr::select(dplyr::all_of(synth_varnames), + dplyr::any_of(group_by_q), + dplyr::any_of(weight_var_q)) + + data <- conf_data %>% + dplyr::select(dplyr::all_of(synth_varnames), + dplyr::any_of(group_by_q), + dplyr::any_of(weight_var_q)) + + } else { + + synthetic_data <- synth_data + data <- conf_data + + } + + # only keep variables in both data sets + # keep group_by variables + if (common_vars) { + + common_var_names <- intersect(names(data), names(synthetic_data)) + + data <- data %>% + dplyr::select(dplyr::all_of(common_var_names), + dplyr::any_of(c(group_by_q, weight_var_q))) + + synthetic_data <- synthetic_data %>% + dplyr::select(dplyr::all_of(common_var_names), + dplyr::any_of(c(group_by_q, weight_var_q))) + + } + + if (keep_numeric) { + # drop non-numeric variables + data <- data %>% + dplyr::select(tidyselect::where(is.numeric), + dplyr::any_of(c(group_by_q, weight_var_q))) + + synthetic_data <- synthetic_data %>% + dplyr::select(tidyselect::where(is.numeric), + dplyr::any_of(c(group_by_q, weight_var_q))) + + } else { + + # drop non-factor variables + data <- data %>% + dplyr::select(tidyselect::where(is.factor), + tidyselect::where(is.character), + dplyr::any_of(c(group_by_q, weight_var_q))) + + synthetic_data <- synthetic_data %>% + dplyr::select(tidyselect::where(is.factor), + tidyselect::where(is.character), + dplyr::any_of(c(group_by_q, weight_var_q))) + + } + + # combine both data sources + combined_data <- dplyr::bind_rows( + `original` = data, + `synthetic` = synthetic_data, + .id = "source" + ) + + return(combined_data) + +} \ No newline at end of file diff --git a/R/util_percentiles.R b/R/util_percentiles.R index 771501b..c3a3a8b 100644 --- a/R/util_percentiles.R +++ b/R/util_percentiles.R @@ -1,106 +1,59 @@ #' Calculate summary statistics for original and synthetic data. #' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data #' @param probs A numeric vector of probabilities with values in \[0,1\]. The #' percentiles are interpolated using an empirical CDF. It's possible that the #' percentiles are an approximation; especially when weights are used. -#' @param group_by An unquoted name of a (or multiple) grouping variable(s) -#' @param weight_var An unquoted name of a weight variable +#' @param weight_var_q A quoted name of a weight variable +#' @param group_by_q The quoted name(s) of a (or multiple) grouping variable(s) #' @param drop_zeros A Boolean for if zeros should be dropped #' @param common_vars A logical for if only common variables should be kept. #' This option will frequently result in an error because quantile() is strict #' about missing values. -#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param synth_varnames A list of variables synthesized to filter on, else `NULL` #' @param na.rm A logical for ignoring `NA` values in computations. #' #' @return A `tibble` of summary statistics. #' -#' @family utility metrics -#' -#' @export -#' -util_percentiles <- function(postsynth, - data, - probs = c(0.1, 0.5, 0.9), - weight_var = NULL, - group_by = NULL, - drop_zeros = FALSE, - common_vars = TRUE, - synth_vars = TRUE, - na.rm = FALSE) { +.util_percentiles <- function( + synth_data, + conf_data, + probs = c(0.1, 0.5, 0.9), + weight_var_q = NULL, + group_by_q = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE) { # catch binding error . <- NULL - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - variable_order <- - levels(postsynth$jth_synthesis_time$variable) - - # filter to only synthesized variables - # keep group_by variables - if (synth_vars) { - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - data <- data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - } - - } else { - - synthetic_data <- postsynth - - } - - # only keep variables in both data sets - # keep group_by variables - if (common_vars) { - - common_vars <- intersect(names(data), names(synthetic_data)) - - data <- data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) - - } - - # drop non-numeric variables except grouping variables - data <- data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - synthetic_data <- synthetic_data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - # combine both data sources - combined_data <- dplyr::bind_rows( - `original` = data, - `synthetic` = synthetic_data, - .id = "source" + # create combined data + combined_data <- .create_combined_data_pointwise( + synth_data = synth_data, + conf_data = conf_data, + group_by_q = group_by_q, + weight_var_q = weight_var_q, + common_vars = common_vars, + synth_varnames = synth_varnames ) - # prep data for NA handling - combined_data <- prep_combined_data_for_na.rm( + combined_data <- .prep_combined_data_for_na.rm_q( combined_data, na.rm = na.rm, drop_zeros = drop_zeros, - drop_zeros_exclude = group_by + drop_zeros_exclude = group_by_q ) na.rm_flag <- (na.rm | drop_zeros) - # set weight to 1 for unweighted statistics - if (missing(weight_var)) { - + # add weight var + if (weight_var_q == "NULL") { + summary_stats <- combined_data %>% - dplyr::group_by(source, dplyr::across({{ group_by }})) %>% + dplyr::group_by(source, dplyr::across(dplyr::all_of(group_by_q))) %>% dplyr::reframe( dplyr::across( .cols = dplyr::everything(), @@ -115,36 +68,35 @@ util_percentiles <- function(postsynth, dplyr::select("p", dplyr::everything()) %>% dplyr::ungroup() %>% tidyr::gather(key = "variable", value = "value", -"source", -"p", - -{{ group_by }}) %>% + -dplyr::all_of(group_by_q)) %>% tidyr::spread(key = source, value = .data$value) %>% dplyr::arrange(.data$variable) - + } else { - - summary_stats <- combined_data %>% - dplyr::group_by(source, dplyr::across({{ group_by }})) %>% - dplyr::reframe( - dplyr::across( - .cols = dplyr::everything(), - .fns = ~ Hmisc::wtd.quantile( - x = ., - weights = {{ weight_var }}, - probs = probs, - na.rm = na.rm_flag - ) - ), - p = probs - ) %>% - dplyr::select("p", dplyr::everything()) %>% - dplyr::ungroup() %>% - tidyr::gather(key = "variable", value = "value", -"source", -"p", - -{{ group_by }}) %>% - tidyr::spread(key = source, value = .data$value) %>% - dplyr::arrange(.data$variable) + summary_stats <- combined_data %>% + dplyr::mutate(.temp_weight = .data[[weight_var_q]]) %>% + dplyr::group_by(source, dplyr::across(dplyr::all_of(group_by_q))) %>% + dplyr::reframe( + dplyr::across( + .cols = dplyr::everything(), + .fns = ~ Hmisc::wtd.quantile( + x = ., + weights = !!rlang::sym(".temp_weight"), + probs = probs, + na.rm = na.rm_flag + ) + ), + p = probs + ) %>% + dplyr::select("p", dplyr::everything()) %>% + dplyr::ungroup() %>% + tidyr::gather(key = "variable", value = "value", -"source", -"p", + -dplyr::all_of(group_by_q)) %>% + tidyr::spread(key = source, value = .data$value) %>% + dplyr::arrange(.data$variable) } - - + summary_stats <- summary_stats %>% dplyr::mutate( difference = .data$synthetic - .data$original, @@ -153,7 +105,7 @@ util_percentiles <- function(postsynth, # sort table by synthesis order and keep factor levels for variables that # weren't synthesized - if (!is_postsynth(postsynth)) { + if (is.null(synth_varnames)) { variable_order <- names(dplyr::select(combined_data, -source)) @@ -161,9 +113,9 @@ util_percentiles <- function(postsynth, all_vars <- names(dplyr::select(combined_data, -source)) - other_vars <- setdiff(all_vars, variable_order) + other_vars <- setdiff(all_vars, synth_varnames) - variable_order <- c(variable_order, other_vars) + variable_order <- c(synth_varnames, other_vars) } @@ -171,8 +123,92 @@ util_percentiles <- function(postsynth, dplyr::mutate( variable = factor(.data$variable, levels = variable_order), ) %>% - dplyr::arrange(.data$variable, .data$p) + dplyr::arrange(.data$variable, .data$p) %>% + dplyr::filter(dplyr::if_all(.cols = dplyr::all_of("variable"), + .fns = \(x) { !is.na(x) })) return(summary_stats) } + +#' Calculate summary statistics for original and synthetic data. +#' +#' @param eval_data An `eval_data` object. +#' @param probs A numeric vector of probabilities with values in \[0,1\]. The +#' percentiles are interpolated using an empirical CDF. It's possible that the +#' percentiles are an approximation; especially when weights are used. +#' @param weight_var An unquoted name of a weight variable +#' @param group_by The unquoted name(s) of a (or multiple) grouping variable(s) +#' @param drop_zeros A Boolean for if zeros should be dropped +#' @param common_vars A logical for if only common variables should be kept. +#' This option will frequently result in an error because quantile() is strict +#' about missing values. +#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param na.rm A logical for ignoring `NA` values in computations. +#' +#' @return A `tibble` of summary statistics (one per synthetic data replicate) +#' +#' @family utility metrics +#' +#' @export +#' +util_percentiles <- function( + eval_data, + probs = c(0.1, 0.5, 0.9), + weight_var = NULL, + group_by = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_vars = TRUE, + na.rm = FALSE) { + + stopifnot(is_eval_data(eval_data)) + + # argument parsing + weight_var_q <- base::deparse(rlang::enexpr(weight_var)) + group_by_q <- purrr::map_chr(as.list(rlang::enexpr(group_by)), base::deparse) + group_by_q <- group_by_q[2:length(group_by_q)] %>% purrr::discard(is.na) + synth_varnames <- if (identical(synth_vars, TRUE)) eval_data$synth_vars else NULL + + if (eval_data$n_rep == 1) { + + return( + .util_percentiles( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + probs = probs, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + drop_zeros = drop_zeros, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_percentiles( + conf_data = eval_data$conf_data, + synth_data = sd, + probs = probs, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + drop_zeros = drop_zeros, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + +} \ No newline at end of file diff --git a/R/util_plots.R b/R/util_plots.R index f3cb667..f40017f 100644 --- a/R/util_plots.R +++ b/R/util_plots.R @@ -1,7 +1,6 @@ #' Create a histogram + KDE estimate for a numeric variable. #' -#' @param joint_data A data.frame combining rows from confidential and synthetic -#' data, with the column 'source' identifying the two. +#' @param eval_data An `eval_data` object. #' @param var_name Numeric variable name to plot. #' @param cat1_name Optional categorical variable to group by for subplots. #' @param cat2_name Optional categorical variable to group by for subplots. @@ -9,11 +8,20 @@ #' @return A `ggplot2` plot #' #' @export -plot_numeric_hist_kde <- function(joint_data, +plot_numeric_hist_kde <- function(eval_data, var_name, cat1_name = NULL, cat2_name = NULL) { + stopifnot(is_eval_data(eval_data)) + + # construct joint_data + joint_data <- dplyr::bind_rows( + confidential = eval_data[["conf_data"]], + synthetic = eval_data[["synth_data"]], + .id = "source" + ) + # check data types stopifnot(pillar::type_sum(joint_data[[var_name]]) == "dbl") @@ -78,8 +86,7 @@ plot_numeric_hist_kde <- function(joint_data, #' Create bar charts for a categorical random variable. #' -#' @param joint_data A data.frame combining rows from confidential and synthetic -#' data, with the column 'source' identifying the two. +#' @param eval_data An `eval_data` object. #' @param var_name Categorical variable name to plot. #' @param cat1_name Optional categorical variable to group by for subplots. #' @param cat2_name Optional categorical variable to group by for subplots. @@ -87,11 +94,20 @@ plot_numeric_hist_kde <- function(joint_data, #' @return A `ggplot2` plot #' #' @export -plot_categorical_bar <- function(joint_data, +plot_categorical_bar <- function(eval_data, var_name, cat1_name = NULL, cat2_name = NULL) { + stopifnot(is_eval_data(eval_data)) + + # construct joint_data + joint_data <- dplyr::bind_rows( + confidential = eval_data[["conf_data"]], + synthetic = eval_data[["synth_data"]], + .id = "source" + ) + # check data types stopifnot(pillar::type_sum(joint_data[[var_name]]) == "fct") @@ -203,20 +219,23 @@ create_cormat_plot <- function(data, cor_method = "pearson") { #' Create side-by-side correlation heatmaps for numeric random variables. #' -#' @param conf_data Confidential data -#' @param synth_data Synthetic data +#' @param eval_data An `eval_data` object. #' @param cor_method A correlation method to pass to `stats::cor(., method=)` -#' +#' #' @return A `ggplot2` plot -#' +#' #' @export -plot_cormat <- function(conf_data, synth_data, cor_method = "pearson") { - - p1 <- create_cormat_plot(conf_data, cor_method = cor_method) + +plot_cormat <- function(eval_data, cor_method = "pearson") { + + stopifnot(is_eval_data(eval_data)) + + p1 <- create_cormat_plot(eval_data[["conf_data"]], cor_method = cor_method) + ggplot2::ggtitle("Confidential data") - p2 <- create_cormat_plot(synth_data, cor_method = cor_method) + + p2 <- create_cormat_plot(eval_data[["synth_data"]], cor_method = cor_method) + ggplot2::ggtitle("Synthetic data") - - gridExtra::grid.arrange(p1, p2, nrow=1) - + + plot <- gridExtra::grid.arrange(p1, p2, nrow = 1) + + return(plot) + } diff --git a/R/util_proportions.R b/R/util_proportions.R index 4dd1e3b..dac735d 100644 --- a/R/util_proportions.R +++ b/R/util_proportions.R @@ -1,136 +1,58 @@ #' Calculate relative frequency tables for categorical variables #' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data -#' @param weight_var An unquoted name of a weight variable -#' @param group_by An unquoted name of a (or multiple) grouping variable(s) +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data +#' @param weight_var_q A quoted name of a weight variable +#' @param group_by_q The quoted name(s) of a (or multiple) grouping variable(s) #' @param common_vars A logical for if only common variables should be kept -#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param synth_varnames A list of variables synthesized to filter on, else `NULL` #' @param keep_empty_levels A logical for keeping all class levels in the group_by #' statements, including missing levels. #' @param na.rm A logical for ignoring `NA` values in proportion calculations. #' #' @return A tibble with variables, classes, and relative frequencies -#' -#' @family Utility metrics -#' -#' @export #' -util_proportions <- function(postsynth, - data, - weight_var = NULL, - group_by = NULL, - common_vars = TRUE, - synth_vars = TRUE, - keep_empty_levels = FALSE, - na.rm = FALSE) { +.util_proportions <- function( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + common_vars = TRUE, + synth_varnames = TRUE, + keep_empty_levels = FALSE, + na.rm = FALSE) { + combined_data <- .create_combined_data_pointwise( + synth_data = synth_data, + conf_data = conf_data, + keep_numeric = FALSE, + group_by_q = group_by_q, + weight_var_q = weight_var_q, + common_vars = common_vars, + synth_varnames = synth_varnames) - if (is_postsynth(postsynth)) { + # add weight var + if (weight_var_q == "NULL") { - synthetic_data <- postsynth$synthetic_data - - variable_order <- - levels(postsynth$jth_synthesis_time$variable) + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = 1) } else { - synthetic_data <- postsynth - - } - - # the goal is to create .temp_weight that is equal to 1 if weight_var isn't - # specified and equal to the weight if weight_var is a variable - synthetic_weight <- synthetic_data %>% - dplyr::select({{ weight_var }}) %>% - dplyr::mutate(.temp_weight = {{ weight_var }}) %>% - dplyr::select(-{{ weight_var }}) - - # if {{ weight }} is NULL then set the weight to 1 - if (ncol(synthetic_weight) == 0) { - - synthetic_weight <- synthetic_data %>% - dplyr::mutate(.temp_weight = 1) %>% - dplyr::select(".temp_weight") - - } - - data_weight <- data %>% - dplyr::select({{ weight_var }}) %>% - dplyr::mutate(.temp_weight = {{ weight_var }}) %>% - dplyr::select(-{{ weight_var }}) - - # if {{ weight }} is NULL then set the weight to 1 - if (ncol(data_weight) == 0) { - - data_weight <- data_weight %>% - dplyr::mutate(.temp_weight = 1) %>% - dplyr::select(".temp_weight") + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = .data[[weight_var_q]]) %>% + dplyr::select(-dplyr::all_of(weight_var_q)) } - # combine the weight variable df to the synthetic data - synthetic_data <- synthetic_data %>% - dplyr::bind_cols(synthetic_weight) %>% - dplyr::select(-{{ weight_var }}) - - # combine the weight variable df to the confidential data - data <- data %>% - dplyr::bind_cols(data_weight) %>% - dplyr::select(-{{ weight_var }}) - - # filter to only synthesized variables - # keep group_by variables - if (is_postsynth(postsynth) & synth_vars) { - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}, ".temp_weight") - - data <- data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}, ".temp_weight") - - } - - # only keep variables in both data sets - # keep group_by variables - if (common_vars) { - - common_vars <- intersect(names(data), names(synthetic_data)) - - data <- data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}, ".temp_weight") - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}, ".temp_weight") - - } - - # dropping columns that are numeric (excluding the weight variable) - synthetic_data <- synthetic_data %>% - dplyr::select(tidyselect::where(is.factor), - tidyselect::where(is.character), - ".temp_weight") - - data <- data %>% - dplyr::select(tidyselect::where(is.factor), - tidyselect::where(is.character), - ".temp_weight") - - # combining confidential and synthetic data - combined_data <- dplyr::bind_rows( - synthetic = synthetic_data, - original = data, - .id = "source" - ) - group_by_weights <- combined_data %>% tidyr::pivot_longer( - cols = -c(source, {{ group_by }}, ".temp_weight"), + cols = -dplyr::all_of(c("source", group_by_q, ".temp_weight")), names_to = "variable", values_to = "class" ) %>% dplyr::group_by( - dplyr::across({{ group_by }}), source, variable, + dplyr::across(dplyr::all_of(c(group_by_q, "source", "variable"))), .drop = !keep_empty_levels ) @@ -140,7 +62,7 @@ util_proportions <- function(postsynth, # lengthening combined data to find proportions for each level combined_data_long <- combined_data %>% tidyr::pivot_longer( - cols = -c(source, {{ group_by }}, ".temp_weight"), + cols = -dplyr::all_of(c("source", group_by_q, ".temp_weight")), names_to = "variable", values_to = "class" ) @@ -152,7 +74,7 @@ util_proportions <- function(postsynth, # empty levels (excludes variables in group_by, excluded by common_vars, etc) prop_col_names <- names( combined_data %>% - dplyr::select(-c(source, {{ group_by }}, ".temp_weight")) + dplyr::select(-dplyr::all_of(c("source", group_by_q, ".temp_weight"))) ) extract_levels <- function(x) { @@ -187,18 +109,18 @@ util_proportions <- function(postsynth, # by cross-joining dplyr::cross_join( combined_data %>% - dplyr::select(c(source, {{ group_by }})) %>% + dplyr::select(dplyr::all_of(c("source", group_by_q))) %>% dplyr::distinct() ) # create the join specification depending on whether group_by is specified - if (is.null(group_by)) { + if (identical(group_by_q, character(0))) { - join_spec <- dplyr::join_by(class, variable, source) + join_spec <- dplyr::join_by(class, "variable", source) } else { - join_spec <- dplyr::join_by(class, variable, source, {{ group_by }}) + join_spec <- dplyr::join_by(class, "variable", source, group_by_q) } @@ -231,7 +153,7 @@ util_proportions <- function(postsynth, # calculating proportions for each level of each variable combined_data <- combined_data %>% dplyr::group_by( - dplyr::across({{ group_by }}), + dplyr::across(dplyr::all_of(group_by_q)), .data$source, .data$variable, .data$class, @@ -245,7 +167,7 @@ util_proportions <- function(postsynth, combined_data <- combined_data %>% tidyr::pivot_wider(names_from = source, values_from = "prop") %>% dplyr::group_by( - dplyr::across({{ group_by }}), + dplyr::across(dplyr::all_of(group_by_q)), .data$variable, .data$class, .drop = !keep_empty_levels @@ -258,4 +180,81 @@ util_proportions <- function(postsynth, # (group_by) -- variable -- class -- original -- synthetic -- difference return(combined_data) +} + +#' +#' Calculate relative frequency tables for categorical variables +#' +#' @param eval_data An `eval_data` object +#' @param weight_var An unquoted name of a weight variable +#' @param group_by The unquoted name(s) of a (or multiple) grouping variable(s) +#' @param common_vars A logical for if only common variables should be kept +#' @param synth_vars A logical for if *only* synthesized variables should be kept +#' @param keep_empty_levels A logical for keeping all class levels in the group_by +#' statements, including missing levels. +#' @param na.rm A logical for ignoring `NA` values in proportion calculations. +#' +#' @return A tibble with variables, classes, and relative frequencies +#' +#' @family Utility metrics +#' +#' @export +#' +util_proportions <- function( + eval_data, + weight_var = NULL, + group_by = NULL, + common_vars = TRUE, + synth_vars = TRUE, + keep_empty_levels = FALSE, + na.rm = FALSE +) { + + stopifnot(is_eval_data(eval_data)) + + # argument parsing + weight_var_q <- base::deparse(rlang::enexpr(weight_var)) + group_by_q <- purrr::map_chr(as.list(rlang::enexpr(group_by)), base::deparse) + group_by_q <- group_by_q[2:length(group_by_q)] %>% purrr::discard(is.na) + synth_varnames <- if (identical(synth_vars, TRUE)) eval_data$synth_vars else NULL + + if (eval_data$n_rep == 1) { + + return( + .util_proportions( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + common_vars = common_vars, + synth_varnames = synth_varnames, + keep_empty_levels = keep_empty_levels, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_proportions( + conf_data = eval_data$conf_data, + synth_data = sd, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + common_vars = common_vars, + synth_varnames = synth_varnames, + keep_empty_levels = keep_empty_levels, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + } \ No newline at end of file diff --git a/R/util_tails.R b/R/util_tails.R deleted file mode 100644 index 66bd14a..0000000 --- a/R/util_tails.R +++ /dev/null @@ -1,94 +0,0 @@ -#' Explore the tails of numeric variables -#' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data -#' @param n The number of observations to consider for each variable -#' @param weight_var An unquoted name of a weight variable -#' @param end "min" for minimum values and "max" for maximum values -#' -#' @return A `tibble` of summary statistics. -#' -#' @family utility metrics -#' -#' @export -#' -util_tails <- function(postsynth, - data, - n = 10, - weight_var = 1, - end = "max") { - - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - variable_order <- - levels(postsynth$jth_synthesis_time$variable) - - } else { - - synthetic_data <- postsynth - - } - - # drop non-numeric variables - data <- data %>% - dplyr::select_if(is.numeric) - - synthetic_data <- synthetic_data %>% - dplyr::select_if(is.numeric) - - # combine both data sources - combined_data <- dplyr::bind_rows( - `original` = data, - `synthetic` = synthetic_data, - .id = "source" - ) - - # pivot longer - long_data <- combined_data %>% - tidyr::pivot_longer( - cols = -c(source, {{ weight_var }}), - names_to = "variable", - values_to = ".value" - ) - - # multiple values by weight - long_data <- long_data %>% - dplyr::mutate(.weighted_value = .data$.value * {{ weight_var }}) - - # calculate proportion of total contained in each observation - long_data <- long_data %>% - dplyr::group_by(source, .data$variable) %>% - dplyr::mutate(.weighted_prop = .data$.weighted_value / sum(.data$.weighted_value)) %>% - dplyr::ungroup() - - # keep top n - if (end == "max") { - - long_data <- long_data %>% - dplyr::group_by(source, .data$variable) %>% - dplyr::slice_max(.data$.weighted_value, n = n, with_ties = FALSE) %>% - dplyr::ungroup() - - } else if (end == "min") { - - long_data <- long_data %>% - dplyr::group_by(source, .data$variable) %>% - dplyr::slice_min(.data$.weighted_value, n = n, with_ties = FALSE) %>% - dplyr::ungroup() - - } - - # add rank and cumulative proportion variable - long_data <- long_data %>% - dplyr::group_by(source, .data$variable) %>% - dplyr::mutate( - .rank = dplyr::row_number(), - .cumulative_prop = cumsum(.data$.weighted_prop) - ) %>% - dplyr::ungroup() - - return(long_data) - -} diff --git a/R/util_totals.R b/R/util_totals.R index 88d7f49..67597a2 100644 --- a/R/util_totals.R +++ b/R/util_totals.R @@ -1,87 +1,53 @@ #' Calculate totals for original and synthetic data. #' -#' @param postsynth A postsynth object or tibble with synthetic data -#' @param data A data frame with the original data -#' @param weight_var An unquoted name of a weight variable -#' @param group_by The unquoted name of a (or multiple) grouping variable(s) +#' @param synth_data A data.frame with synthetic data +#' @param conf_data A data.frame with the confidential data +#' @param weight_var_q A quoted name of a weight variable +#' @param group_by_q The quoted name(s) of a (or multiple) grouping variable(s) #' @param common_vars A logical for if only common variables should be kept -#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param synth_varnames A list of variables synthesized to filter on, else `NULL` #' @param na.rm A logical for ignoring `NA` values in computations. #' #' @return A `tibble` of totals. #' -#' @family utility metrics -#' -#' @export -#' -util_totals<- function(postsynth, - data, - weight_var = 1, - group_by = NULL, - common_vars = TRUE, - synth_vars = TRUE, - na.rm = FALSE) { +.util_totals <- function( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE) { # catch binding error . <- NULL - if (is_postsynth(postsynth)) { - - synthetic_data <- postsynth$synthetic_data - - variable_order <- - levels(postsynth$jth_synthesis_time$variable) - - # filter to only synthesized variables - # keep group_by variables - if (synth_vars) { - - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - data <- data %>% - dplyr::select(dplyr::all_of(variable_order), {{ group_by }}) - - } - - } else { - - synthetic_data <- postsynth - - } + # create combined data + combined_data <- .create_combined_data_pointwise( + synth_data = synth_data, + conf_data = conf_data, + group_by_q = group_by_q, + weight_var_q = weight_var_q, + common_vars = common_vars, + synth_varnames = synth_varnames + ) - # only keep variables in both data sets - # keep group_by variables - if (common_vars) { + # add weight var + if (weight_var_q == "NULL") { - common_vars <- intersect(names(data), names(synthetic_data)) + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = 1) - data <- data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) + } else { - synthetic_data <- synthetic_data %>% - dplyr::select(dplyr::all_of(common_vars), {{ group_by }}) + combined_data <- combined_data %>% + dplyr::mutate(.temp_weight = .data[[weight_var_q]]) } - # drop non-numeric variables - data <- data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - synthetic_data <- synthetic_data %>% - dplyr::select(tidyselect::where(is.numeric), {{ group_by }}) - - # combine both data sources - combined_data <- dplyr::bind_rows( - `original` = data, - `synthetic` = synthetic_data, - .id = "source" - ) - # calculate summary statistics totals <- combined_data %>% - dplyr::mutate(.temp_weight = {{ weight_var }}) %>% - dplyr::group_by(source, dplyr::across({{ group_by }})) %>% + dplyr::group_by(source, dplyr::across(dplyr::all_of(group_by_q))) %>% dplyr::summarise( dplyr::across( .cols = -".temp_weight", @@ -91,7 +57,8 @@ util_totals<- function(postsynth, ) ) ) %>% - tidyr::gather(key = "variable", value = "value", -source, - {{ group_by }}) %>% + tidyr::gather(key = "variable", value = "value", + -source, -dplyr::all_of(group_by_q)) %>% tidyr::separate(col = .data$variable, into = c("variable", "statistic"), sep = "_(?!.*_)") %>% @@ -109,7 +76,7 @@ util_totals<- function(postsynth, # sort table by synthesis order and keep factor levels for variables that # weren't synthesized - if (!is_postsynth(postsynth)) { + if (is.null(synth_varnames)) { variable_order <- names(dplyr::select(combined_data, -source)) @@ -117,9 +84,9 @@ util_totals<- function(postsynth, all_vars <- names(dplyr::select(combined_data, -source)) - other_vars <- setdiff(all_vars, variable_order) + other_vars <- setdiff(all_vars, synth_varnames) - variable_order <- c(variable_order, other_vars) + variable_order <- c(synth_varnames, other_vars) } @@ -133,3 +100,73 @@ util_totals<- function(postsynth, return(totals) } + +#' Calculate totals for original and synthetic data. +#' +#' @param eval_data An `eval_data` object +#' @param weight_var An unquoted name of a weight variable +#' @param group_by The unquoted name of a (or multiple) grouping variable(s) +#' @param common_vars A logical for if only common variables should be kept +#' @param synth_vars A logical for if only synthesized variables should be kept +#' @param na.rm A logical for ignoring `NA` values in computations. +#' +#' @return A `tibble` of totals. +#' +#' @family utility metrics +#' +#' @export +#' +util_totals <- function( + eval_data, + weight_var = NULL, + group_by = NULL, + common_vars = TRUE, + synth_vars = TRUE, + na.rm = FALSE) { + + stopifnot(is_eval_data(eval_data)) + + # argument parsing + weight_var_q <- base::deparse(rlang::enexpr(weight_var)) + group_by_q <- purrr::map_chr(as.list(rlang::enexpr(group_by)), base::deparse) + group_by_q <- group_by_q[2:length(group_by_q)] %>% purrr::discard(is.na) + synth_varnames <- if (identical(synth_vars, TRUE)) eval_data$synth_vars else NULL + + if (eval_data$n_rep == 1) { + + return( + .util_totals( + conf_data = eval_data$conf_data, + synth_data = eval_data$synth_data, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + ) + + } else { + + result <- purrr::map( + .x = eval_data$synth_data, + .f = \(sd) { + + .util_totals( + conf_data = eval_data$conf_data, + synth_data = sd, + weight_var_q = weight_var_q, + group_by_q = group_by_q, + common_vars = common_vars, + synth_varnames = synth_varnames, + na.rm = na.rm + ) + + } + ) + + return(result) + + } + +} \ No newline at end of file diff --git a/R/weighted_estimators.R b/R/weighted_estimators.R index 4b26aa0..c4f9883 100644 --- a/R/weighted_estimators.R +++ b/R/weighted_estimators.R @@ -34,8 +34,6 @@ weighted_sd <- function(x, w, na.rm = FALSE) { #' #' @return A numeric vector of length 1. #' -#' @export -#' weighted_skewness <- function(x, w, na.rm = FALSE) { # https://www.gnu.org/software/gsl/doc/html/statistics.html#weighted-samples diff --git a/README.md b/README.md index 7f3e4e2..a1539e0 100644 --- a/README.md +++ b/README.md @@ -3,6 +3,7 @@ # `syntheval` + `syntheval` makes it simple to evaluate the utility and disclosure risks @@ -16,7 +17,7 @@ first major version, 0.1.0. This will involve API changes and new functionality. You can keep track of our work in the following issues: - [Version 0.0.5](https://github.com/UrbanInstitute/syntheval/issues/77) -- [Version 0.0.5](https://github.com/UrbanInstitute/syntheval/issues/78) +- [Version 0.0.6](https://github.com/UrbanInstitute/syntheval/issues/78) - [Version 0.1.0](https://github.com/UrbanInstitute/syntheval/issues/107) @@ -77,16 +78,21 @@ show synthesized variables for `postsynth` objects and show all common variables for data frames. The `common_vars` and `synth_vars` arguments can change this behavior. +### Evaluation Data + +`syntheval` functions expect `eval_data` as their main input object. + +``` r +eval_data <- eval_data(conf_data = penguins_conf, synth_data = penguins_postsynth) +``` + ### Proportions `util_proportions()` compares the proportions of classes from categorical variables in the original data and synthetic data. ``` r -util_proportions( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_proportions(eval_data = eval_data) ``` # A tibble: 2 × 5 @@ -98,23 +104,14 @@ util_proportions( All common variables are shown when using a data frame. ``` r -util_proportions( - postsynth = penguins_syn_df, - data = penguins_conf -) +util_proportions(eval_data = eval_data) ``` - # A tibble: 8 × 5 - variable class synthetic original difference - - 1 island Biscoe 0.465 0.489 -0.0240 - 2 island Dream 0.414 0.369 0.0450 - 3 island Torgersen 0.120 0.141 -0.0210 - 4 sex female 0.529 0.495 0.0330 - 5 sex male 0.471 0.505 -0.0330 - 6 species Adelie 0.459 0.438 0.0210 - 7 species Chinstrap 0.234 0.204 0.0300 - 8 species Gentoo 0.306 0.357 -0.0511 + # A tibble: 2 × 5 + variable class synthetic original difference + + 1 sex female 0.529 0.495 0.0330 + 2 sex male 0.471 0.505 -0.0330 ### Means and Totals @@ -122,10 +119,7 @@ util_proportions( skewnesses, and kurtoses of the original data and synthetic data. ``` r -util_moments( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_moments(eval_data = eval_data) ``` # A tibble: 20 × 6 @@ -156,10 +150,7 @@ util_moments( totals. ``` r -util_totals( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_totals(eval_data = eval_data) ``` # A tibble: 8 × 6 @@ -182,8 +173,7 @@ be easily overwritten. ``` r util_percentiles( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, probs = c(0.5, 0.8) ) ``` @@ -204,8 +194,7 @@ The functions are designed to work well with `library(ggplot2)`. ``` r util_percentiles( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, probs = seq(0.01, 0.99, 0.01) ) |> pivot_longer( @@ -218,7 +207,7 @@ util_percentiles( facet_wrap(~ variable, scales = "free") ``` -![](README_files/figure-commonmark/unnamed-chunk-8-1.png) +![](README_files/figure-commonmark/unnamed-chunk-9-1.png) ### KS Distance @@ -227,10 +216,7 @@ original distribution and synthetic distribution for numeric variables. The function also returns the point(s) of the maximum distance. ``` r -util_ks_distance( - postsynth = penguins_syn_df, - data = penguins_conf -) +util_ks_distance(eval_data = eval_data) ``` # A tibble: 14 × 3 @@ -258,10 +244,7 @@ matrices calculated on numeric variables in the original data and synthetic data. ``` r -co_occurrence <- util_co_occurrence( - postsynth = penguins_postsynth, - data = penguins_conf -) +co_occurrence <- util_co_occurrence(eval_data = eval_data) co_occurrence$co_occurrence_difference ``` @@ -301,10 +284,7 @@ matrices calculated on numeric variables in the original data and synthetic data. ``` r -corr_fit <- util_corr_fit( - postsynth = penguins_postsynth, - data = penguins_conf -) +corr_fit <- util_corr_fit(eval_data = eval_data) round(corr_fit$correlation_difference, digits = 3) ``` @@ -341,8 +321,7 @@ form of the regression model. ``` r ci_overlap <- util_ci_overlap( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, formula = body_mass_g ~ bill_length_mm + sex ) ``` @@ -390,7 +369,7 @@ ci_overlap$coefficient |> ) ``` -![](README_files/figure-commonmark/unnamed-chunk-16-1.png) +![](README_files/figure-commonmark/unnamed-chunk-17-1.png) ### Discriminant-Based Metrics @@ -415,7 +394,7 @@ Discriminant-based metrics are built a `discrimination` object created by `discrimination()`. ``` r -disc1 <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) +disc1 <- discrimination(eval_data = eval_data) ``` Next, we use `library(tidymodels)` to specify a model. We recommend the @@ -482,16 +461,16 @@ disc1 |> # A tibble: 666 × 10 .pred_synthetic .source_label .sample species island sex bill_length_mm - 1 0.154 original training Adelie Torgersen male 39.1 - 2 0.154 original training Adelie Torgersen fema… 39.5 - 3 0.369 original training Adelie Torgersen fema… 40.3 - 4 0.596 original testing Adelie Torgersen fema… 36.7 - 5 0.154 original training Adelie Torgersen male 39.3 - 6 0.154 original training Adelie Torgersen fema… 38.9 - 7 0.714 original training Adelie Torgersen male 39.2 - 8 0.369 original training Adelie Torgersen fema… 41.1 - 9 0.596 original testing Adelie Torgersen male 38.6 - 10 0.4 original training Adelie Torgersen male 34.6 + 1 0.143 original training Adelie Torgersen male 39.1 + 2 0.627 original testing Adelie Torgersen fema… 39.5 + 3 0.378 original training Adelie Torgersen fema… 40.3 + 4 0.429 original training Adelie Torgersen fema… 36.7 + 5 0.733 original testing Adelie Torgersen male 39.3 + 6 0.627 original training Adelie Torgersen fema… 38.9 + 7 0.327 original training Adelie Torgersen male 39.2 + 8 0.378 original training Adelie Torgersen fema… 41.1 + 9 0.25 original training Adelie Torgersen male 38.6 + 10 0.327 original training Adelie Torgersen male 34.6 # ℹ 656 more rows # ℹ 3 more variables: bill_depth_mm , flipper_length_mm , # body_mass_g @@ -510,68 +489,60 @@ disc1 |> node), split, n, loss, yval, (yprob) * denotes terminal node - 1) root 498 249 synthetic (0.50000000 0.50000000) - 2) bill_depth_mm>=16.65 332 153 synthetic (0.53915663 0.46084337) - 4) bill_length_mm< 34.2 10 1 synthetic (0.90000000 0.10000000) * - 5) bill_length_mm>=34.2 322 152 synthetic (0.52795031 0.47204969) - 10) bill_length_mm>=42.6 128 49 synthetic (0.61718750 0.38281250) - 20) flipper_length_mm< 194.5 48 11 synthetic (0.77083333 0.22916667) * - 21) flipper_length_mm>=194.5 80 38 synthetic (0.52500000 0.47500000) - 42) bill_length_mm< 52.45 73 32 synthetic (0.56164384 0.43835616) - 84) bill_length_mm>=44.25 64 25 synthetic (0.60937500 0.39062500) - 168) body_mass_g>=4175 27 6 synthetic (0.77777778 0.22222222) * - 169) body_mass_g< 4175 37 18 original (0.48648649 0.51351351) - 338) bill_length_mm< 45.65 8 2 synthetic (0.75000000 0.25000000) * - 339) bill_length_mm>=45.65 29 12 original (0.41379310 0.58620690) * - 85) bill_length_mm< 44.25 9 2 original (0.22222222 0.77777778) * - 43) bill_length_mm>=52.45 7 1 original (0.14285714 0.85714286) * - 11) bill_length_mm< 42.6 194 91 original (0.46907216 0.53092784) - 22) bill_length_mm< 39.65 129 62 synthetic (0.51937984 0.48062016) - 44) flipper_length_mm>=180.5 121 56 synthetic (0.53719008 0.46280992) - 88) bill_length_mm>=36.1 96 41 synthetic (0.57291667 0.42708333) - 176) island=Biscoe 29 9 synthetic (0.68965517 0.31034483) * - 177) island=Dream,Torgersen 67 32 synthetic (0.52238806 0.47761194) - 354) bill_length_mm< 38.75 47 19 synthetic (0.59574468 0.40425532) * - 355) bill_length_mm>=38.75 20 7 original (0.35000000 0.65000000) - 710) flipper_length_mm>=190.5 7 2 synthetic (0.71428571 0.28571429) * - 711) flipper_length_mm< 190.5 13 2 original (0.15384615 0.84615385) * - 89) bill_length_mm< 36.1 25 10 original (0.40000000 0.60000000) * - 45) flipper_length_mm< 180.5 8 2 original (0.25000000 0.75000000) * - 23) bill_length_mm>=39.65 65 24 original (0.36923077 0.63076923) * - 3) bill_depth_mm< 16.65 166 70 original (0.42168675 0.57831325) - 6) bill_length_mm>=51.35 10 2 synthetic (0.80000000 0.20000000) * - 7) bill_length_mm< 51.35 156 62 original (0.39743590 0.60256410) - 14) body_mass_g>=3125 149 62 original (0.41610738 0.58389262) - 28) body_mass_g< 4387.5 34 15 synthetic (0.55882353 0.44117647) - 56) bill_depth_mm>=13.95 25 8 synthetic (0.68000000 0.32000000) * - 57) bill_depth_mm< 13.95 9 2 original (0.22222222 0.77777778) * - 29) body_mass_g>=4387.5 115 43 original (0.37391304 0.62608696) - 58) body_mass_g>=4612.5 104 42 original (0.40384615 0.59615385) - 116) bill_depth_mm< 14.15 18 6 synthetic (0.66666667 0.33333333) * - 117) bill_depth_mm>=14.15 86 30 original (0.34883721 0.65116279) * - 59) body_mass_g< 4612.5 11 1 original (0.09090909 0.90909091) * - 15) body_mass_g< 3125 7 0 original (0.00000000 1.00000000) * + 1) root 498 249 synthetic (0.5000000 0.5000000) + 2) bill_length_mm< 34.55 17 5 synthetic (0.7058824 0.2941176) * + 3) bill_length_mm>=34.55 481 237 original (0.4927235 0.5072765) + 6) bill_depth_mm< 14.05 33 13 synthetic (0.6060606 0.3939394) + 12) bill_length_mm>=46.15 8 1 synthetic (0.8750000 0.1250000) * + 13) bill_length_mm< 46.15 25 12 synthetic (0.5200000 0.4800000) + 26) bill_depth_mm>=13.85 10 2 synthetic (0.8000000 0.2000000) * + 27) bill_depth_mm< 13.85 15 5 original (0.3333333 0.6666667) * + 7) bill_depth_mm>=14.05 448 217 original (0.4843750 0.5156250) + 14) bill_length_mm< 46.45 289 141 synthetic (0.5121107 0.4878893) + 28) species=Chinstrap 45 15 synthetic (0.6666667 0.3333333) * + 29) species=Adelie,Gentoo 244 118 original (0.4836066 0.5163934) + 58) sex=female 133 63 synthetic (0.5263158 0.4736842) + 116) body_mass_g>=3312.5 96 40 synthetic (0.5833333 0.4166667) + 232) bill_depth_mm< 17.95 75 28 synthetic (0.6266667 0.3733333) * + 233) bill_depth_mm>=17.95 21 9 original (0.4285714 0.5714286) * + 117) body_mass_g< 3312.5 37 14 original (0.3783784 0.6216216) * + 59) sex=male 111 48 original (0.4324324 0.5675676) + 118) flipper_length_mm< 192.5 62 30 synthetic (0.5161290 0.4838710) + 236) body_mass_g>=4000 25 8 synthetic (0.6800000 0.3200000) * + 237) body_mass_g< 4000 37 15 original (0.4054054 0.5945946) + 474) bill_depth_mm>=18.8 23 10 synthetic (0.5652174 0.4347826) + 948) bill_length_mm>=39 15 4 synthetic (0.7333333 0.2666667) * + 949) bill_length_mm< 39 8 2 original (0.2500000 0.7500000) * + 475) bill_depth_mm< 18.8 14 2 original (0.1428571 0.8571429) * + 119) flipper_length_mm>=192.5 49 16 original (0.3265306 0.6734694) * + 15) bill_length_mm>=46.45 159 69 original (0.4339623 0.5660377) + 30) body_mass_g>=4125 108 51 original (0.4722222 0.5277778) + 60) bill_length_mm>=49.25 61 27 synthetic (0.5573770 0.4426230) + 120) flipper_length_mm< 222.5 42 14 synthetic (0.6666667 0.3333333) * + 121) flipper_length_mm>=222.5 19 6 original (0.3157895 0.6842105) * + 61) bill_length_mm< 49.25 47 17 original (0.3617021 0.6382979) * + 31) body_mass_g< 4125 51 18 original (0.3529412 0.6470588) * $discriminator_auc # A tibble: 2 × 4 .sample .metric .estimator .estimate - 1 training roc_auc binary 0.742 - 2 testing roc_auc binary 0.425 + 1 training roc_auc binary 0.693 + 2 testing roc_auc binary 0.568 $pmse # A tibble: 2 × 4 .source .pmse .null_pmse .pmse_ratio - 1 training 0.0466 0.0320 1.46 - 2 testing 0.0437 0.0327 1.34 + 1 training 0.0311 0.0315 0.987 + 2 testing 0.0314 0.0329 0.953 $specks # A tibble: 2 × 2 .source .specks - 1 training 0.390 - 2 testing 0.143 + 1 training 0.333 + 2 testing 0.131 attr(,"class") [1] "discrimination" @@ -588,7 +559,7 @@ disc1$discriminator |> vip() ``` -![](README_files/figure-commonmark/unnamed-chunk-21-1.png) +![](README_files/figure-commonmark/unnamed-chunk-22-1.png) ``` r disc1$discriminator$fit$fit$fit |> @@ -600,7 +571,7 @@ disc1$discriminator$fit$fit$fit |> Call prp with roundint=FALSE, or rebuild the rpart model with model=TRUE. -![](README_files/figure-commonmark/unnamed-chunk-21-2.png) +![](README_files/figure-commonmark/unnamed-chunk-22-2.png) #### Example Using Regularized Regression @@ -609,7 +580,7 @@ hyperparameter tuning. ``` r # create discrimination -disc2 <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) +disc2 <- discrimination(eval_data = eval_data) # create a recipe that includes 2nd-degree polynomials, dummy variables, and # standardization @@ -669,16 +640,16 @@ disc2 |> # A tibble: 666 × 10 .pred_synthetic .source_label .sample species island sex bill_length_mm - 1 0.409 original training Adelie Torgersen male 39.1 - 2 0.455 original training Adelie Torgersen fema… 39.5 - 3 0.360 original testing Adelie Torgersen fema… 40.3 - 4 0.496 original training Adelie Torgersen fema… 36.7 - 5 0.420 original training Adelie Torgersen male 39.3 - 6 0.457 original training Adelie Torgersen fema… 38.9 - 7 0.539 original training Adelie Torgersen male 39.2 - 8 0.354 original training Adelie Torgersen fema… 41.1 - 9 0.483 original training Adelie Torgersen male 38.6 - 10 0.681 original testing Adelie Torgersen male 34.6 + 1 0.5 original training Adelie Torgersen male 39.1 + 2 0.5 original training Adelie Torgersen fema… 39.5 + 3 0.5 original training Adelie Torgersen fema… 40.3 + 4 0.5 original training Adelie Torgersen fema… 36.7 + 5 0.5 original training Adelie Torgersen male 39.3 + 6 0.5 original training Adelie Torgersen fema… 38.9 + 7 0.5 original training Adelie Torgersen male 39.2 + 8 0.5 original training Adelie Torgersen fema… 41.1 + 9 0.5 original training Adelie Torgersen male 38.6 + 10 0.5 original testing Adelie Torgersen male 34.6 # ℹ 656 more rows # ℹ 3 more variables: bill_depth_mm , flipper_length_mm , # body_mass_g @@ -699,77 +670,77 @@ disc2 |> Call: glmnet::glmnet(x = maybe_matrix(x), y = y, family = "binomial", alpha = ~1) - Df %Dev Lambda - 1 0 0.00 0.036370 - 2 3 0.07 0.033140 - 3 3 0.18 0.030200 - 4 3 0.27 0.027520 - 5 3 0.35 0.025070 - 6 3 0.41 0.022840 - 7 5 0.50 0.020820 - 8 5 0.63 0.018970 - 9 5 0.75 0.017280 - 10 5 0.86 0.015750 - 11 5 0.95 0.014350 - 12 5 1.02 0.013070 - 13 4 1.08 0.011910 - 14 4 1.13 0.010850 - 15 5 1.16 0.009889 - 16 5 1.29 0.009010 - 17 6 1.40 0.008210 - 18 7 1.50 0.007481 - 19 8 1.58 0.006816 - 20 8 1.65 0.006210 - 21 9 1.72 0.005659 - 22 10 1.79 0.005156 - 23 10 1.86 0.004698 - 24 10 1.91 0.004281 - 25 10 1.96 0.003900 - 26 10 2.00 0.003554 - 27 10 2.04 0.003238 - 28 10 2.06 0.002950 - 29 10 2.09 0.002688 - 30 10 2.11 0.002450 - 31 10 2.12 0.002232 - 32 11 2.14 0.002034 - 33 11 2.16 0.001853 - 34 11 2.18 0.001688 - 35 11 2.19 0.001538 - 36 11 2.20 0.001402 - 37 11 2.21 0.001277 - 38 11 2.22 0.001164 - 39 11 2.22 0.001060 - 40 11 2.23 0.000966 - 41 11 2.23 0.000880 - 42 12 2.24 0.000802 - 43 12 2.24 0.000731 - 44 12 2.24 0.000666 - 45 12 2.24 0.000607 - 46 13 2.25 0.000553 + Df %Dev Lambda + 1 0 0.00 0.0313500 + 2 2 0.05 0.0285600 + 3 2 0.10 0.0260300 + 4 2 0.14 0.0237100 + 5 3 0.18 0.0216100 + 6 3 0.25 0.0196900 + 7 3 0.32 0.0179400 + 8 3 0.37 0.0163500 + 9 3 0.42 0.0148900 + 10 3 0.45 0.0135700 + 11 3 0.48 0.0123600 + 12 3 0.51 0.0112700 + 13 4 0.53 0.0102700 + 14 6 0.57 0.0093530 + 15 6 0.61 0.0085230 + 16 6 0.63 0.0077650 + 17 7 0.66 0.0070760 + 18 8 0.69 0.0064470 + 19 9 0.76 0.0058740 + 20 9 0.81 0.0053520 + 21 9 0.85 0.0048770 + 22 9 0.89 0.0044440 + 23 10 0.92 0.0040490 + 24 10 0.96 0.0036890 + 25 10 0.98 0.0033610 + 26 10 1.01 0.0030630 + 27 11 1.03 0.0027910 + 28 11 1.05 0.0025430 + 29 11 1.07 0.0023170 + 30 11 1.09 0.0021110 + 31 11 1.10 0.0019240 + 32 11 1.11 0.0017530 + 33 12 1.12 0.0015970 + 34 12 1.13 0.0014550 + 35 12 1.13 0.0013260 + 36 12 1.14 0.0012080 + 37 12 1.14 0.0011010 + 38 12 1.15 0.0010030 + 39 12 1.15 0.0009138 + 40 12 1.15 0.0008327 + 41 12 1.15 0.0007587 + 42 12 1.16 0.0006913 + 43 12 1.16 0.0006299 + 44 12 1.16 0.0005739 + 45 12 1.16 0.0005229 + 46 12 1.16 0.0004765 ... - and 6 more lines. + and 0 more lines. $discriminator_auc # A tibble: 2 × 4 .sample .metric .estimator .estimate - 1 training roc_auc binary 0.601 - 2 testing roc_auc binary 0.475 + 1 training roc_auc binary 0.5 + 2 testing roc_auc binary 0.5 $pmse # A tibble: 2 × 4 - .source .pmse .null_pmse .pmse_ratio - - 1 training 0.00732 0.00736 0.996 - 2 testing 0.00829 0.00745 1.11 + .source .pmse .null_pmse .pmse_ratio + + 1 training 1.23e-32 1.23e-32 1 + 2 testing 1.23e-32 1.23e-32 1 $specks # A tibble: 2 × 2 - .source .specks - - 1 training 0.157 - 2 testing 0.167 + .source .specks + + 1 training 4.86e-17 + 2 testing 6.94e-17 attr(,"class") [1] "discrimination" @@ -783,7 +754,7 @@ disc2$discriminator |> vip() ``` -![](README_files/figure-commonmark/unnamed-chunk-22-1.png) +![](README_files/figure-commonmark/unnamed-chunk-23-1.png) ## Additional Functionality @@ -795,8 +766,7 @@ by species. ``` r util_moments( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, group_by = species ) ``` @@ -825,8 +795,7 @@ moments by the body weight of the penguins. ``` r util_moments( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, weight_var = body_mass_g ) ``` diff --git a/README.qmd b/README.qmd index 9ed9b04..d7bc016 100644 --- a/README.qmd +++ b/README.qmd @@ -68,25 +68,28 @@ The following examples demonstrate utility and disclosure risk metrics using syn Functions like `util_proportions()` and `util_moments()` have different behaviors for `postsynth` objects and data frames. By default, they only show synthesized variables for `postsynth` objects and show all common variables for data frames. The `common_vars` and `synth_vars` arguments can change this behavior. +### Evaluation Data + +`syntheval` functions expect `eval_data` as their main input object. + +```{r} +eval_data <- eval_data(conf_data = penguins_conf, synth_data = penguins_postsynth) + +``` + ### Proportions `util_proportions()` compares the proportions of classes from categorical variables in the original data and synthetic data. ```{r} -util_proportions( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_proportions(eval_data = eval_data) ``` All common variables are shown when using a data frame. ```{r} -util_proportions( - postsynth = penguins_syn_df, - data = penguins_conf -) +util_proportions(eval_data = eval_data) ``` @@ -95,20 +98,14 @@ util_proportions( `util_moments()` compares the counts, means, standard deviations, skewnesses, and kurtoses of the original data and synthetic data. ```{r} -util_moments( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_moments(eval_data = eval_data) ``` `util_totals()` is similar to `util_moments()` but looks at counts and totals. ```{r} -util_totals( - postsynth = penguins_postsynth, - data = penguins_conf -) +util_totals(eval_data = eval_data) ``` @@ -118,8 +115,7 @@ util_totals( ```{r} util_percentiles( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, probs = c(0.5, 0.8) ) @@ -129,8 +125,7 @@ The functions are designed to work well with `library(ggplot2)`. ```{r} util_percentiles( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, probs = seq(0.01, 0.99, 0.01) ) |> pivot_longer( @@ -149,10 +144,7 @@ util_percentiles( `util_ks_distance()` shows the Kolmogorov-Smirnov distance between the original distribution and synthetic distribution for numeric variables. The function also returns the point(s) of the maximum distance. ```{r} -util_ks_distance( - postsynth = penguins_syn_df, - data = penguins_conf -) +util_ks_distance(eval_data = eval_data) ``` @@ -161,10 +153,7 @@ util_ks_distance( `util_co_occurrence()` differences the lower triangles of co-occurrence matrices calculated on numeric variables in the original data and synthetic data. ```{r} -co_occurrence <- util_co_occurrence( - postsynth = penguins_postsynth, - data = penguins_conf -) +co_occurrence <- util_co_occurrence(eval_data = eval_data) co_occurrence$co_occurrence_difference @@ -186,10 +175,7 @@ All observations have non-zero `bill_length_mm`, `bill_depth_mm`, `flipper_lengt `util_corr_fit()` differences the lower triangles of correlation matrices calculated on numeric variables in the original data and synthetic data. ```{r} -corr_fit <- util_corr_fit( - postsynth = penguins_postsynth, - data = penguins_conf -) +corr_fit <- util_corr_fit(eval_data = eval_data) round(corr_fit$correlation_difference, digits = 3) @@ -210,8 +196,7 @@ corr_fit$correlation_difference_rmse ```{r} ci_overlap <- util_ci_overlap( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, formula = body_mass_g ~ bill_length_mm + sex ) @@ -253,7 +238,7 @@ Discriminant-based metrics build models to predict if an observation is original Discriminant-based metrics are built a `discrimination` object created by `discrimination()`. ```{r} -disc1 <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) +disc1 <- discrimination(eval_data = eval_data) ``` @@ -325,7 +310,7 @@ Let's repeat the workflow from above with LASSO logistic regression and hyperpar ```{r} # create discrimination -disc2 <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) +disc2 <- discrimination(eval_data = eval_data) # create a recipe that includes 2nd-degree polynomials, dummy variables, and # standardization @@ -380,8 +365,7 @@ Many utility metrics include a `group_by` argument to group the metrics by group ```{r} util_moments( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, group_by = species ) @@ -393,8 +377,7 @@ Many utility metrics include a `weight_var` argument to use weighted statistics ```{r} util_moments( - postsynth = penguins_postsynth, - data = penguins_conf, + eval_data = eval_data, weight_var = body_mass_g ) diff --git a/README_files/figure-commonmark/unnamed-chunk-17-1.png b/README_files/figure-commonmark/unnamed-chunk-17-1.png index da0c4f2..277de6f 100644 Binary files a/README_files/figure-commonmark/unnamed-chunk-17-1.png and b/README_files/figure-commonmark/unnamed-chunk-17-1.png differ diff --git a/README_files/figure-commonmark/unnamed-chunk-22-1.png b/README_files/figure-commonmark/unnamed-chunk-22-1.png index 75f0de6..1d1fee9 100644 Binary files a/README_files/figure-commonmark/unnamed-chunk-22-1.png and b/README_files/figure-commonmark/unnamed-chunk-22-1.png differ diff --git a/README_files/figure-commonmark/unnamed-chunk-22-2.png b/README_files/figure-commonmark/unnamed-chunk-22-2.png index 6902b7d..8cdf5ab 100644 Binary files a/README_files/figure-commonmark/unnamed-chunk-22-2.png and b/README_files/figure-commonmark/unnamed-chunk-22-2.png differ diff --git a/README_files/figure-commonmark/unnamed-chunk-23-1.png b/README_files/figure-commonmark/unnamed-chunk-23-1.png index 0becc87..acc24c6 100644 Binary files a/README_files/figure-commonmark/unnamed-chunk-23-1.png and b/README_files/figure-commonmark/unnamed-chunk-23-1.png differ diff --git a/README_files/figure-commonmark/unnamed-chunk-9-1.png b/README_files/figure-commonmark/unnamed-chunk-9-1.png index 5568756..ac10a0d 100644 Binary files a/README_files/figure-commonmark/unnamed-chunk-9-1.png and b/README_files/figure-commonmark/unnamed-chunk-9-1.png differ diff --git a/man/add_pmse.Rd b/man/add_pmse.Rd index 48da543..b68cc7e 100644 --- a/man/add_pmse.Rd +++ b/man/add_pmse.Rd @@ -21,14 +21,15 @@ add_propensities()) with a pMSE Add pMSE to discrimination object } \seealso{ -Other Utility metrics: -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/add_pmse_ratio.Rd b/man/add_pmse_ratio.Rd index be2a13d..a79f4dd 100644 --- a/man/add_pmse_ratio.Rd +++ b/man/add_pmse_ratio.Rd @@ -25,14 +25,15 @@ A discrimination with pMSE Add pMSE ratio to discrimination object } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/add_propensities.Rd b/man/add_propensities.Rd index aabfd08..cf89943 100644 --- a/man/add_propensities.Rd +++ b/man/add_propensities.Rd @@ -39,14 +39,15 @@ generating propensities Add propensities for if an observation belongs to the synthetic data } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/add_propensities_tuned.Rd b/man/add_propensities_tuned.Rd index c510a1f..818edc2 100644 --- a/man/add_propensities_tuned.Rd +++ b/man/add_propensities_tuned.Rd @@ -45,14 +45,15 @@ generating propensities Add propensities for if an observation belongs to the synthetic data } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/add_specks.Rd b/man/add_specks.Rd index 86252b9..e4e2b0a 100644 --- a/man/add_specks.Rd +++ b/man/add_specks.Rd @@ -19,14 +19,15 @@ A discrimination with SPECKS Add SPECKS to discrimination object } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/co_occurrence.Rd b/man/co_occurrence.Rd index 4f1de18..a720a61 100644 --- a/man/co_occurrence.Rd +++ b/man/co_occurrence.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/co_occurence.R +% Please edit documentation in R/co_occurrence.R \name{co_occurrence} \alias{co_occurrence} \title{Construct a co-occurrence matrix} diff --git a/man/convert_na_to_level.Rd b/man/convert_na_to_level.Rd index baeeb02..51e137d 100644 --- a/man/convert_na_to_level.Rd +++ b/man/convert_na_to_level.Rd @@ -4,14 +4,20 @@ \alias{convert_na_to_level} \title{Convert \code{NA} values to \code{"NA"} for categorical variables} \usage{ +convert_na_to_level(data) + convert_na_to_level(data) } \arguments{ \item{data}{A data frame or tibble} } \value{ +A data frame or tibble with \code{NA} converted to \code{"NA"} + A data frame or tibble with \code{NA} converted to \code{"NA"} } \description{ +Convert \code{NA} values to \code{"NA"} for categorical variables + Convert \code{NA} values to \code{"NA"} for categorical variables } diff --git a/man/discrimination.Rd b/man/discrimination.Rd index d47a3d9..5d21da1 100644 --- a/man/discrimination.Rd +++ b/man/discrimination.Rd @@ -4,12 +4,10 @@ \alias{discrimination} \title{Combine synthetic data and data for a discriminant based metric} \usage{ -discrimination(postsynth, data) +discrimination(eval_data) } \arguments{ -\item{postsynth}{A postsynth object from tidysynthesis or a tibble} - -\item{data}{an original (observed) data set.} +\item{eval_data}{An \code{eval_data} object.} } \value{ A list of class discrimination @@ -18,14 +16,15 @@ A list of class discrimination Combine synthetic data and data for a discriminant based metric } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/dot-create_combined_data_pointwise.Rd b/man/dot-create_combined_data_pointwise.Rd new file mode 100644 index 0000000..4b3802f --- /dev/null +++ b/man/dot-create_combined_data_pointwise.Rd @@ -0,0 +1,38 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_nse_helper.R +\name{.create_combined_data_pointwise} +\alias{.create_combined_data_pointwise} +\title{Create combined data for pointwise utility statistic evaluation} +\usage{ +.create_combined_data_pointwise( + synth_data, + conf_data, + keep_numeric = TRUE, + group_by_q = NULL, + weight_var_q = NULL, + common_vars = FALSE, + synth_varnames = NULL +) +} +\arguments{ +\item{synth_data}{A synthetic data.frame} + +\item{conf_data}{A confidential data.frame} + +\item{keep_numeric}{A boolean, if TRUE keeps only numeric variables, else keeps +factors and characters. Defaults to TRUE.} + +\item{group_by_q}{The quoted name(s) of a (or multiple) grouping variable(s)} + +\item{weight_var_q}{A quoted name of a weight variable} + +\item{common_vars}{A logical for if only common variables should be kept} + +\item{synth_varnames}{A list of variables synthesized to filter on, else \code{NULL}} +} +\value{ +A tibble +} +\description{ +Create combined data for pointwise utility statistic evaluation +} diff --git a/man/dot-prep_combined_data_for_na.rm_q.Rd b/man/dot-prep_combined_data_for_na.rm_q.Rd new file mode 100644 index 0000000..bf094af --- /dev/null +++ b/man/dot-prep_combined_data_for_na.rm_q.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_na_helper.R +\name{.prep_combined_data_for_na.rm_q} +\alias{.prep_combined_data_for_na.rm_q} +\title{Check whether na.rm is compatible with univariate utilty metrics} +\usage{ +.prep_combined_data_for_na.rm_q( + combined_data, + na.rm = FALSE, + drop_zeros = FALSE, + drop_zeros_exclude = NULL +) +} +\arguments{ +\item{combined_data}{A data frame or tibble} + +\item{na.rm}{A boolean for whether to ignore missing values} + +\item{drop_zeros}{A boolean for whether to ignore zero values in utility metrics} + +\item{drop_zeros_exclude}{An optional set of quoted columns on which to drop zeros} +} +\value{ +A data frame or tibble with missing and/or zero values set to NA +} +\description{ +Check whether na.rm is compatible with univariate utilty metrics +} diff --git a/man/dot-util_ci_overlap.Rd b/man/dot-util_ci_overlap.Rd new file mode 100644 index 0000000..f45b4ad --- /dev/null +++ b/man/dot-util_ci_overlap.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_ci_overlap.R +\name{.util_ci_overlap} +\alias{.util_ci_overlap} +\title{Regression confidence interval overlap for one synthetic data replicate} +\usage{ +.util_ci_overlap(synth_data, conf_data, formula) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{formula}{A formula for a linear regression model} +} +\value{ +A list of two dataframes: +\itemize{ +\item \code{ci_overlap}: one row per model parameter with utility metrics. +\itemize{ +\item \code{overlap }: symmetric overlap metric, calculated as the average of the +interval overlap contained in the synthetic confidence interval and the +interval overlap contained in the confidential confidence interval. +\item \code{coef_diff}: synthetic parameter estimate - confidential parameter estimate +\item \code{std_coef_diff}: \code{coef_diff} divided by the standard error for the confidential data. +\item \code{sign_match}: boolean if the synthetic and confidential parameter estimates have the same sign. +\item \code{significance_match}: boolean if the null hypothesis test where the +parameter is 0 has p-value less than .05 agrees in both confidential and +synthetic data. +\item \code{ss}: boolean if both \code{sign_match} and \code{significance_match} are true. +\item \code{sso}: boolean if \code{sign_match} is true and \code{overlap} is positive. +} +\item \code{coef_diff}: one row per model parameter and data source (confidential or +synthetic) listing parameter estimates, standard errors, test statistics, +p-values for null hypothesis tests, and 95\% confidence interval bounds. +} +} +\description{ +Regression confidence interval overlap for one synthetic data replicate +} diff --git a/man/dot-util_co_occurrence.Rd b/man/dot-util_co_occurrence.Rd new file mode 100644 index 0000000..75128dc --- /dev/null +++ b/man/dot-util_co_occurrence.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_co_ocurrence.R +\name{.util_co_occurrence} +\alias{.util_co_occurrence} +\title{Compare the co-occurrence fit metric of a confidential and synthetic dataset} +\usage{ +.util_co_occurrence(synth_data, conf_data, na.rm = FALSE) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{na.rm}{a logical indicating whether missing values should be removed. +Note: values are jointly removed for each pair of variables even if only one +value is missing.} +} +\value{ +A \code{list} of fit metrics: +\itemize{ +\item \code{co_occurrence_original}: co-occurrence matrix of the original data. +\item \code{co_occurrence_synthetic}: co-occurrence matrix of the synthetic data. +\item \code{co_occurrence_difference}: difference between \code{co_occurrence_synthetic} and +\code{co_occurrence_original}. +\code{co_occurrence_synthetic} and \code{co_occurrence_original}, divided by the number of +cells in the co-occurrence matrix. +\item \code{co_occurrence_difference_mae}: Mean absolute error between +\code{co_occurrence_original} and \code{co_occurrence_synthetic} +\item \code{co_occurrence_difference_rmse}: Root mean squared error between +\code{co_occurrence_original} and \code{co_occurrence_synthetic} +} +} +\description{ +Compare the co-occurrence fit metric of a confidential and synthetic dataset +} diff --git a/man/dot-util_corr_fit.Rd b/man/dot-util_corr_fit.Rd new file mode 100644 index 0000000..d63130a --- /dev/null +++ b/man/dot-util_corr_fit.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_corr_fit.R +\name{.util_corr_fit} +\alias{.util_corr_fit} +\title{Calculate the correlation fit metric of a confidential data set.} +\usage{ +.util_corr_fit(synth_data, conf_data, use = "everything") +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{use}{optional character string giving a method for computing +covariances in the presence of missing values. This must be (an abbreviation +of) one of the strings "everything", "all.obs", "complete.obs", +"na.or.complete", or "pairwise.complete.obs".} +} +\value{ +A \code{list} of fit metrics: +\itemize{ +\item \code{correlation_original}: correlation matrix of the original data. +\item \code{correlation_synthetic}: correlation matrix of the synthetic data. +\item \code{correlation_difference}: difference between \code{correlation_synthetic} and +\code{correlation_original}. +\item \code{correlation_fit}: square root of the sum of squared differences between +\code{correlation_synthetic} and \code{correlation_original}, divided by the number of +cells in the correlation matrix. +} +} +\description{ +Calculate the correlation fit metric of a confidential data set. +} diff --git a/man/dot-util_ks_distance.Rd b/man/dot-util_ks_distance.Rd new file mode 100644 index 0000000..050cbd5 --- /dev/null +++ b/man/dot-util_ks_distance.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_ks_distance.R +\name{.util_ks_distance} +\alias{.util_ks_distance} +\title{Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in +the synthetic and confidential data} +\usage{ +.util_ks_distance(synth_data, conf_data, na.rm = FALSE) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{na.rm}{a logical indicating whether missing values should be removed.} +} +\value{ +A tibble with the D and location of the largest distance for each +numeric variable +} +\description{ +Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in +the synthetic and confidential data +} diff --git a/man/dot-util_moments.Rd b/man/dot-util_moments.Rd new file mode 100644 index 0000000..b2809e7 --- /dev/null +++ b/man/dot-util_moments.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_moments.R +\name{.util_moments} +\alias{.util_moments} +\title{Calculate summary statistics for original and synthetic data.} +\usage{ +.util_moments( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE +) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{weight_var_q}{A quoted name of a weight variable} + +\item{group_by_q}{The quoted name(s) of a (or multiple) grouping variable(s)} + +\item{drop_zeros}{A logical for if zeros should be dropped} + +\item{common_vars}{A logical for if only common variables should be kept} + +\item{synth_varnames}{A list of variables synthesized to filter on, else \code{NULL}} + +\item{na.rm}{A logical for ignoring \code{NA} values in computations.} +} +\value{ +A \code{tibble} of summary statistics. +} +\description{ +Calculate summary statistics for original and synthetic data. +} diff --git a/man/dot-util_percentiles.Rd b/man/dot-util_percentiles.Rd new file mode 100644 index 0000000..c43dc87 --- /dev/null +++ b/man/dot-util_percentiles.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_percentiles.R +\name{.util_percentiles} +\alias{.util_percentiles} +\title{Calculate summary statistics for original and synthetic data.} +\usage{ +.util_percentiles( + synth_data, + conf_data, + probs = c(0.1, 0.5, 0.9), + weight_var_q = NULL, + group_by_q = NULL, + drop_zeros = FALSE, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE +) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{probs}{A numeric vector of probabilities with values in [0,1]. The +percentiles are interpolated using an empirical CDF. It's possible that the +percentiles are an approximation; especially when weights are used.} + +\item{weight_var_q}{A quoted name of a weight variable} + +\item{group_by_q}{The quoted name(s) of a (or multiple) grouping variable(s)} + +\item{drop_zeros}{A Boolean for if zeros should be dropped} + +\item{common_vars}{A logical for if only common variables should be kept. +This option will frequently result in an error because quantile() is strict +about missing values.} + +\item{synth_varnames}{A list of variables synthesized to filter on, else \code{NULL}} + +\item{na.rm}{A logical for ignoring \code{NA} values in computations.} +} +\value{ +A \code{tibble} of summary statistics. +} +\description{ +Calculate summary statistics for original and synthetic data. +} diff --git a/man/dot-util_proportions.Rd b/man/dot-util_proportions.Rd new file mode 100644 index 0000000..5137f97 --- /dev/null +++ b/man/dot-util_proportions.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_proportions.R +\name{.util_proportions} +\alias{.util_proportions} +\title{Calculate relative frequency tables for categorical variables} +\usage{ +.util_proportions( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + common_vars = TRUE, + synth_varnames = TRUE, + keep_empty_levels = FALSE, + na.rm = FALSE +) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{weight_var_q}{A quoted name of a weight variable} + +\item{group_by_q}{The quoted name(s) of a (or multiple) grouping variable(s)} + +\item{common_vars}{A logical for if only common variables should be kept} + +\item{synth_varnames}{A list of variables synthesized to filter on, else \code{NULL}} + +\item{keep_empty_levels}{A logical for keeping all class levels in the group_by +statements, including missing levels.} + +\item{na.rm}{A logical for ignoring \code{NA} values in proportion calculations.} +} +\value{ +A tibble with variables, classes, and relative frequencies +} +\description{ +Calculate relative frequency tables for categorical variables +} diff --git a/man/dot-util_totals.Rd b/man/dot-util_totals.Rd new file mode 100644 index 0000000..0b7f7c8 --- /dev/null +++ b/man/dot-util_totals.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/util_totals.R +\name{.util_totals} +\alias{.util_totals} +\title{Calculate totals for original and synthetic data.} +\usage{ +.util_totals( + synth_data, + conf_data, + weight_var_q = NULL, + group_by_q = NULL, + common_vars = TRUE, + synth_varnames = NULL, + na.rm = FALSE +) +} +\arguments{ +\item{synth_data}{A data.frame with synthetic data} + +\item{conf_data}{A data.frame with the confidential data} + +\item{weight_var_q}{A quoted name of a weight variable} + +\item{group_by_q}{The quoted name(s) of a (or multiple) grouping variable(s)} + +\item{common_vars}{A logical for if only common variables should be kept} + +\item{synth_varnames}{A list of variables synthesized to filter on, else \code{NULL}} + +\item{na.rm}{A logical for ignoring \code{NA} values in computations.} +} +\value{ +A \code{tibble} of totals. +} +\description{ +Calculate totals for original and synthetic data. +} diff --git a/man/eval_data.Rd b/man/eval_data.Rd index 0572d7d..99acd64 100644 --- a/man/eval_data.Rd +++ b/man/eval_data.Rd @@ -4,7 +4,7 @@ \alias{eval_data} \title{Create evaluation data container} \usage{ -eval_data(conf_data, synth_data, holdout_data = NULL) +eval_data(conf_data, synth_data, holdout_data = NULL, synth_vars = NULL) } \arguments{ \item{conf_data}{A confidential dataframe} @@ -13,6 +13,10 @@ eval_data(conf_data, synth_data, holdout_data = NULL) \item{holdout_data}{An optional holdout dataframe containing the same columns as the confidential dataframe} + +\item{synth_vars}{An optional list of variables synthesized (if not using +full synthesis). If \code{synth_data} uses \code{postsynth} object(s), then these +are inherited from \code{jth_synthesis_time}.} } \value{ An \code{eval_data} object. diff --git a/man/plot_categorical_bar.Rd b/man/plot_categorical_bar.Rd index a6cf387..07b1743 100644 --- a/man/plot_categorical_bar.Rd +++ b/man/plot_categorical_bar.Rd @@ -4,11 +4,10 @@ \alias{plot_categorical_bar} \title{Create bar charts for a categorical random variable.} \usage{ -plot_categorical_bar(joint_data, var_name, cat1_name = NULL, cat2_name = NULL) +plot_categorical_bar(eval_data, var_name, cat1_name = NULL, cat2_name = NULL) } \arguments{ -\item{joint_data}{A data.frame combining rows from confidential and synthetic -data, with the column 'source' identifying the two.} +\item{eval_data}{An \code{eval_data} object.} \item{var_name}{Categorical variable name to plot.} diff --git a/man/plot_cormat.Rd b/man/plot_cormat.Rd index a1d35bc..cc32c6b 100644 --- a/man/plot_cormat.Rd +++ b/man/plot_cormat.Rd @@ -4,12 +4,10 @@ \alias{plot_cormat} \title{Create side-by-side correlation heatmaps for numeric random variables.} \usage{ -plot_cormat(conf_data, synth_data, cor_method = "pearson") +plot_cormat(eval_data, cor_method = "pearson") } \arguments{ -\item{conf_data}{Confidential data} - -\item{synth_data}{Synthetic data} +\item{eval_data}{An \code{eval_data} object.} \item{cor_method}{A correlation method to pass to \verb{stats::cor(., method=)}} } diff --git a/man/plot_numeric_hist_kde.Rd b/man/plot_numeric_hist_kde.Rd index 19e7bd5..d0a87e5 100644 --- a/man/plot_numeric_hist_kde.Rd +++ b/man/plot_numeric_hist_kde.Rd @@ -4,11 +4,10 @@ \alias{plot_numeric_hist_kde} \title{Create a histogram + KDE estimate for a numeric variable.} \usage{ -plot_numeric_hist_kde(joint_data, var_name, cat1_name = NULL, cat2_name = NULL) +plot_numeric_hist_kde(eval_data, var_name, cat1_name = NULL, cat2_name = NULL) } \arguments{ -\item{joint_data}{A data.frame combining rows from confidential and synthetic -data, with the column 'source' identifying the two.} +\item{eval_data}{An \code{eval_data} object.} \item{var_name}{Numeric variable name to plot.} diff --git a/man/syntheval-package.Rd b/man/syntheval-package.Rd index 1507d3e..0452f3b 100644 --- a/man/syntheval-package.Rd +++ b/man/syntheval-package.Rd @@ -20,6 +20,7 @@ Useful links: Authors: \itemize{ + \item Aaron R. Williams \email{awilliams@urban.org} (\href{https://orcid.org/0000-0001-5564-1938}{ORCID}) \item Jeremy Seeman \email{jseeman@urban.org} (\href{https://orcid.org/0000-0003-3526-3209}{ORCID}) } diff --git a/man/util_ci_overlap.Rd b/man/util_ci_overlap.Rd index 81cbb61..ed670b1 100644 --- a/man/util_ci_overlap.Rd +++ b/man/util_ci_overlap.Rd @@ -4,17 +4,15 @@ \alias{util_ci_overlap} \title{Regression confidence interval overlap} \usage{ -util_ci_overlap(postsynth, data, formula) +util_ci_overlap(eval_data, formula) } \arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} +\item{eval_data}{An \code{eval_data} object} \item{formula}{A formula for a linear regression model} } \value{ -A list of two dataframes: +A list of two dataframes (one per each synthetic data replicate): \itemize{ \item \code{ci_overlap}: one row per model parameter with utility metrics. \itemize{ @@ -42,23 +40,25 @@ Regression confidence interval overlap conf_data <- mtcars synth_data <- mtcars \%>\% dplyr::slice_sample(n = nrow(mtcars) / 2) + +eval_data <- eval_data(conf_data, synth_data) util_ci_overlap( - conf_data, - synth_data, + eval_data, mpg ~ disp + vs + am ) } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ks_distance}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/util_co_occurrence.Rd b/man/util_co_occurrence.Rd index 37fbcc5..70fee91 100644 --- a/man/util_co_occurrence.Rd +++ b/man/util_co_occurrence.Rd @@ -2,21 +2,19 @@ % Please edit documentation in R/util_co_ocurrence.R \name{util_co_occurrence} \alias{util_co_occurrence} -\title{Calculate the co-occurrence fit metric of a confidential data set.} +\title{Compare the co-occurrence fit metric of a confidential and synthetic dataset} \usage{ -util_co_occurrence(postsynth, data, na.rm = FALSE) +util_co_occurrence(eval_data, na.rm = FALSE) } \arguments{ -\item{postsynth}{a postsynth object from tidysynthesis or a tibble} - -\item{data}{an original (observed) data set.} +\item{eval_data}{An \code{eval_data} object} \item{na.rm}{a logical indicating whether missing values should be removed. Note: values are jointly removed for each pair of variables even if only one value is missing.} } \value{ -A \code{list} of fit metrics: +A \code{list} of fit metrics (one per each synthetic data replicate):: \itemize{ \item \code{co_occurrence_original}: co-occurrence matrix of the original data. \item \code{co_occurrence_synthetic}: co-occurrence matrix of the synthetic data. @@ -31,14 +29,18 @@ cells in the co-occurrence matrix. } } \description{ -Calculate the co-occurrence fit metric of a confidential data set. +Compare the co-occurrence fit metric of a confidential and synthetic dataset } \seealso{ -Other utility metrics: -\code{\link{util_corr_fit}()}, -\code{\link{util_moments}()}, -\code{\link{util_percentiles}()}, -\code{\link{util_tails}()}, -\code{\link{util_totals}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}}, +\code{\link[=util_proportions]{util_proportions()}} } -\concept{utility metrics} +\concept{Utility metrics} diff --git a/man/util_corr_fit.Rd b/man/util_corr_fit.Rd index 8044124..6cf673f 100644 --- a/man/util_corr_fit.Rd +++ b/man/util_corr_fit.Rd @@ -4,12 +4,10 @@ \alias{util_corr_fit} \title{Calculate the correlation fit metric of a confidential data set.} \usage{ -util_corr_fit(postsynth, data, use = "everything") +util_corr_fit(eval_data, use = "everything") } \arguments{ -\item{postsynth}{A postsynth object from tidysynthesis or a tibble} - -\item{data}{an original (observed) data set.} +\item{eval_data}{An \code{eval_data} object} \item{use}{optional character string giving a method for computing covariances in the presence of missing values. This must be (an abbreviation @@ -17,7 +15,7 @@ of) one of the strings "everything", "all.obs", "complete.obs", "na.or.complete", or "pairwise.complete.obs".} } \value{ -A \code{list} of fit metrics: +A \code{list} of fit metrics (one per each synthetic data replicate): \itemize{ \item \code{correlation_original}: correlation matrix of the original data. \item \code{correlation_synthetic}: correlation matrix of the synthetic data. @@ -32,11 +30,9 @@ cells in the correlation matrix. Calculate the correlation fit metric of a confidential data set. } \seealso{ -Other utility metrics: -\code{\link{util_co_occurrence}()}, -\code{\link{util_moments}()}, -\code{\link{util_percentiles}()}, -\code{\link{util_tails}()}, -\code{\link{util_totals}()} +Other utility metrics: +\code{\link[=util_moments]{util_moments()}}, +\code{\link[=util_percentiles]{util_percentiles()}}, +\code{\link[=util_totals]{util_totals()}} } \concept{utility metrics} diff --git a/man/util_ks_distance.Rd b/man/util_ks_distance.Rd index 85dbf1a..0d588e7 100644 --- a/man/util_ks_distance.Rd +++ b/man/util_ks_distance.Rd @@ -5,32 +5,31 @@ \title{Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in the synthetic and confidential data} \usage{ -util_ks_distance(postsynth, data, na.rm = FALSE) +util_ks_distance(eval_data, na.rm = FALSE) } \arguments{ -\item{postsynth}{a postsynth object or tibble with synthetic data} - -\item{data}{a data frame with the original data} +\item{eval_data}{An \code{eval_data} object} \item{na.rm}{a logical indicating whether missing values should be removed.} } \value{ A tibble with the D and location of the largest distance for each -numeric variable +numeric variable, one per synthetic data replicate } \description{ Calculate the Kolmogorov-Smirnov distance (D) for each numeric variable in the synthetic and confidential data } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_proportions}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_proportions]{util_proportions()}} } \concept{Utility metrics} diff --git a/man/util_moments.Rd b/man/util_moments.Rd index 96c4e1e..3f1a115 100644 --- a/man/util_moments.Rd +++ b/man/util_moments.Rd @@ -5,9 +5,8 @@ \title{Calculate summary statistics for original and synthetic data.} \usage{ util_moments( - postsynth, - data, - weight_var = 1, + eval_data, + weight_var = NULL, group_by = NULL, drop_zeros = FALSE, common_vars = TRUE, @@ -16,9 +15,7 @@ util_moments( ) } \arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} +\item{eval_data}{An \code{eval_data} object} \item{weight_var}{An unquoted name of a weight variable} @@ -28,7 +25,7 @@ util_moments( \item{common_vars}{A logical for if only common variables should be kept} -\item{synth_vars}{A logical for if only synthesized variables should be kept} +\item{synth_vars}{A logical for if \emph{only} synthesized variables should be kept} \item{na.rm}{A logical for ignoring \code{NA} values in computations.} } @@ -39,11 +36,9 @@ A \code{tibble} of summary statistics. Calculate summary statistics for original and synthetic data. } \seealso{ -Other utility metrics: -\code{\link{util_co_occurrence}()}, -\code{\link{util_corr_fit}()}, -\code{\link{util_percentiles}()}, -\code{\link{util_tails}()}, -\code{\link{util_totals}()} +Other utility metrics: +\code{\link[=util_corr_fit]{util_corr_fit()}}, +\code{\link[=util_percentiles]{util_percentiles()}}, +\code{\link[=util_totals]{util_totals()}} } \concept{utility metrics} diff --git a/man/util_percentiles.Rd b/man/util_percentiles.Rd index 1830f3b..ccd7ed7 100644 --- a/man/util_percentiles.Rd +++ b/man/util_percentiles.Rd @@ -5,8 +5,7 @@ \title{Calculate summary statistics for original and synthetic data.} \usage{ util_percentiles( - postsynth, - data, + eval_data, probs = c(0.1, 0.5, 0.9), weight_var = NULL, group_by = NULL, @@ -17,9 +16,7 @@ util_percentiles( ) } \arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} +\item{eval_data}{An \code{eval_data} object.} \item{probs}{A numeric vector of probabilities with values in [0,1]. The percentiles are interpolated using an empirical CDF. It's possible that the @@ -27,7 +24,7 @@ percentiles are an approximation; especially when weights are used.} \item{weight_var}{An unquoted name of a weight variable} -\item{group_by}{An unquoted name of a (or multiple) grouping variable(s)} +\item{group_by}{The unquoted name(s) of a (or multiple) grouping variable(s)} \item{drop_zeros}{A Boolean for if zeros should be dropped} @@ -40,17 +37,15 @@ about missing values.} \item{na.rm}{A logical for ignoring \code{NA} values in computations.} } \value{ -A \code{tibble} of summary statistics. +A \code{tibble} of summary statistics (one per synthetic data replicate) } \description{ Calculate summary statistics for original and synthetic data. } \seealso{ -Other utility metrics: -\code{\link{util_co_occurrence}()}, -\code{\link{util_corr_fit}()}, -\code{\link{util_moments}()}, -\code{\link{util_tails}()}, -\code{\link{util_totals}()} +Other utility metrics: +\code{\link[=util_corr_fit]{util_corr_fit()}}, +\code{\link[=util_moments]{util_moments()}}, +\code{\link[=util_totals]{util_totals()}} } \concept{utility metrics} diff --git a/man/util_proportions.Rd b/man/util_proportions.Rd index 54bfd86..a13196c 100644 --- a/man/util_proportions.Rd +++ b/man/util_proportions.Rd @@ -5,8 +5,7 @@ \title{Calculate relative frequency tables for categorical variables} \usage{ util_proportions( - postsynth, - data, + eval_data, weight_var = NULL, group_by = NULL, common_vars = TRUE, @@ -16,17 +15,15 @@ util_proportions( ) } \arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} +\item{eval_data}{An \code{eval_data} object} \item{weight_var}{An unquoted name of a weight variable} -\item{group_by}{An unquoted name of a (or multiple) grouping variable(s)} +\item{group_by}{The unquoted name(s) of a (or multiple) grouping variable(s)} \item{common_vars}{A logical for if only common variables should be kept} -\item{synth_vars}{A logical for if only synthesized variables should be kept} +\item{synth_vars}{A logical for if \emph{only} synthesized variables should be kept} \item{keep_empty_levels}{A logical for keeping all class levels in the group_by statements, including missing levels.} @@ -40,14 +37,15 @@ A tibble with variables, classes, and relative frequencies Calculate relative frequency tables for categorical variables } \seealso{ -Other Utility metrics: -\code{\link{add_pmse}()}, -\code{\link{add_pmse_ratio}()}, -\code{\link{add_propensities}()}, -\code{\link{add_propensities_tuned}()}, -\code{\link{add_specks}()}, -\code{\link{discrimination}()}, -\code{\link{util_ci_overlap}()}, -\code{\link{util_ks_distance}()} +Other Utility metrics: +\code{\link[=add_pmse]{add_pmse()}}, +\code{\link[=add_pmse_ratio]{add_pmse_ratio()}}, +\code{\link[=add_propensities]{add_propensities()}}, +\code{\link[=add_propensities_tuned]{add_propensities_tuned()}}, +\code{\link[=add_specks]{add_specks()}}, +\code{\link[=discrimination]{discrimination()}}, +\code{\link[=util_ci_overlap]{util_ci_overlap()}}, +\code{\link[=util_co_occurrence]{util_co_occurrence()}}, +\code{\link[=util_ks_distance]{util_ks_distance()}} } \concept{Utility metrics} diff --git a/man/util_tails.Rd b/man/util_tails.Rd deleted file mode 100644 index 9125cb1..0000000 --- a/man/util_tails.Rd +++ /dev/null @@ -1,34 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/util_tails.R -\name{util_tails} -\alias{util_tails} -\title{Explore the tails of numeric variables} -\usage{ -util_tails(postsynth, data, n = 10, weight_var = 1, end = "max") -} -\arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} - -\item{n}{The number of observations to consider for each variable} - -\item{weight_var}{An unquoted name of a weight variable} - -\item{end}{"min" for minimum values and "max" for maximum values} -} -\value{ -A \code{tibble} of summary statistics. -} -\description{ -Explore the tails of numeric variables -} -\seealso{ -Other utility metrics: -\code{\link{util_co_occurrence}()}, -\code{\link{util_corr_fit}()}, -\code{\link{util_moments}()}, -\code{\link{util_percentiles}()}, -\code{\link{util_totals}()} -} -\concept{utility metrics} diff --git a/man/util_totals.Rd b/man/util_totals.Rd index 2382eb4..b7f0b65 100644 --- a/man/util_totals.Rd +++ b/man/util_totals.Rd @@ -5,9 +5,8 @@ \title{Calculate totals for original and synthetic data.} \usage{ util_totals( - postsynth, - data, - weight_var = 1, + eval_data, + weight_var = NULL, group_by = NULL, common_vars = TRUE, synth_vars = TRUE, @@ -15,9 +14,7 @@ util_totals( ) } \arguments{ -\item{postsynth}{A postsynth object or tibble with synthetic data} - -\item{data}{A data frame with the original data} +\item{eval_data}{An \code{eval_data} object} \item{weight_var}{An unquoted name of a weight variable} @@ -36,11 +33,9 @@ A \code{tibble} of totals. Calculate totals for original and synthetic data. } \seealso{ -Other utility metrics: -\code{\link{util_co_occurrence}()}, -\code{\link{util_corr_fit}()}, -\code{\link{util_moments}()}, -\code{\link{util_percentiles}()}, -\code{\link{util_tails}()} +Other utility metrics: +\code{\link[=util_corr_fit]{util_corr_fit()}}, +\code{\link[=util_moments]{util_moments()}}, +\code{\link[=util_percentiles]{util_percentiles()}} } \concept{utility metrics} diff --git a/syntheval.Rproj b/syntheval.Rproj index 21a4da0..4307293 100644 --- a/syntheval.Rproj +++ b/syntheval.Rproj @@ -1,4 +1,5 @@ Version: 1.0 +ProjectId: d2c2ffc0-e150-4f0b-afb1-576420f84a70 RestoreWorkspace: Default SaveWorkspace: Default diff --git a/tests/testthat/test-add_discriminator_auc.R b/tests/testthat/test-add_discriminator_auc.R index 581424e..af92f6f 100644 --- a/tests/testthat/test-add_discriminator_auc.R +++ b/tests/testthat/test-add_discriminator_auc.R @@ -17,13 +17,15 @@ test_that("add_discriminator_auc returns perfect value for identical data (no sp ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) - disc <- discrimination(postsynth, data) %>% + disc <- discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -53,14 +55,16 @@ test_that("add_discriminator_auc returns perfect value for identical data (split ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -97,14 +101,16 @@ test_that("add_pmse returns perfect value for seperable data (no split)" , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod diff --git a/tests/testthat/test-add_pmse_ratio.R b/tests/testthat/test-add_pmse_ratio.R index 8b5fd02..a4c3012 100644 --- a/tests/testthat/test-add_pmse_ratio.R +++ b/tests/testthat/test-add_pmse_ratio.R @@ -17,14 +17,16 @@ test_that("add_pmse returns ideal value for identical data with variation " , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + dt_mod <- parsnip::decision_tree() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "rpart") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = dt_mod @@ -70,17 +72,19 @@ test_that("add_pmse returns perfect value for identical data without variation " ) %>% structure(class = "postsynth") - logistic_mod <- parsnip::logistic_reg() %>% + ed <- eval_data(conf_data = data, synth_data = postsynth) + + dt_mod <- parsnip::decision_tree() %>% parsnip::set_mode(mode = "classification") %>% - parsnip::set_engine(engine = "glm") + parsnip::set_engine(engine = "rpart") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, - spec = logistic_mod + spec = dt_mod ) %>% add_pmse() %>% add_pmse_ratio(times = 25) diff --git a/tests/testthat/test-add_propensities.R b/tests/testthat/test-add_propensities.R index 1565eee..76e8156 100644 --- a/tests/testthat/test-add_propensities.R +++ b/tests/testthat/test-add_propensities.R @@ -20,11 +20,12 @@ test_that("Three recipe methods return identical results" , { parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(penguins_postsynth, penguins_conf)$combined_data) + ed <- eval_data(conf_data = penguins_conf, synth_data = penguins_postsynth) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) # recipe and formula set.seed(1) - approach_custom <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) %>% + approach_custom <- discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -33,7 +34,7 @@ test_that("Three recipe methods return identical results" , { # no recipe, no formula set.seed(1) approach_default <- suppressMessages( - discrimination(postsynth = penguins_postsynth, data = penguins_conf) %>% + discrimination(ed) %>% add_propensities( spec = logistic_mod ) @@ -41,12 +42,17 @@ test_that("Three recipe methods return identical results" , { # formula and no recipe set.seed(1) - approach_formula <- discrimination(postsynth = penguins_postsynth, data = penguins_conf) %>% + approach_formula <- discrimination(ed) %>% add_propensities( spec = logistic_mod, formula = .source_label ~ . ) + # remove elapsed element + approach_custom$discriminator$fit$fit$elapsed$elapsed <- NULL + approach_default$discriminator$fit$fit$elapsed$elapsed <- NULL + approach_formula$discriminator$fit$fit$elapsed$elapsed <- NULL + expect_equal(approach_custom, approach_default) expect_equal(approach_custom, approach_formula) diff --git a/tests/testthat/test-add_propensities_tuned.R b/tests/testthat/test-add_propensities_tuned.R new file mode 100644 index 0000000..66a2f03 --- /dev/null +++ b/tests/testthat/test-add_propensities_tuned.R @@ -0,0 +1,45 @@ +test_that("add_propensities_tuned returns propensities and fitted workflow", { + + skip_if_not_installed("glmnet") + + logistic_mod <- parsnip::logistic_reg(penalty = tune::tune()) |> + parsnip::set_mode(mode = "classification") |> + parsnip::set_engine(engine = "glmnet") + + # build evaluation/discrimination object using small example data + ed <- eval_data(conf_data = penguins_conf, synth_data = penguins_postsynth) + disc <- discrimination(ed) + + rec <- recipes::recipe(.source_label ~ ., data = disc$combined_data) |> + recipes::step_dummy(recipes::all_nominal_predictors()) + + # very small tuning grid and 2-fold CV for speed in tests + grid <- tibble::tibble(penalty = c(1e-3, 1e-2)) + + set.seed(123) + out <- disc |> + add_propensities_tuned( + spec = logistic_mod, + recipe = rec, + grid = grid, + v = 2, + prop = 0.7, + save_fit = TRUE + ) + + # basic structural assertions + expect_s3_class(out, "discrimination") + expect_true("propensities" %in% names(out)) + + p <- out[["propensities"]] + expect_equal(nrow(p), nrow(disc[["combined_data"]])) + expect_true(".pred_synthetic" %in% colnames(p)) + expect_type(p$.pred_synthetic, "double") + expect_true(all(p$.pred_synthetic >= 0 & p$.pred_synthetic <= 1)) + expect_true(".sample" %in% colnames(p)) + expect_true(all(p$.sample %in% c("training", "testing"))) + + # fitted workflow should be stored on the discrimination object + expect_s3_class(out$discriminator, "workflow") + +}) diff --git a/tests/testthat/test-add_specks.R b/tests/testthat/test-add_specks.R index b3fd127..6d0affb 100644 --- a/tests/testthat/test-add_specks.R +++ b/tests/testthat/test-add_specks.R @@ -17,13 +17,15 @@ test_that("add_specks returns perfect value for identical data (no split) " , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) - disc <- discrimination(postsynth, data) %>% + disc <- discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -53,14 +55,16 @@ test_that("add_specks returns perfect value for identical data (split) " , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -95,14 +99,16 @@ test_that("add_specks returns 1 for perfectly different data (no split) " , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod @@ -137,14 +143,16 @@ test_that("add_specks returns 1 for perfectly different data (split) " , { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = data, synth_data = postsynth) + logistic_mod <- parsnip::logistic_reg() %>% parsnip::set_mode(mode = "classification") %>% parsnip::set_engine(engine = "glm") - rec <- recipes::recipe(.source_label ~ ., data = discrimination(postsynth, data)$combined_data) + rec <- recipes::recipe(.source_label ~ ., data = discrimination(ed)$combined_data) disc <- suppressWarnings( - discrimination(postsynth, data) %>% + discrimination(ed) %>% add_propensities( recipe = rec, spec = logistic_mod diff --git a/tests/testthat/test-disc_mit.R b/tests/testthat/test-disc_mit.R index 0f87d51..cfa670b 100644 --- a/tests/testthat/test-disc_mit.R +++ b/tests/testthat/test-disc_mit.R @@ -17,7 +17,10 @@ postsynth <- list( synthetic_data = tibble::tibble( a = c(1, 1, 1, 1), b = c(1, 1, 1, 1) - ) + ), + jth_synthesis_time = data.frame( + variable = factor(c("a", "b")) + ) ) class(postsynth) <- "postsynth" diff --git a/tests/testthat/test-discrimination.R b/tests/testthat/test-discrimination.R index 893de38..7a44429 100644 --- a/tests/testthat/test-discrimination.R +++ b/tests/testthat/test-discrimination.R @@ -1,6 +1,9 @@ + test_that("discrimination() returns the correct object " , { - discrimination <- discrimination(penguins_postsynth, penguins_conf) + ed <- eval_data(conf_data = penguins_conf, synth_data = penguins_postsynth) + + discrimination <- discrimination(ed) expect_equal(nrow(discrimination$combined_data), nrow(penguins_postsynth$synthetic_data) + nrow(penguins_conf)) @@ -14,11 +17,12 @@ test_that("discrimination() returns the correct object when sysnthesizing a subs postsynth_narrow <- penguins_postsynth postsynth_narrow$synthetic_data <- dplyr::select(postsynth_narrow$synthetic_data, -bill_depth_mm) - # expect warning for mismatched columns - expect_message(discrimination(postsynth_narrow, penguins_conf)) + ed1 <- eval_data(conf_data = penguins_conf, synth_data = postsynth_narrow) - # create discrimination to test dimensions - discrimination <- suppressMessages(discrimination(postsynth_narrow, penguins_conf)) + # expect warning for mismatched columns + expect_message( + discrimination <- discrimination(ed1) + ) expect_equal(nrow(discrimination$combined_data), nrow(postsynth_narrow$synthetic_data) + nrow(penguins_conf)) diff --git a/tests/testthat/test-util_ci_overlap.R b/tests/testthat/test-util_ci_overlap.R index 4a80d4c..9f34ed2 100644 --- a/tests/testthat/test-util_ci_overlap.R +++ b/tests/testthat/test-util_ci_overlap.R @@ -1,7 +1,7 @@ # test with postsynth test_that("overlap is zero for identical data ", { - overlap1 <- util_ci_overlap(postsynth = cars, data = cars, formula = dist ~ speed) + overlap1 <- util_ci_overlap(eval_data(cars, cars), formula = dist ~ speed) expect_equal(overlap1$ci_overlap$overlap, c(1, 1)) expect_equal(overlap1$ci_overlap$coef_diff, c(0, 0)) @@ -36,7 +36,9 @@ test_that("overlap is 1 for adjacent data ", { cars2 <- cars cars2$dist <- cars$dist + offset - overlap2 <- util_ci_overlap(postsynth = cars, data = cars2, formula = dist ~ speed) + eval_data <- eval_data(conf_data = cars2, synth_data = cars) + + overlap2 <- util_ci_overlap(eval_data, formula = dist ~ speed) expect_equal(overlap2$ci_overlap$overlap, c(0, 1)) diff --git a/tests/testthat/test-util_co_occurrence.R b/tests/testthat/test-util_co_occurrence.R index 7cdd4b9..aa2daa3 100644 --- a/tests/testthat/test-util_co_occurrence.R +++ b/tests/testthat/test-util_co_occurrence.R @@ -5,13 +5,22 @@ df <- data.frame(a = c(1, 0, 1, 2), syn <- list(synthetic_data = data.frame(a = c(1, 0, 0, 0), c = c("c", "c", "c", "c"), - b = c(1, 0, 0, 0))) %>% + b = c(1, 0, 0, 0)), + jth_synthesis_time = data.frame( + variable = factor(c("a", "c", "b")) + )) %>% structure(class = "postsynth") +ed0 <- eval_data(conf_data = df, synth_data = df) + +ed1 <- eval_data(conf_data = df, synth_data = syn) + + + # test with postsynth test_that("util_co_occurrence() is correct with identical data ", { - co_occurrence <- util_co_occurrence(postsynth = df, data = df) + co_occurrence <- util_co_occurrence(ed0) diff_matrix <- matrix(c(NA, NA, 0, NA), byrow = TRUE, nrow = 2, ncol = 2) colnames(diff_matrix) <- c("a", "b") @@ -20,36 +29,32 @@ test_that("util_co_occurrence() is correct with identical data ", { expect_equal(co_occurrence$co_occurrence_difference, diff_matrix) expect_equal(co_occurrence$co_occurrence_difference_mae, 0) expect_equal(co_occurrence$co_occurrence_difference_rmse, 0) + }) # test with data test_that("util_co_occurrence() is correct with different data ", { - co_occurrence <- util_co_occurrence(postsynth = syn, data = df) + co_occurrence <- util_co_occurrence(ed1) diff_matrix <- matrix(c(NA, NA, -0.25, NA), byrow = TRUE, nrow = 2, ncol = 2) colnames(diff_matrix) <- c("a", "b") rownames(diff_matrix) <- c("a", "b") - - co_occurrence <- util_co_occurrence(postsynth = syn, data = df) expect_equal(co_occurrence$co_occurrence_difference, diff_matrix) expect_equal(co_occurrence$co_occurrence_difference_mae, mean(abs(-0.25))) expect_equal(co_occurrence$co_occurrence_difference_rmse, sqrt(mean((-0.25) ^ 2))) + }) test_that("util_co_occurrence() works with NA ", { - syn <- list( - synthetic_data = acs_conf - ) %>% - structure(class = "postsynth") - - co_occurrence <- util_co_occurrence( - postsynth = syn, - data = acs_conf, - na.rm = TRUE + ed2 <- eval_data( + synth_data = acs_conf, + conf_data = acs_conf ) + + co_occurrence <- util_co_occurrence(ed2, na.rm = TRUE) expect_equal(max(co_occurrence$co_occurrence_difference, na.rm = TRUE), 0) expect_equal(co_occurrence$co_occurrence_difference_mae, 0) diff --git a/tests/testthat/test-util_corr_fit.R b/tests/testthat/test-util_corr_fit.R index 6fe3162..9d04322 100644 --- a/tests/testthat/test-util_corr_fit.R +++ b/tests/testthat/test-util_corr_fit.R @@ -22,15 +22,21 @@ test_that("util_corr_fit is correct with postsynth ", { syn <- list(synthetic_data = data.frame(a = c(1, 2, 3), c = c(3, 2, 1), b = c(1, 2, 3), - RECID = c("a", "b", "c"))) %>% + RECID = c("a", "b", "c")), + jth_synthesis_time = data.frame( + variable = factor(c("a", "c", "b")) + )) %>% structure(class = "postsynth") - corr <- util_corr_fit(postsynth = syn, data = df) + ed <- eval_data(conf_data = df, synth_data = syn) + + corr <- util_corr_fit(ed) expect_equal(corr$correlation_difference, diff_matrix) expect_equal(corr$correlation_fit, sqrt(sum(c(0, -2, -2) ^ 2)) / 3) expect_equal(corr$correlation_difference_mae, mean(abs(c(0, -2, -2)))) expect_equal(corr$correlation_difference_rmse, sqrt(mean(c(0, -2, -2) ^ 2))) + }) # test with data @@ -41,7 +47,9 @@ test_that("util_corr_fit is correct with postsynth ", { b = c(1, 2, 3), RECID = c("a", "b", "c")) - corr <- util_corr_fit(postsynth = syn, data = df) + ed <- eval_data(conf_data = df, synth_data = syn) + + corr <- util_corr_fit(ed) expect_equal(corr$correlation_difference, diff_matrix) expect_equal(corr$correlation_fit, sqrt(sum(c(0, -2, -2) ^ 2)) / 3) @@ -51,16 +59,9 @@ test_that("util_corr_fit is correct with postsynth ", { test_that("util_corr_fit works with NA ", { - syn <- list( - synthetic_data = acs_conf - ) %>% - structure(class = "postsynth") + ed <- eval_data(synth_data = acs_conf, conf_data = acs_conf) - corr <- util_corr_fit( - postsynth = syn, - data = acs_conf, - use = "pairwise.complete.obs" - ) + corr <- util_corr_fit(eval_data = ed, use = "pairwise.complete.obs") expect_equal(max(corr$correlation_difference, na.rm = TRUE), 0) expect_equal(corr$correlation_fit, 0) diff --git a/tests/testthat/test-util_ks-distance.R b/tests/testthat/test-util_ks-distance.R index 40e7c07..fdd71e2 100644 --- a/tests/testthat/test-util_ks-distance.R +++ b/tests/testthat/test-util_ks-distance.R @@ -6,19 +6,15 @@ df <- data.frame( test_that("KS is 0 ", { - syn <- list( - synthetic_data = data.frame( - a = c(1, 2, 3, 4, NA), - b = c(1, 2, 3, 4, NA), - c = c("a", "a", "b", "b", NA) - ), - jth_synthesis_time = data.frame( - variable = factor(c("a", "b")) - ) - ) %>% - structure(class = "postsynth") - - D <- util_ks_distance(postsynth = syn, data = df, na.rm = TRUE) + syn <- data.frame( + a = c(1, 2, 3, 4, NA), + b = c(1, 2, 3, 4, NA), + c = c("a", "a", "b", "b", NA) + ) + + ed <- eval_data(conf_data = df, synth_data = syn) + + D <- util_ks_distance(ed, na.rm = TRUE) expect_equal(D$D, rep(0, 8)) @@ -26,19 +22,15 @@ test_that("KS is 0 ", { test_that("KS distance is 0.5 ", { - syn <- list( - synthetic_data = data.frame( - a = c(3, 4, 5, 6, NA), - b = c(3, 4, 5, 6, NA), - c = c("a", "a", "b", "b", NA) - ), - jth_synthesis_time = data.frame( - variable = factor(c("a", "b")) - ) - ) %>% - structure(class = "postsynth") - - D <- util_ks_distance(postsynth = syn, data = df, na.rm = TRUE) + syn <- data.frame( + a = c(3, 4, 5, 6, NA), + b = c(3, 4, 5, 6, NA), + c = c("a", "a", "b", "b", NA) + ) + + ed <- eval_data(conf_data = df, synth_data = syn) + + D <- util_ks_distance(ed, na.rm = TRUE) expect_equal(D$D, rep(0.5, 4)) @@ -46,19 +38,15 @@ test_that("KS distance is 0.5 ", { test_that("KS distance is 1 ", { - syn <- list( - synthetic_data = data.frame( - a = c(60, 70, 80, 90, NA), - b = c(60, 70, 80, 90, NA), - c = c("a", "a", "b", "b", NA) - ), - jth_synthesis_time = data.frame( - variable = factor(c("a", "b")) - ) - ) %>% - structure(class = "postsynth") + syn <- data.frame( + a = c(60, 70, 80, 90, NA), + b = c(60, 70, 80, 90, NA), + c = c("a", "a", "b", "b", NA) + ) + + ed <- eval_data(conf_data = df, synth_data = syn) - D <- util_ks_distance(postsynth = syn, data = df, na.rm = TRUE) + D <- util_ks_distance(ed, na.rm = TRUE) expect_equal(D$D, c(1, 1)) @@ -66,15 +54,9 @@ test_that("KS distance is 1 ", { test_that("KS distance works with NA ", { - syn <- list( - synthetic_data = acs_conf - ) %>% - structure(class = "postsynth") + ed <- eval_data(conf_data = acs_conf, synth_data = acs_conf) - D <- util_ks_distance( - postsynth = syn, - data = acs_conf, - na.rm = TRUE) + D <- util_ks_distance(ed, na.rm = TRUE) expect_equal(max(D$D), 0) diff --git a/tests/testthat/test-util_moments.R b/tests/testthat/test-util_moments.R index 3a43524..18e638d 100644 --- a/tests/testthat/test-util_moments.R +++ b/tests/testthat/test-util_moments.R @@ -48,14 +48,13 @@ syn_na <- list( ) %>% structure(class = "postsynth") +ed0 <- eval_data(synth_data = df, conf_data = df) +ed1 <- eval_data(synth_data = syn, conf_data = df) + # full unweighted - postysynth test_that("moments full unweighted -- postsynth ", { - summary_stats <- - util_moments( - postsynth = syn, - data = df - ) %>% + summary_stats <- util_moments(ed1) %>% dplyr::filter(variable == "a") expect_equal( @@ -70,11 +69,7 @@ test_that("moments full unweighted -- postsynth ", { test_that("moments full unweighted -- df ", { - summary_stats <- - util_moments( - postsynth = df, - data = df - ) %>% + summary_stats <- util_moments(ed0) %>% dplyr::filter(variable == "a") expect_equal( @@ -90,12 +85,7 @@ test_that("moments full unweighted -- df ", { # full weighted test_that("moments full weighted -- postsynth", { - summary_stats <- - util_moments( - postsynth = syn, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_moments(ed1, weight_var = weight) %>% dplyr::filter(variable == "a") expect_equal( @@ -110,12 +100,7 @@ test_that("moments full weighted -- postsynth", { test_that("moments full weighted -- df", { - summary_stats <- - util_moments( - postsynth = df, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_moments(ed0, weight_var = weight) %>% dplyr::filter(variable == "a") expect_equal( @@ -130,12 +115,7 @@ test_that("moments full weighted -- df", { test_that("moments nonzero unweighted -- postsynth", { - summary_stats <- - util_moments( - postsynth = syn, - data = df, - drop_zeros = TRUE - ) %>% + summary_stats <- util_moments(ed1, drop_zeros = TRUE) %>% dplyr::filter(variable == "d") expect_equal( @@ -150,12 +130,7 @@ test_that("moments nonzero unweighted -- postsynth", { test_that("moments nonzero unweighted -- postsynth", { - summary_stats <- - util_moments( - postsynth = df, - data = df, - drop_zeros = TRUE - ) %>% + summary_stats <- util_moments(ed0, drop_zeros = TRUE) %>% dplyr::filter(variable == "d") expect_equal( @@ -170,10 +145,8 @@ test_that("moments nonzero unweighted -- postsynth", { test_that("moments nonzero weighted -- postsynth", { - summary_stats <- - util_moments( - postsynth = syn, - data = df, + summary_stats <- util_moments( + ed1, weight_var = weight, drop_zeros = TRUE ) %>% @@ -191,10 +164,8 @@ test_that("moments nonzero weighted -- postsynth", { test_that("moments nonzero weighted -- df", { - summary_stats <- - util_moments( - postsynth = df, - data = df, + summary_stats <- util_moments( + ed0, weight_var = weight, drop_zeros = TRUE ) %>% @@ -212,10 +183,8 @@ test_that("moments nonzero weighted -- df", { test_that("moments test grouping var ", { - summary_stats <- - util_moments( - postsynth = syn, - data = df, + summary_stats <- util_moments( + ed1, weight_var = weight, group_by = c ) %>% @@ -234,10 +203,8 @@ test_that("moments test grouping var ", { }) test_that("moments grouping by multiple variables", { - summary_stats <- - util_moments( - postsynth = syn, - data = df, + summary_stats <- util_moments( + ed1, weight_var = weight, group_by = c(c, e) ) %>% @@ -269,13 +236,14 @@ test_that("util_moments() variables selection returns correct dimensions ", { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = storms_sub, synth_data = syn) + # are variable names missing ever? expect_message( expect_false( util_moments( - postsynth = syn, - data = storms_sub, - common_vars = FALSE, + ed, + common_vars = FALSE, synth_vars = FALSE )$variable %>% is.na() %>% @@ -283,29 +251,26 @@ test_that("util_moments() variables selection returns correct dimensions ", { ) ) - # are statistics names missing ever? expect_message( expect_false( util_moments( - postsynth = syn, - data = storms_sub, - common_vars = FALSE, + ed, + common_vars = FALSE, synth_vars = FALSE )$statistic %>% is.na() %>% all() ) ) - + # 55 rows = all 11 variables times 5 statistics expect_message( expect_equal( dim( util_moments( - postsynth = syn, - data = storms_sub, - common_vars = FALSE, + ed, + common_vars = FALSE, synth_vars = FALSE ) ), @@ -318,9 +283,8 @@ test_that("util_moments() variables selection returns correct dimensions ", { expect_equal( dim( util_moments( - postsynth = syn, - data = storms_sub, - common_vars = TRUE, + ed, + common_vars = TRUE, synth_vars = FALSE ) ), @@ -333,8 +297,7 @@ test_that("util_moments() variables selection returns correct dimensions ", { expect_equal( dim( util_moments( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = TRUE ) @@ -346,8 +309,7 @@ test_that("util_moments() variables selection returns correct dimensions ", { expect_equal( dim( util_moments( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = TRUE ) @@ -359,10 +321,12 @@ test_that("util_moments() variables selection returns correct dimensions ", { test_that("util_moments na.rm works as expected", { + + ed <- eval_data(synth_data = syn_na, conf_data = df_na) + expect_message( res <- util_moments( - postsynth = syn_na, - data = df_na, + ed, na.rm = FALSE ) ) @@ -371,8 +335,7 @@ test_that("util_moments na.rm works as expected", { ) res_rm <- util_moments( - postsynth = syn_na, - data = df_na, + ed, na.rm = TRUE ) diff --git a/tests/testthat/test-util_percentiles.R b/tests/testthat/test-util_percentiles.R index ed28b53..b6dd2c9 100644 --- a/tests/testthat/test-util_percentiles.R +++ b/tests/testthat/test-util_percentiles.R @@ -48,13 +48,13 @@ syn_na <- list( ) %>% structure(class = "postsynth") +ed0 <- eval_data(conf_data = df, synth_data = df) +ed1 <- eval_data(conf_data = df, synth_data = syn) +ed_na <- eval_data(conf_data = df_na, synth_data = syn_na) + test_that("unweighted percentiles make sense ", { - test1 <- util_percentiles( - postsynth = syn, - data = df, - probs = 0.5 - ) + test1 <- util_percentiles(ed1, probs = 0.5) # does the dimension make sense? expect_equal( @@ -79,10 +79,10 @@ test_that("unweighted percentiles make sense ", { test_that("weighted percentiles make sense ", { test2 <- util_percentiles( - postsynth = syn, - data = df, + ed1, probs = 0.5, - weight_var = weight + weight_var = weight, + synth_vars = FALSE ) # does the dimension make sense? @@ -108,8 +108,7 @@ test_that("weighted percentiles make sense ", { test_that("percentiles can handle multiple percentile ", { test3 <- util_percentiles( - postsynth = syn, - data = df, + ed1, probs = c(0.01, 0.99), weight_var = weight ) @@ -121,8 +120,7 @@ test_that("percentiles can handle multiple percentile ", { ) test4 <- util_percentiles( - postsynth = syn, - data = df, + ed1, probs = c(0.1, 0.5, 0.9), weight_var = weight ) @@ -138,8 +136,7 @@ test_that("percentiles can handle multiple percentile ", { test_that("unweighted percentiles grouped by one variable ", { test5 <- util_percentiles( - postsynth = syn, - data = df, + ed1, probs = 0.5, group_by = c ) @@ -168,8 +165,7 @@ test_that("unweighted percentiles grouped by one variable ", { test_that("unweighted percentiles grouped by multiple variables ", { test6 <- util_percentiles( - postsynth = syn, - data = df, + ed1, probs = 0.5, group_by = c(c, e) ) @@ -218,11 +214,12 @@ test_that("util_percentiles() variables selection returns correct dimensions ", ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = storms_sub, synth_data = syn) + # are variable names missing ever? expect_false( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = FALSE )$variable %>% @@ -233,8 +230,7 @@ test_that("util_percentiles() variables selection returns correct dimensions ", # are statistics names missing ever? expect_false( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = FALSE )$p %>% @@ -246,8 +242,7 @@ test_that("util_percentiles() variables selection returns correct dimensions ", expect_message( expect_error( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE ) @@ -258,8 +253,7 @@ test_that("util_percentiles() variables selection returns correct dimensions ", expect_equal( dim( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = FALSE ) @@ -271,8 +265,7 @@ test_that("util_percentiles() variables selection returns correct dimensions ", expect_equal( dim( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = TRUE ) @@ -284,8 +277,7 @@ test_that("util_percentiles() variables selection returns correct dimensions ", expect_equal( dim( util_percentiles( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = TRUE ) @@ -301,8 +293,7 @@ test_that("util_percentiles na.rm", { expect_message( expect_error( util_percentiles( - postsynth = syn_na, - data = df_na, + ed_na, probs = 0.5, na.rm = FALSE ) @@ -311,8 +302,7 @@ test_that("util_percentiles na.rm", { # else, re res <- util_percentiles( - postsynth = syn_na, - data = df_na, + ed_na, probs = 0.5, na.rm = TRUE ) diff --git a/tests/testthat/test-util_plots.R b/tests/testthat/test-util_plots.R index 7fc785d..be4d7bd 100644 --- a/tests/testthat/test-util_plots.R +++ b/tests/testthat/test-util_plots.R @@ -12,31 +12,27 @@ synth_df <- data.frame( c2 = factor(c("a", "b", "a", "b")) ) -joint_data <- dplyr::bind_rows( - confidential = conf_df, - synthetic = synth_df, - .id = "source" -) +ed <- eval_data(conf_data = conf_df, synth_data = synth_df) test_that("plot_numeric_hist_kde throws expected errors", { expect_error( - plot_numeric_hist_kde(joint_data, "c1") + plot_numeric_hist_kde(ed, "c1") ) expect_error( - plot_numeric_hist_kde(joint_data, "n1", "n2") + plot_numeric_hist_kde(ed, "n1", "n2") ) expect_error( - plot_numeric_hist_kde(joint_data, "n1", "c1", "n2") + plot_numeric_hist_kde(ed, "n1", "c1", "n2") ) }) test_that("plot_numeric_hist_kde creates the right ggplot", { - plot <- plot_numeric_hist_kde(joint_data, "n1") + plot <- plot_numeric_hist_kde(ed, "n1") expect_s3_class(plot$layers[[1]]$geom, "GeomBar") expect_s3_class(plot$layers[[2]]$geom, "GeomDensity") @@ -45,22 +41,22 @@ test_that("plot_numeric_hist_kde creates the right ggplot", { test_that("plot_categorical_bar throws expected errors", { expect_error( - plot_categorical_bar(joint_data, "n1") + plot_categorical_bar(ed, "n1") ) expect_error( - plot_categorical_bar(joint_data, "c1", "n2") + plot_categorical_bar(ed, "c1", "n2") ) expect_error( - plot_categorical_bar(joint_data, "c1", "c1", "n2") + plot_categorical_bar(ed, "c1", "c1", "n2") ) }) test_that("plot_categorical_bar creates the right ggplot", { - plot <- plot_categorical_bar(joint_data, "c1") + plot <- plot_categorical_bar(ed, "c1") expect_s3_class(plot$layers[[1]]$geom, "GeomBar") }) @@ -74,10 +70,18 @@ test_that("create_cormat_plot creates the right ggplot", { }) +test_that("plot_cormat throws expected errors", { + + expect_error( + plot_cormat(conf_df) + ) + +}) + test_that("plot_cormat creates the right ggplot", { - - plot <- plot_cormat(conf_df, synth_df) - + + plot <- plot_cormat(ed) + expect_equal(length(plot$grobs), 2) - + }) \ No newline at end of file diff --git a/tests/testthat/test-util_proportions.R b/tests/testthat/test-util_proportions.R index 616d741..b6818e0 100644 --- a/tests/testthat/test-util_proportions.R +++ b/tests/testthat/test-util_proportions.R @@ -45,14 +45,13 @@ syn_na <- list( ) %>% structure(class = "postsynth") +ed0 <- eval_data(conf_data = df, synth_data = df) +ed1 <- eval_data(conf_data = df, synth_data = syn) + # testing variable selection test_that("testing if proportions only uses fct and chr variables", { - summary_stats <- - util_proportions( - postsynth = syn, - data = df - ) + summary_stats <- util_proportions(ed1) expect_equal( unique(summary_stats$variable), @@ -63,11 +62,7 @@ test_that("testing if proportions only uses fct and chr variables", { # testing proportions test_that("testing if proportions are correct -- postsynth", { - summary_stats <- - util_proportions( - postsynth = syn, - data = df - ) + summary_stats <- util_proportions(ed1) expect_equal( round(summary_stats$original, 3), @@ -83,11 +78,7 @@ test_that("testing if proportions are correct -- postsynth", { test_that("testing if proportions are correct -- df", { - summary_stats <- - util_proportions( - postsynth = df, - data = df - ) + summary_stats <- util_proportions(ed0) expect_equal( round(summary_stats$original, 3), @@ -103,12 +94,7 @@ test_that("testing if proportions are correct -- df", { # with group_by specified test_that("testing if proportions are correct w/ group_by -- postsynth", { - summary_stats <- - util_proportions( - postsynth = syn, - data = df, - group_by = c - ) + summary_stats <- util_proportions(ed1, group_by = c) expect_equal( summary_stats$original, @@ -123,12 +109,7 @@ test_that("testing if proportions are correct w/ group_by -- postsynth", { test_that("testing if proportions are correct w/ group_by -- df", { - summary_stats <- - util_proportions( - postsynth = df, - data = df, - group_by = c - ) + summary_stats <- util_proportions(ed0, group_by = c) expect_equal( summary_stats$original, @@ -144,12 +125,7 @@ test_that("testing if proportions are correct w/ group_by -- df", { # with weight_var specified test_that("testing if proportions w/ weight_var are correct -- postsynth", { - summary_stats <- - util_proportions( - postsynth = syn, - data = df, - weight_var = weight - ) + summary_stats <- util_proportions(ed1, weight_var = weight) expect_equal( summary_stats$original, @@ -165,12 +141,7 @@ test_that("testing if proportions w/ weight_var are correct -- postsynth", { test_that("testing if proportions w/ weight_var are correct -- df", { - summary_stats <- - util_proportions( - postsynth = df, - data = df, - weight_var = weight - ) + summary_stats <- util_proportions(ed0, weight_var = weight) expect_equal( summary_stats$original, @@ -190,8 +161,7 @@ test_that("testing if proportions w/ weight_var and group_by are correct summary_stats <- util_proportions( - postsynth = syn, - data = df, + ed1, weight_var = weight, group_by = c ) @@ -213,8 +183,7 @@ test_that("testing if proportions w/ weight_var and group_by are correct summary_stats <- util_proportions( - postsynth = df, - data = df, + ed0, weight_var = weight, group_by = c ) @@ -259,11 +228,11 @@ test_that("test util_proportions() with multiple grouping variables", { ) %>% structure(class = "postsynth") + ed2 <- eval_data(conf_data = df2, synth_data = syn2) summary_stats <- util_proportions( - postsynth = syn2, - data = df2, + ed2, weight_var = weight, group_by = c(var2, var3) ) @@ -299,11 +268,12 @@ test_that("util_proportions() variables selection returns correct dimensions ", ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = storms_sub, synth_data = syn) + # are variable names missing ever? expect_false( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE )$variable %>% @@ -314,8 +284,7 @@ test_that("util_proportions() variables selection returns correct dimensions ", # are statistics names missing ever? expect_false( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE )$class %>% @@ -323,25 +292,23 @@ test_that("util_proportions() variables selection returns correct dimensions ", all() ) - # 55 rows = all 11 variables times 5 statistics + # 221 rows = 221 levels in name variable expect_equal( dim( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE ) ), - c(215, 5) + c(221, 5) ) - # 50 rows = 10 common variables times 5 statistics + # 9 rows = 9 levels in class variable expect_equal( dim( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = FALSE ) @@ -353,8 +320,7 @@ test_that("util_proportions() variables selection returns correct dimensions ", expect_equal( dim( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = TRUE ) @@ -366,8 +332,7 @@ test_that("util_proportions() variables selection returns correct dimensions ", expect_equal( dim( util_proportions( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = TRUE ) @@ -378,20 +343,17 @@ test_that("util_proportions() variables selection returns correct dimensions ", }) test_that("na.rm in levels works as expected", { - res <- util_proportions( - postsynth = syn_na, - data = df_na - ) + + ed_na <- eval_data(conf_data = df_na, synth_data = syn_na) + + res <- util_proportions(ed_na) + expect_identical( res$class, c("NA", "green", "orange", "yellow", "1", "2", NA) ) - res_rm <- util_proportions( - postsynth = syn_na, - data = df_na, - na.rm = TRUE - ) + res_rm <- util_proportions(ed_na, na.rm = TRUE) expect_identical( res_rm$class, @@ -402,9 +364,10 @@ test_that("na.rm in levels works as expected", { test_that("keep_empty_levels works as expected", { + ed_na <- eval_data(conf_data = df_na, synth_data = syn_na) + res <- util_proportions( - postsynth = syn_na, - data = df_na, + ed_na, keep_empty_levels = TRUE ) diff --git a/tests/testthat/test-util_totals.R b/tests/testthat/test-util_totals.R index d88d5ac..847f29e 100644 --- a/tests/testthat/test-util_totals.R +++ b/tests/testthat/test-util_totals.R @@ -48,14 +48,13 @@ syn_na <- list( ) %>% structure(class = "postsynth") +ed0 <- eval_data(conf_data = df, synth_data = df) +ed1 <- eval_data(conf_data = df, synth_data = syn) + # full unweighted - postysynth test_that("moments full unweighted -- postsynth ", { - summary_stats <- - util_totals( - postsynth = syn, - data = df - ) %>% + summary_stats <- util_totals(ed1) %>% dplyr::filter(variable == "a") expect_equal( @@ -70,11 +69,7 @@ test_that("moments full unweighted -- postsynth ", { test_that("moments full unweighted -- df ", { - summary_stats <- - util_totals( - postsynth = df, - data = df - ) %>% + summary_stats <- util_totals(ed0) %>% dplyr::filter(variable == "a") expect_equal( @@ -90,12 +85,7 @@ test_that("moments full unweighted -- df ", { # full weighted test_that("moments full weighted -- postsynth", { - summary_stats <- - util_totals( - postsynth = syn, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_totals(ed1, weight_var = weight) %>% dplyr::filter(variable == "a") expect_equal( @@ -110,12 +100,7 @@ test_that("moments full weighted -- postsynth", { test_that("moments full weighted -- df", { - summary_stats <- - util_totals( - postsynth = df, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_totals(ed0, weight_var = weight) %>% dplyr::filter(variable == "a") expect_equal( @@ -130,11 +115,7 @@ test_that("moments full weighted -- df", { test_that("moments nonzero unweighted -- postsynth", { - summary_stats <- - util_totals( - postsynth = syn, - data = df - ) %>% + summary_stats <- util_totals(ed1) %>% dplyr::filter(variable == "d") expect_equal( @@ -149,11 +130,7 @@ test_that("moments nonzero unweighted -- postsynth", { test_that("moments nonzero unweighted -- postsynth", { - summary_stats <- - util_totals( - postsynth = df, - data = df - ) %>% + summary_stats <- util_totals(ed0) %>% dplyr::filter(variable == "d") expect_equal( @@ -168,12 +145,7 @@ test_that("moments nonzero unweighted -- postsynth", { test_that("moments nonzero weighted -- postsynth", { - summary_stats <- - util_totals( - postsynth = syn, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_totals(ed1, weight_var = weight) %>% dplyr::filter(variable == "d") expect_equal( @@ -188,12 +160,7 @@ test_that("moments nonzero weighted -- postsynth", { test_that("moments nonzero weighted -- df", { - summary_stats <- - util_totals( - postsynth = df, - data = df, - weight_var = weight - ) %>% + summary_stats <- util_totals(ed0, weight_var = weight) %>% dplyr::filter(variable == "d") expect_equal( @@ -208,10 +175,8 @@ test_that("moments nonzero weighted -- df", { test_that("moments test grouping var ", { - summary_stats <- - util_totals( - postsynth = syn, - data = df, + summary_stats <- util_totals( + ed1, weight_var = weight, group_by = c ) %>% @@ -232,8 +197,7 @@ test_that("moments test grouping var ", { test_that("moments grouping by multiple variables", { summary_stats <- util_totals( - postsynth = syn, - data = df, + ed1, weight_var = weight, group_by = c(c, e) ) %>% @@ -269,11 +233,11 @@ test_that("util_totals() variables selection returns correct dimensions ", { ) %>% structure(class = "postsynth") + ed <- eval_data(conf_data = storms_sub, synth_data = syn) # are variable names missing ever? expect_false( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE )$variable %>% @@ -284,8 +248,7 @@ test_that("util_totals() variables selection returns correct dimensions ", { # are statistics names missing ever? expect_false( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE )$statistic %>% @@ -297,8 +260,7 @@ test_that("util_totals() variables selection returns correct dimensions ", { expect_equal( dim( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = FALSE ) @@ -310,8 +272,7 @@ test_that("util_totals() variables selection returns correct dimensions ", { expect_equal( dim( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = FALSE ) @@ -323,8 +284,7 @@ test_that("util_totals() variables selection returns correct dimensions ", { expect_equal( dim( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = FALSE, synth_vars = TRUE ) @@ -336,8 +296,7 @@ test_that("util_totals() variables selection returns correct dimensions ", { expect_equal( dim( util_totals( - postsynth = syn, - data = storms_sub, + ed, common_vars = TRUE, synth_vars = TRUE ) @@ -349,9 +308,10 @@ test_that("util_totals() variables selection returns correct dimensions ", { test_that("util_totals() na.rm works as expected", { + ed_na <- eval_data(conf_data = df_na, synth_data = syn_na) + res <- util_totals( - postsynth = syn_na, - data = df_na, + ed_na, na.rm = FALSE ) @@ -360,8 +320,7 @@ test_that("util_totals() na.rm works as expected", { ) res_rm <- util_totals( - postsynth = syn_na, - data = df_na, + ed_na, na.rm = TRUE )