diff --git a/DESCRIPTION b/DESCRIPTION index 5f65a77d..011b57c5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -41,7 +41,9 @@ Suggests: knitr (>= 1.42), rmarkdown (>= 2.23), testthat (>= 3.0.4), - withr (>= 2.0.0) + withr (>= 2.0.0), + ggplot2, + Hmisc VignetteBuilder: knitr, rmarkdown diff --git a/NAMESPACE b/NAMESPACE index 518c5375..12ceda99 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -1,6 +1,11 @@ # Generated by roxygen2: do not edit by hand export(apply_metadata) +export(check_long_strings) +export(check_special_chars) +export(describe_cols) +export(detect_issues) +export(is_empty_string) export(mutate_na) export(radab) export(radae) @@ -23,6 +28,7 @@ export(radsub) export(radtr) export(radtte) export(radvs) +export(reduce_num_levels_in_df) export(rel_var) export(replace_na) export(rtexp) diff --git a/NEWS.md b/NEWS.md index 614eaa14..07038eab 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,7 @@ # random.cdisc.data 0.3.16.9003 - +* Added `reduce_num_levels_in_df` for dimensionality control in realistic data to maximize information content while limiting the number of levels in categorical variables. +* Added vignette about data handling called `data_pre_processing.Rmd`. +* # random.cdisc.data 0.3.16 ### Miscellaneous diff --git a/R/utils.R b/R/utils.R index 53ad1ac4..e15ee983 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,126 +1,29 @@ -#' Load Cached Data -#' -#' Return data attached to package. -#' -#' @keywords internal -#' @noRd -get_cached_data <- function(dataname) { - checkmate::assert_string(dataname) - if (!("package:random.cdisc.data" %in% search())) { - stop("cached data can only be loaded if the random.cdisc.data package is attached.", - "Please run library(random.cdisc.data) before loading cached data.", - call. = FALSE - ) - } else { - get(dataname, envir = asNamespace("random.cdisc.data")) - } -} - +# Exported utils ------------------------------------------------------------------------- #' Create a Factor with Random Elements of x #' #' Sample elements from `x` with replacement to build a factor. #' -#' @param x (`character vector` or `factor`)\cr If character vector then it is also used +#' @param x (`character` or `factor`)\cr If character vector then it is also used #' as levels of the returned factor. If factor then the levels are used as the new levels. -#' @param N (`numeric`)\cr Number of items to choose. +#' @param N (`numeric(1)`)\cr Number of items to choose. +#' @param random_seed (`numeric(1)` or `NULL`)\cr Seed for random number generation. #' @param ... Additional arguments to be passed to `sample`. #' #' @return A factor of length `N`. -#' @export #' #' @examples #' sample_fct(letters[1:3], 10) #' sample_fct(iris$Species, 10) -sample_fct <- function(x, N, ...) { # nolint - checkmate::assert_number(N) - - factor(sample(x, N, replace = TRUE, ...), levels = if (is.factor(x)) levels(x) else x) -} - -#' Related Variables: Initialize -#' -#' Verify and initialize related variable values. -#' For example, `relvar_init("Alanine Aminotransferase Measurement", "ALT")`. -#' -#' @param relvar1 (`list` of `character`)\cr List of n elements. -#' @param relvar2 (`list` of `character`)\cr List of n elements. -#' -#' @return A vector of n elements. -#' -#' @keywords internal -relvar_init <- function(relvar1, relvar2) { - checkmate::assert_character(relvar1, min.len = 1, any.missing = FALSE) - checkmate::assert_character(relvar2, min.len = 1, any.missing = FALSE) - - if (length(relvar1) != length(relvar2)) { - message(simpleError( - "The argument value length of relvar1 and relvar2 differ. They must contain the same number of elements." - )) - return(NA) - } - return(list("relvar1" = relvar1, "relvar2" = relvar2)) -} - -#' Related Variables: Assign #' -#' Assign values to a related variable within a domain. -#' -#' @param df (`data.frame`)\cr Data frame containing the related variables. -#' @param var_name (`character`)\cr Name of variable related to `rel_var` to add to `df`. -#' @param var_values (`any`)\cr Vector of values related to values of `related_var`. -#' @param related_var (`character`)\cr Name of variable within `df` with values to which values -#' of `var_name` must relate. -#' -#' @return `df` with added factor variable `var_name` containing `var_values` corresponding to `related_var`. #' @export -#' -#' @examples -#' # Example with data.frame. -#' params <- c("Level A", "Level B", "Level C") -#' adlb_df <- data.frame( -#' ID = 1:9, -#' PARAM = factor( -#' rep(c("Level A", "Level B", "Level C"), 3), -#' levels = params -#' ) -#' ) -#' rel_var( -#' df = adlb_df, -#' var_name = "PARAMCD", -#' var_values = c("A", "B", "C"), -#' related_var = "PARAM" -#' ) -#' -#' # Example with tibble. -#' adlb_tbl <- tibble::tibble( -#' ID = 1:9, -#' PARAM = factor( -#' rep(c("Level A", "Level B", "Level C"), 3), -#' levels = params -#' ) -#' ) -#' rel_var( -#' df = adlb_tbl, -#' var_name = "PARAMCD", -#' var_values = c("A", "B", "C"), -#' related_var = "PARAM" -#' ) -rel_var <- function(df, var_name, related_var, var_values = NULL) { - checkmate::assert_data_frame(df) - checkmate::assert_string(var_name) - checkmate::assert_string(related_var) - n_relvar1 <- length(unique(df[, related_var, drop = TRUE])) - checkmate::assert_vector(var_values, null.ok = TRUE, len = n_relvar1, any.missing = FALSE) - if (is.null(var_values)) var_values <- rep(NA, n_relvar1) +sample_fct <- function(x, N, random_seed = NULL, ...) { # nolint + checkmate::assert_number(N) - relvar1 <- unique(df[, related_var, drop = TRUE]) - relvar2_values <- rep(NA, nrow(df)) - for (r in seq_len(n_relvar1)) { - matched <- which(df[, related_var, drop = TRUE] == relvar1[r]) - relvar2_values[matched] <- var_values[r] + if (!is.null(random_seed)) { + set.seed(random_seed) } - df[[var_name]] <- factor(relvar2_values) - return(df) + + factor(sample(x, N, replace = TRUE, ...), levels = if (is.factor(x)) levels(x) else x) } #' Create Visit Schedule @@ -132,11 +35,12 @@ rel_var <- function(df, var_name, related_var, var_values = NULL) { #' @inheritParams argument_convention #' #' @return A factor of length `n_assessments`. -#' @export #' #' @examples #' visit_schedule(visit_format = "WEeK", n_assessments = 10L) #' visit_schedule(visit_format = "CyCLE", n_assessments = 5L, n_days = 2L) +#' +#' @export visit_schedule <- function(visit_format = "WEEK", n_assessments = 10L, n_days = 5L) { @@ -162,55 +66,6 @@ visit_schedule <- function(visit_format = "WEEK", visit_values <- stats::reorder(factor(visit_values), assessments_ord) } -#' Primary Keys: Retain Values -#' -#' Retain values within primary keys. -#' -#' @param df (`data.frame`)\cr Data frame in which to apply the retain. -#' @param value_var (`any`)\cr Variable in `df` containing the value to be retained. -#' @param event (`expression`)\cr Expression returning a logical value to trigger the retain. -#' @param outside (`any`)\cr Additional value to retain. Defaults to `NA`. -#' @return A vector of values where expression is true. -#' @keywords internal -retain <- function(df, value_var, event, outside = NA) { - indices <- c(1, which(event == TRUE), nrow(df) + 1) - values <- c(outside, value_var[event == TRUE]) - rep(values, diff(indices)) -} - -#' Primary Keys: Labels -#' -#' @description Shallow copy of `formatters::var_relabel()`. Used mainly internally to -#' relabel a subset of variables in a data set. -#' -#' @param x (`data.frame`)\cr Data frame containing variables to which labels are applied. -#' @param ... (`named character`)\cr Name-Value pairs, where name corresponds to a variable -#' name in `x` and the value to the new variable label. -#' @return x (`data.frame`)\cr Data frame with labels applied. -#' -#' @keywords internal -rcd_var_relabel <- function(x, ...) { - stopifnot(is.data.frame(x)) - if (missing(...)) { - return(x) - } - dots <- list(...) - varnames <- names(dots) - if (is.null(varnames)) { - stop("missing variable declarations") - } - map_varnames <- match(varnames, colnames(x)) - if (any(is.na(map_varnames))) { - stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found") - } - if (any(vapply(dots, Negate(is.character), logical(1)))) { - stop("all variable labels must be of type character") - } - for (i in seq_along(map_varnames)) { - attr(x[[map_varnames[[i]]]], "label") <- dots[[i]] - } - x -} #' Apply Metadata #' @@ -222,7 +77,6 @@ rcd_var_relabel <- function(x, ...) { #' @param adsl_filename (`yaml`)\cr File containing ADSL metadata. #' @return Data frame with metadata applied. #' -#' @export #' @examples #' seed <- 1 #' adsl <- radsl(seed = seed) @@ -233,6 +87,8 @@ rcd_var_relabel <- function(x, ...) { #' adsub, file.path(yaml_path, "ADSUB.yml"), TRUE, #' file.path(yaml_path, "ADSL.yml") #' ) +#' +#' @export apply_metadata <- function(df, filename, add_adsl = TRUE, adsl_filename = "metadata/ADSL.yml") { checkmate::assert_data_frame(df) checkmate::assert_string(filename) @@ -397,6 +253,7 @@ ungroup_rowwise_df <- function(x) { return(x) } + #' Zero-Truncated Poisson Distribution #' #' @description `r lifecycle::badge("stable")` @@ -411,7 +268,6 @@ ungroup_rowwise_df <- function(x) { #' @param lambda (`numeric`)\cr Non-negative mean(s). #' #' @return The random numbers. -#' @export #' #' @examples #' x <- rpois(1e6, lambda = 5) @@ -420,6 +276,8 @@ ungroup_rowwise_df <- function(x) { #' #' y <- rtpois(1e6, lambda = 5) #' hist(y) +#' +#' @export rtpois <- function(n, lambda) { stats::qpois(stats::runif(n, stats::dpois(0, lambda), 1), lambda) } @@ -441,7 +299,6 @@ rtpois <- function(n, lambda) { #' #' @return The random numbers. If neither `l` nor `r` are provided then the usual Exponential #' distribution is used. -#' @export #' #' @examples #' x <- stats::rexp(1e6, rate = 5) @@ -453,6 +310,8 @@ rtpois <- function(n, lambda) { #' #' z <- rtexp(1e6, rate = 5, r = 0.5) #' hist(z) +#' +#' @export rtexp <- function(n, rate, l = NULL, r = NULL) { if (!is.null(l)) { l - log(1 - stats::runif(n)) / rate @@ -462,3 +321,163 @@ rtexp <- function(n, rate, l = NULL, r = NULL) { stats::rexp(n, rate) } } + +# Internal utils --------------------------------------------------------------------------------- +#' Load Cached Data +#' +#' Return data attached to package. +#' +#' @keywords internal +#' @noRd +get_cached_data <- function(dataname) { + checkmate::assert_string(dataname) + if (!("package:random.cdisc.data" %in% search())) { + stop("cached data can only be loaded if the random.cdisc.data package is attached.", + "Please run library(random.cdisc.data) before loading cached data.", + call. = FALSE + ) + } else { + get(dataname, envir = asNamespace("random.cdisc.data")) + } +} + + +# Related Variables --------------------------------------------------------------------------------- +#' Related Variables: Initialize +#' +#' Verify and initialize related variable values. +#' For example, `relvar_init("Alanine Aminotransferase Measurement", "ALT")`. +#' +#' @param relvar1 (`list` of `character`)\cr List of n elements. +#' @param relvar2 (`list` of `character`)\cr List of n elements. +#' +#' @return A vector of n elements. +#' +#' @keywords internal +relvar_init <- function(relvar1, relvar2) { + checkmate::assert_character(relvar1, min.len = 1, any.missing = FALSE) + checkmate::assert_character(relvar2, min.len = 1, any.missing = FALSE) + + if (length(relvar1) != length(relvar2)) { + message(simpleError( + "The argument value length of relvar1 and relvar2 differ. They must contain the same number of elements." + )) + return(NA) + } + return(list("relvar1" = relvar1, "relvar2" = relvar2)) +} + +#' Related Variables: Assign +#' +#' Assign values to a related variable within a domain. +#' +#' @param df (`data.frame`)\cr Data frame containing the related variables. +#' @param var_name (`character`)\cr Name of variable related to `rel_var` to add to `df`. +#' @param var_values (`any`)\cr Vector of values related to values of `related_var`. +#' @param related_var (`character`)\cr Name of variable within `df` with values to which values +#' of `var_name` must relate. +#' +#' @return `df` with added factor variable `var_name` containing `var_values` corresponding to `related_var`. +#' +#' @examples +#' # Example with data.frame. +#' params <- c("Level A", "Level B", "Level C") +#' adlb_df <- data.frame( +#' ID = 1:9, +#' PARAM = factor( +#' rep(c("Level A", "Level B", "Level C"), 3), +#' levels = params +#' ) +#' ) +#' rel_var( +#' df = adlb_df, +#' var_name = "PARAMCD", +#' var_values = c("A", "B", "C"), +#' related_var = "PARAM" +#' ) +#' +#' # Example with tibble. +#' adlb_tbl <- tibble::tibble( +#' ID = 1:9, +#' PARAM = factor( +#' rep(c("Level A", "Level B", "Level C"), 3), +#' levels = params +#' ) +#' ) +#' rel_var( +#' df = adlb_tbl, +#' var_name = "PARAMCD", +#' var_values = c("A", "B", "C"), +#' related_var = "PARAM" +#' ) +#' +#' @export +rel_var <- function(df, var_name, related_var, var_values = NULL) { + checkmate::assert_data_frame(df) + checkmate::assert_string(var_name) + checkmate::assert_string(related_var) + n_relvar1 <- length(unique(df[, related_var, drop = TRUE])) + checkmate::assert_vector(var_values, null.ok = TRUE, len = n_relvar1, any.missing = FALSE) + if (is.null(var_values)) var_values <- rep(NA, n_relvar1) + + relvar1 <- unique(df[, related_var, drop = TRUE]) + relvar2_values <- rep(NA, nrow(df)) + for (r in seq_len(n_relvar1)) { + matched <- which(df[, related_var, drop = TRUE] == relvar1[r]) + relvar2_values[matched] <- var_values[r] + } + df[[var_name]] <- factor(relvar2_values) + return(df) +} +# Primary Keys -------------------------------------------------------------------- +#' Primary Keys: Retain Values +#' +#' Retain values within primary keys. +#' +#' @param df (`data.frame`)\cr Data frame in which to apply the retain. +#' @param value_var (`any`)\cr Variable in `df` containing the value to be retained. +#' @param event (`expression`)\cr Expression returning a logical value to trigger the retain. +#' @param outside (`any`)\cr Additional value to retain. Defaults to `NA`. +#' +#' @return A vector of values where expression is true. +#' +#' @keywords internal +retain <- function(df, value_var, event, outside = NA) { + indices <- c(1, which(event == TRUE), nrow(df) + 1) + values <- c(outside, value_var[event == TRUE]) + rep(values, diff(indices)) +} + +#' Primary Keys: Labels +#' +#' @description Shallow copy of `formatters::var_relabel()`. Used mainly internally to +#' relabel a subset of variables in a data set. +#' +#' @param x (`data.frame`)\cr Data frame containing variables to which labels are applied. +#' @param ... (`named character`)\cr Name-Value pairs, where name corresponds to a variable +#' name in `x` and the value to the new variable label. +#' @return x (`data.frame`)\cr Data frame with labels applied. +#' +#' @keywords internal +rcd_var_relabel <- function(x, ...) { + stopifnot(is.data.frame(x)) + if (missing(...)) { + return(x) + } + dots <- list(...) + varnames <- names(dots) + if (is.null(varnames)) { + stop("missing variable declarations") + } + map_varnames <- match(varnames, colnames(x)) + if (any(is.na(map_varnames))) { + stop("variables: ", paste(varnames[is.na(map_varnames)], collapse = ", "), " not found") + } + if (any(vapply(dots, Negate(is.character), logical(1)))) { + stop("all variable labels must be of type character") + } + for (i in seq_along(map_varnames)) { + attr(x[[map_varnames[[i]]]], "label") <- dots[[i]] + } + x +} diff --git a/R/utils_dim_control_and_checks.R b/R/utils_dim_control_and_checks.R new file mode 100644 index 00000000..2bc2973c --- /dev/null +++ b/R/utils_dim_control_and_checks.R @@ -0,0 +1,469 @@ +# Dimension control and df checks ---------------------------------------------- + +#' Reduce number of levels in a column of a `data.frame` +#' +#' @description `r lifecycle::badge("experimental")` +#' +#' Use this function to reduce the number of levels in a `data.frame` column called `variable`. +#' This function calculates the frequency distribution of levels and sets either a soft threshold +#' based on the probability cut-off (`p_to_keep`) and/or an hard threshold (`num_max_values`). +#' Consider checking the number of unique values in each pivotal data column with [describe_cols()]. +#' +#' @param df (`data.frame`)\cr data.frame with too many levels for a `variable`. +#' @param variable (`character(1)`)\cr string with the name of the column to be reduced. +#' @param p_to_keep (`numeric(1)`)\cr probability cut-off to keep the most frequent levels. If `num_max_values` is +#' specified (i.e. not `NULL`) this is not used. +#' @param num_max_values (`integer(1)`)\cr maximum number of levels to keep. This encompasses only +#' rare values (`num_of_rare_values`) but not additional desired values (`add_specific_value`) +#' and rows (`keep_spec_rows`). +#' @param num_of_rare_values (`integer(1)`)\cr number of additional rare values to keep. These are selected +#' from the least frequent levels. +#' @param add_specific_value (`character`)\cr specific values to keep. +#' @param keep_spec_rows (`integer`)\cr specific rows to keep. +#' @param explorative (`logical(1)`)\cr if `TRUE`, a plot with the frequency distribution of levels is shown. +#' @param verbose (`logical(1)`)\cr if `TRUE`, messages are printed. +#' +#' @details +#' If necessary, a number of additional rare values can be picked from the least represented levels +#' (`num_of_rare_values`). For general use it is also possible to keep certain values +#' (`add_specific_value`) and rows (`keep_spec_rows`). Exploratory plots can be also appreciated with +#' `explorative = TRUE`. +#' +#' @return A modified `data.frame` or a plot if `explorative = TRUE`. +#' +#' @examples +#' # real case scenario: trimming of variables with too many levels +#' random.cdisc.data::cadae %>% +#' reduce_num_levels_in_df(adae_pharmaverse, "AEDECOD", +#' num_max_values = 7, num_of_rare_values = 1, +#' add_specific_value = c( +#' "VOMITING", "NAUSEA", "SKIN IRRITATION", "HEADACHE", # For SMQ01NAM, SMQ02NAM, CQ01NAM +#' "MYOCARDIAL INFARCTION" # for aet07 AESDTH == "Y" +#' ) +#' ) +#' +#' @export +reduce_num_levels_in_df <- function(df, + variable, + p_to_keep = 0.7, + num_max_values = NULL, + num_of_rare_values = 0, + add_specific_value = NULL, + keep_spec_rows = NULL, + explorative = FALSE, + verbose = TRUE) { + checkmate::assert_number(p_to_keep, lower = 0, upper = 1) + checkmate::assert_data_frame(df) + checkmate::assert_string(variable) + checkmate::assert_character(add_specific_value, null.ok = TRUE) + checkmate::assert_choice(variable, names(df)) + checkmate::assert_integerish(keep_spec_rows, + null.ok = TRUE, + lower = 1, upper = nrow(df), unique = TRUE + ) + checkmate::assert_flag(explorative) + checkmate::assert_flag(verbose) + cur_vec <- df[[variable]] + + if (is.factor(cur_vec)) { + cur_vec <- as.character(cur_vec) + } + + lev_freq <- sort(table(cur_vec), decreasing = TRUE) + + # Explorative plot + if (explorative) { + require(ggplot2) + plot_tbl <- tibble( + level = names(lev_freq), + freq = lev_freq + ) %>% + arrange(desc(freq)) %>% + mutate(level = factor(level, levels = level)) + + how_many_to_plot <- min(10, nrow(plot_tbl)) + spacing <- round(nrow(plot_tbl) / how_many_to_plot) + gg <- ggplot(plot_tbl) + + geom_col(aes(x = level, y = freq), width = 1) + + theme_classic() + + labs(title = paste0("Frequency of levels in ", variable), x = "Level", y = "Frequency") + + scale_x_discrete( + breaks = plot_tbl$level[seq(1, nrow(plot_tbl), by = spacing)], + labels = seq(1, nrow(plot_tbl))[seq(1, nrow(plot_tbl), by = spacing)] + ) + + # Adding % annotation + annot_x <- tail(plot_tbl$level[cumsum(plot_tbl$freq) <= sum(plot_tbl$freq) * p_to_keep], 1) + annot_y <- 0.9 * max(plot_tbl$freq) + annot_label <- paste0( + "Desired: ", round(p_to_keep * 100, 1), "%", + "\n", "Levels to keep: ", sum(cumsum(plot_tbl$freq) <= sum(plot_tbl$freq) * p_to_keep) + ) + gg <- gg + geom_vline(aes(xintercept = tail(level[cumsum(freq) <= sum(freq) * p_to_keep], 1)), color = "red") + + annotate("text", x = annot_x, y = annot_y, label = annot_label, vjust = 0, hjust = 0) + + if (!is.null(num_max_values)) { + annot_x <- num_max_values - num_of_rare_values + annot_y <- 0.5 * max(plot_tbl$freq) + annot_label <- paste0( + "Desired: ", num_max_values - num_of_rare_values, + "\n Kept: ", + round(sum(plot_tbl$freq[seq(1, num_max_values - num_of_rare_values)]) * 100 / sum(plot_tbl$freq), 1), + "%" + ) + gg <- gg + geom_vline(aes(xintercept = num_max_values - num_of_rare_values), color = "blue") + + annotate("text", x = annot_x, y = annot_y, label = annot_label, vjust = 0, hjust = 0) + } + + if (!is.null(add_specific_value)) { + xint <- which(plot_tbl$level %in% add_specific_value) + annot_x <- tail(which(plot_tbl$level %in% add_specific_value), 1) + annot_y <- 0.1 * max(plot_tbl$freq) + if (length(add_specific_value) == 1L) { + annot_label <- paste0( + "Specific value: ", add_specific_value, + "\nAdded freq: ", + round(plot_tbl$freq[which(plot_tbl$level == add_specific_value)] * 100 / sum(plot_tbl$freq), 1), + "%\n", + "Rank: ", which(plot_tbl$level == add_specific_value) + ) + } else { + xint <- max(xint) + annot_label <- paste0( + "Num spec values: ", length(add_specific_value), + "\nAdded freq: ", + round(sum(plot_tbl$freq[which(plot_tbl$level %in% add_specific_value)]) * 100 / sum(plot_tbl$freq), 1), + "%\n", + "Max rank: ", max(which(plot_tbl$level %in% add_specific_value)) + ) + } + gg <- gg + + geom_vline(aes(xintercept = xint), color = "black") + + annotate("text", x = annot_x, y = annot_y, label = annot_label, vjust = 0, hjust = 0) + } + + return(gg) + + # Effective calculations + } + checkmate::assert_int(num_of_rare_values, lower = 0, upper = length(lev_freq)) + checkmate::assert_int(num_max_values, lower = num_of_rare_values, upper = length(lev_freq), null.ok = TRUE) + + if (!is.null(num_max_values)) { + lev_to_keep <- names(lev_freq)[seq(1, num_max_values - num_of_rare_values)] + + if (num_of_rare_values > 0) { + lev_to_keep <- c( + lev_to_keep, + names(lev_freq)[seq(length(lev_freq) - num_of_rare_values + 1, length(lev_freq))] + ) + } + } else { + cum_freq <- cumsum(lev_freq) / sum(lev_freq) + if (p_to_keep < min(cum_freq)) { + stop(paste0("p_to_keep is too low. The minimum value of p_to_keep is ", round(min(cum_freq), 3))) + } + lev_to_keep <- names(lev_freq)[cum_freq <= p_to_keep] + } + + if (!is.null(add_specific_value)) { + checkmate::assert_subset(add_specific_value, names(lev_freq)) + lev_to_keep <- unique(c(lev_to_keep, add_specific_value)) + } + out <- df %>% filter(!!sym(variable) %in% lev_to_keep) + + if (!is.null(keep_spec_rows)) { + lev_new_rows <- cur_vec[keep_spec_rows] + what_is_new_row <- which(!lev_new_rows %in% lev_to_keep) + lev_new_rows <- lev_new_rows[what_is_new_row] + keep_spec_rows <- keep_spec_rows[what_is_new_row] + + if (length(keep_spec_rows) > 0) { + out <- rbind(out, df %>% slice(keep_spec_rows)) + } + } + + if (verbose) { + if (length(keep_spec_rows) > 0) { + core_msg <- paste0( + length(lev_to_keep), " + ", length(keep_spec_rows), " (from keep_spec_rows) levels out of ", + length(lev_freq), " levels. Total rows kept (%): ", + round((sum(lev_freq[lev_to_keep]) + length(keep_spec_rows)) * 100 / sum(lev_freq), 1) + ) + } else { + core_msg <- paste0( + length(lev_to_keep), " levels out of ", length(lev_freq), " levels. Total rows kept (%): ", + round(sum(lev_freq[lev_to_keep]) * 100 / sum(lev_freq), 1) + ) + } + msg <- paste0( + "Reducing levels of ", deparse(substitute(df)), " for variable ", + variable, ": keeping ", core_msg + ) + message(msg) + } + + # Simple check of filtering + stopifnot(nrow(out) == sum(cur_vec %in% lev_to_keep) + length(keep_spec_rows)) + + # We want a factor anyway (drop unused levels) + out <- out %>% + mutate(!!sym(variable) := factor(!!sym(variable))) + + invisible(out) +} + + +# Descriptive tools ------------------------------------------------------------ +#' Describe columns of a data frame +#' +#' @description +#' This function uses some simple descriptor to describe the columns of a data frame. It is an indicative +#' function and it is not intended to be used for a full description or analysis of the data. +#' +#' @param df (`data.frame`)\cr Data like `random.cdisc.data::cadae`. +#' @param additional_checks (named `list` of functions)\cr List of functions that take in input a column +#' and return a vector of logicals. List names are used as column names for the returning `tibble`. Needs +#' to have at least a `"column"` parameter. See [check_long_strings()] for an example. +#' @param max_desc_length (`integer(1)`)\cr Maximum length of the description of any column name. You can retrieve this +#' attribute using [formatters::var_labels()] on the data. `NA` is returned when absent. +#' @param column (`character`)\cr Column to describe. If using a custom function, please consider how to handle +#' all types and missing values (`NA`). +#' @param max_length (`integer(1)`)\cr Maximum length of a string. +#' @param special_chr (`character(1)`)\cr Regular expression to detect special characters. +#' +#' @return A `tibble` with the following columns: +#' \itemize{ +#' \item `col.name`: column name. We do not expect this code name to be longer than 5 - 10 characters. +#' \item `desc`: description of the column (output of [formatters::var_labels()]). +#' \item `long_desc`: `TRUE` if `desc` is longer than 80 characters. Use `max_desc_length` to change this variable. +#' \item `nrows`: number of elements or rows (useful when having multiple data to compare). +#' \item `type`: type of the column. +#' \item `is_numeric`: logical indicating if the column is numeric. +#' \item `n_na`: number of missing values. +#' \item `n_empty`: number of empty strings. +#' \item `n_unique`: number of unique values (everything is casted as factor). +#' \item `n_levels`: number of levels (if factor) or number of unique values (if character). +#' \item `n_empty_levels`: number of empty levels if > 0. If it is -1 the column is a factor that +#' contains some missing values (`NA`). +#' \item `additional_checks` list names: output of additional checks functions. +#' \item `mean`: mean of the column (if numeric). +#' \item `sd`: standard deviation of the column (if numeric). +#' \item `quartiles`: quartiles of the column (if numeric). +#' } +#' +#' @seealso [reduce_num_levels_in_df()] for how to reduce pivotal values when `n_unique` is too high. +#' +#' @examples +#' # Describe columns of a data frame +#' describe_cols(random.cdisc.data::cadae) +#' +#' adae <- random.cdisc.data::cadae +#' adae$STUDYID[1] <- "missing" # We search for this string +#' adae$USUBJID[2] <- paste0(rep("a", 40), collapse = "_") # Too long for us!! +#' +#' # Let's add one custom check function (additional_checks param) +#' check_spec_missing_str <- function(column, missing_str) { +#' # We want characters +#' column <- as.character(column) +#' # We do not want NAs (already taken into account before) +#' if (anyNA(column)) { +#' column[is.na(column)] <- "NA" +#' } +#' # Checking if it is "missing" +#' if (is.character(column)) { +#' return(column == missing_str) +#' } else { +#' return(0) # not applicable (e.g. is numeric) +#' } +#' } +#' +#' # Our description function +#' out <- describe_cols( +#' adae, +#' additional_checks = list( +#' "very_long" = check_long_strings, +#' "n_missing" = check_spec_missing_str +#' ), +#' extra_args = list( # extra arguments for our additional_checks functions +#' "max_length" = 70, +#' "missing_str" = "missing" +#' ) +#' ) +#' out[out$n_missing > 0, ] # STUDYID has 1 "missing" value +#' out[out$very_long > 0, ] # USUBJID has 1 long string +#' +#' @export +describe_cols <- function(df, + additional_checks = list( + "too_long" = check_long_strings, + "special_chars" = check_special_chars + ), + extra_args = list(max_length = 80, special_chr = "outlier"), + max_desc_length = 80) { + checkmate::assert_data_frame(df) + checkmate::assert_list(additional_checks, any.missing = FALSE) + checkmate::assert_list(extra_args, unique = TRUE) + checkmate::assert_int(max_desc_length, lower = 1, upper = 500) + + if (is.null(names(additional_checks))) { + names(additional_checks) <- paste0("check_", seq_along(additional_checks)) + } + + # Values of columns + var_lb <- formatters::var_labels(df) + lb_tb <- tibble::tibble( + col.name = names(var_lb), + desc = as.character(var_lb), + long_desc = nchar(desc) > max_desc_length + ) + + # main descriptor + lb_tb2 <- dplyr::bind_cols(lb_tb, + "nrows" = nrow(df), + "type" = df %>% dplyr::summarise_all(~ class(.)[1]) %>% t() %>% c(), + "is_numeric" = df %>% dplyr::summarise_all(~ is.numeric(.)) %>% t() %>% c(), + "n_na" = df %>% dplyr::summarise_all(~ sum(is.na(.))) %>% t() %>% c(), + "n_empty" = df %>% dplyr::summarise_all(~ sum(is_empty_string(.))) %>% t() %>% c(), + "n_unique" = df %>% dplyr::summarise_all(~ length(unique(as.character(.)))) %>% t() %>% c(), + "n_levels" = df %>% dplyr::summarise_all(~ { + ifelse(is.factor(.), length(levels(.)), length(unique(.))) + }) %>% t() %>% c() + ) %>% dplyr::mutate( + "n_empty_levels" = n_levels - n_unique # 0 if character, -1 if NAs are present + ) + + # Adding custom checks + for (custom_function_i in seq_along(additional_checks)) { + col_fun_name <- names(additional_checks)[custom_function_i] + lb_tb2 <- dplyr::bind_cols( + lb_tb2, + "very_tmp_name" = df %>% dplyr::summarise_all(~ { + col <- . + cur_fun <- additional_checks[[custom_function_i]] + + cur_extra_args <- as.list(args(cur_fun)) + drop_empty_params <- names(cur_extra_args) == "" + cur_extra_args <- cur_extra_args[!drop_empty_params] + if (names(cur_extra_args)[1] != "column") { + stop("The first element of additional_checks must have a column parameter.") + } + cur_extra_args$column <- col + param_overload <- names(cur_extra_args) %in% names(extra_args) + + if (any(param_overload)) { + cur_extra_args[param_overload] <- extra_args[names(cur_extra_args)[param_overload]] + } + + sum(do.call(cur_fun, args = cur_extra_args)) + }) |> t() |> c() + ) + lb_tb2 <- dplyr::rename(lb_tb2, !!col_fun_name := very_tmp_name) + } + + if (any(lb_tb2$is_numeric)) { + lb_tb2 <- dplyr::mutate(lb_tb2, + "mean" = NA_real_, + "sd" = NA_real_, + "quantile" = NA_real_ + ) + # for numeric + lb_tb2$mean[lb_tb2$is_numeric] <- apply(df[, lb_tb2$is_numeric], 2, function(i) { + mean(i, na.rm = TRUE) + }) + lb_tb2$sd[lb_tb2$is_numeric] <- apply(df[, lb_tb2$is_numeric], 2, function(i) { + sd(i, na.rm = TRUE) + }) + lb_tb2$quantile[lb_tb2$is_numeric] <- apply(df[, lb_tb2$is_numeric], 2, function(i) { + as.list(quantile(i, na.rm = TRUE)) + }) + } + + # return + return(lb_tb2) +} + +# Any element of column is an empty string? columns are vectors +#' @rdname describe_cols +#' @export +is_empty_string <- function(column) { + if (anyNA(column)) { + column[is.na(column)] <- "NA" + } + return(as.character(column) == "") +} +# Function to check for long strings +#' @rdname describe_cols +#' @export +check_long_strings <- function(column, max_length = 80) { + checkmate::assert_int(max_length, lower = 1, upper = 500, null.ok = FALSE) + column <- as.character(column) + if (anyNA(column)) { + column[is.na(column)] <- "NA" + } + long_strings <- nchar(column) > max_length + if (any(long_strings, na.rm = TRUE)) { + return(long_strings) + } else { + return(NULL) + } +} + +# Function to check for specific special characters +#' @rdname describe_cols +#' @export +check_special_chars <- function(column, special_chr = "[\\n\\r\\{\\}\\[\\]]") { + checkmate::assert_character(special_chr, null.ok = FALSE) + column <- as.character(column) + if (anyNA(column)) { + column[is.na(column)] <- "NA" + } + special_chars <- stringr::str_detect(column, stringr::regex(special_chr)) + if (any(special_chars, na.rm = TRUE)) { + return(special_chars) + } else { + return(NULL) + } +} + +#' @examples +#' # Lets find those values that are too long +#' +#' @rdname describe_cols +#' @export +detect_issues <- function(df, + additional_checks = list( + "too_long" = check_long_strings, + "special_chars" = check_special_chars + ), + extra_args = list(max_length = 80, special_chr = "outlier"), + max_desc_length = 80) { + checkmate::assert_int(max_desc_length, lower = 1, upper = 500, null.ok = FALSE) + df_col_desc <- describe_cols(df = df, additional_checks = additional_checks, extra_args = extra_args) + condition_v <- list( + "have_long_desc" = ifelse(is.na(df_col_desc$desc), FALSE, nchar(df_col_desc$desc) > max_desc_length), + "have_empty_levels" = df_col_desc$n_empty_levels > 0, + "have_nas_not_levels" = df_col_desc$n_empty_levels < 0 + ) + if (any(condition_v$have_long_desc)) { + cur_c <- condition_v$have_long_desc + message( + "The following columns have long descriptions: ", + paste(df_col_desc$col.name[cur_c], collapse = ", ") + ) + } + if (any(condition_v$have_empty_levels)) { + cur_c <- condition_v$have_empty_levels + message( + "The following columns are ", unique(df_col_desc$type[cur_c]), " and have empty levels: ", + paste(df_col_desc$col.name[cur_c], collapse = ", ") + ) + } + if (any(condition_v$have_nas_not_levels)) { + cur_c <- condition_v$have_nas_not_levels + message( + "The following columns are ", unique(df_col_desc$type[cur_c]), " and have NAs that are not levels: ", + paste(df_col_desc$col.name[cur_c], collapse = ", ") + ) + } +} diff --git a/_pkgdown.yml b/_pkgdown.yml index 3f62c4b7..52ab5e47 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -112,3 +112,10 @@ reference: - sample_fct - rcd_var_relabel - visit_schedule + + - title: Utility Functions For Dimensionaly Control and Reduction + desc: Function to simplify data pre-processing and recognize error-prone inputs + contents: + - reduce_num_levels_in_df + - describe_cols + - diff --git a/inst/WORDLIST b/inst/WORDLIST index 13d4a120..582c8a50 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -62,6 +62,7 @@ WOS Xiuting Xuefeng anthropometric +casted cdisc de dipietrc diff --git a/man/apply_metadata.Rd b/man/apply_metadata.Rd index d05b1236..80714d6c 100644 --- a/man/apply_metadata.Rd +++ b/man/apply_metadata.Rd @@ -36,4 +36,5 @@ adsub <- apply_metadata( adsub, file.path(yaml_path, "ADSUB.yml"), TRUE, file.path(yaml_path, "ADSL.yml") ) + } diff --git a/man/describe_cols.Rd b/man/describe_cols.Rd new file mode 100644 index 00000000..aa5feb69 --- /dev/null +++ b/man/describe_cols.Rd @@ -0,0 +1,119 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_dim_control_and_checks.R +\name{describe_cols} +\alias{describe_cols} +\alias{is_empty_string} +\alias{check_long_strings} +\alias{check_special_chars} +\alias{detect_issues} +\title{Describe columns of a data frame} +\usage{ +describe_cols( + df, + additional_checks = list(too_long = check_long_strings, special_chars = + check_special_chars), + extra_args = list(max_length = 80, special_chr = "outlier"), + max_desc_length = 80 +) + +is_empty_string(column) + +check_long_strings(column, max_length = 80) + +check_special_chars(column, special_chr = "[\\\\n\\\\r\\\\{\\\\}\\\\[\\\\]]") + +detect_issues( + df, + additional_checks = list(too_long = check_long_strings, special_chars = + check_special_chars), + extra_args = list(max_length = 80, special_chr = "outlier"), + max_desc_length = 80 +) +} +\arguments{ +\item{df}{(\code{data.frame})\cr Data like \code{random.cdisc.data::cadae}.} + +\item{additional_checks}{(named \code{list} of functions)\cr List of functions that take in input a column +and return a vector of logicals. List names are used as column names for the returning \code{tibble}. Needs +to have at least a \code{"column"} parameter. See \code{\link[=check_long_strings]{check_long_strings()}} for an example.} + +\item{max_desc_length}{(\code{integer(1)})\cr Maximum length of the description of any column name. You can retrieve this +attribute using \code{\link[formatters:var_labels]{formatters::var_labels()}} on the data. \code{NA} is returned when absent.} + +\item{column}{(\code{character})\cr Column to describe. If using a custom function, please consider how to handle +all types and missing values (\code{NA}).} + +\item{max_length}{(\code{integer(1)})\cr Maximum length of a string.} + +\item{special_chr}{(\code{character(1)})\cr Regular expression to detect special characters.} +} +\value{ +A \code{tibble} with the following columns: +\itemize{ +\item \code{col.name}: column name. We do not expect this code name to be longer than 5 - 10 characters. +\item \code{desc}: description of the column (output of \code{\link[formatters:var_labels]{formatters::var_labels()}}). +\item \code{long_desc}: \code{TRUE} if \code{desc} is longer than 80 characters. Use \code{max_desc_length} to change this variable. +\item \code{nrows}: number of elements or rows (useful when having multiple data to compare). +\item \code{type}: type of the column. +\item \code{is_numeric}: logical indicating if the column is numeric. +\item \code{n_na}: number of missing values. +\item \code{n_empty}: number of empty strings. +\item \code{n_unique}: number of unique values (everything is casted as factor). +\item \code{n_levels}: number of levels (if factor) or number of unique values (if character). +\item \code{n_empty_levels}: number of empty levels if > 0. If it is -1 the column is a factor that +contains some missing values (\code{NA}). +\item \code{additional_checks} list names: output of additional checks functions. +\item \code{mean}: mean of the column (if numeric). +\item \code{sd}: standard deviation of the column (if numeric). +\item \code{quartiles}: quartiles of the column (if numeric). +} +} +\description{ +This function uses some simple descriptor to describe the columns of a data frame. It is an indicative +function and it is not intended to be used for a full description or analysis of the data. +} +\examples{ +# Describe columns of a data frame +describe_cols(random.cdisc.data::cadae) + +adae <- random.cdisc.data::cadae +adae$STUDYID[1] <- "missing" # We search for this string +adae$USUBJID[2] <- paste0(rep("a", 40), collapse = "_") # Too long for us!! + +# Let's add one custom check function (additional_checks param) +check_spec_missing_str <- function(column, missing_str) { + # We want characters + column <- as.character(column) + # We do not want NAs (already taken into account before) + if (anyNA(column)) { + column[is.na(column)] <- "NA" + } + # Checking if it is "missing" + if (is.character(column)) { + return(column == missing_str) + } else { + return(0) # not applicable (e.g. is numeric) + } +} + +# Our description function +out <- describe_cols( + adae, + additional_checks = list( + "very_long" = check_long_strings, + "n_missing" = check_spec_missing_str + ), + extra_args = list( # extra arguments for our additional_checks functions + "max_length" = 70, + "missing_str" = "missing" + ) +) +out[out$n_missing > 0, ] # STUDYID has 1 "missing" value +out[out$very_long > 0, ] # USUBJID has 1 long string + +# Lets find those values that are too long + +} +\seealso{ +\code{\link[=reduce_num_levels_in_df]{reduce_num_levels_in_df()}} for how to reduce pivotal values when \code{n_unique} is too high. +} diff --git a/man/reduce_num_levels_in_df.Rd b/man/reduce_num_levels_in_df.Rd new file mode 100644 index 00000000..842850bc --- /dev/null +++ b/man/reduce_num_levels_in_df.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils_dim_control_and_checks.R +\name{reduce_num_levels_in_df} +\alias{reduce_num_levels_in_df} +\title{Reduce number of levels in a column of a \code{data.frame}} +\usage{ +reduce_num_levels_in_df( + df, + variable, + p_to_keep = 0.7, + num_max_values = NULL, + num_of_rare_values = 0, + add_specific_value = NULL, + keep_spec_rows = NULL, + explorative = FALSE, + verbose = TRUE +) +} +\arguments{ +\item{df}{(\code{data.frame})\cr data.frame with too many levels for a \code{variable}.} + +\item{variable}{(\code{character(1)})\cr string with the name of the column to be reduced.} + +\item{p_to_keep}{(\code{numeric(1)})\cr probability cut-off to keep the most frequent levels. If \code{num_max_values} is +specified (i.e. not \code{NULL}) this is not used.} + +\item{num_max_values}{(\code{integer(1)})\cr maximum number of levels to keep. This encompasses only +rare values (\code{num_of_rare_values}) but not additional desired values (\code{add_specific_value}) +and rows (\code{keep_spec_rows}).} + +\item{num_of_rare_values}{(\code{integer(1)})\cr number of additional rare values to keep. These are selected +from the least frequent levels.} + +\item{add_specific_value}{(\code{character})\cr specific values to keep.} + +\item{keep_spec_rows}{(\code{integer})\cr specific rows to keep.} + +\item{explorative}{(\code{logical(1)})\cr if \code{TRUE}, a plot with the frequency distribution of levels is shown.} + +\item{verbose}{(\code{logical(1)})\cr if \code{TRUE}, messages are printed.} +} +\value{ +A modified \code{data.frame} or a plot if \code{explorative = TRUE}. +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Use this function to reduce the number of levels in a \code{data.frame} column called \code{variable}. +This function calculates the frequency distribution of levels and sets either a soft threshold +based on the probability cut-off (\code{p_to_keep}) and/or an hard threshold (\code{num_max_values}). +Consider checking the number of unique values in each pivotal data column with \code{\link[=describe_cols]{describe_cols()}}. +} +\details{ +If necessary, a number of additional rare values can be picked from the least represented levels +(\code{num_of_rare_values}). For general use it is also possible to keep certain values +(\code{add_specific_value}) and rows (\code{keep_spec_rows}). Exploratory plots can be also appreciated with +\code{explorative = TRUE}. +} +\examples{ +# real case scenario: trimming of variables with too many levels +random.cdisc.data::cadae \%>\% + reduce_num_levels_in_df(adae_pharmaverse, "AEDECOD", + num_max_values = 7, num_of_rare_values = 1, + add_specific_value = c( + "VOMITING", "NAUSEA", "SKIN IRRITATION", "HEADACHE", # For SMQ01NAM, SMQ02NAM, CQ01NAM + "MYOCARDIAL INFARCTION" # for aet07 AESDTH == "Y" + ) + ) + +} diff --git a/man/rel_var.Rd b/man/rel_var.Rd index 97782184..58ae9e2e 100644 --- a/man/rel_var.Rd +++ b/man/rel_var.Rd @@ -53,4 +53,5 @@ rel_var( var_values = c("A", "B", "C"), related_var = "PARAM" ) + } diff --git a/man/rtexp.Rd b/man/rtexp.Rd index b933ee8a..b354ef96 100644 --- a/man/rtexp.Rd +++ b/man/rtexp.Rd @@ -38,4 +38,5 @@ hist(y) z <- rtexp(1e6, rate = 5, r = 0.5) hist(z) + } diff --git a/man/rtpois.Rd b/man/rtpois.Rd index c1034713..d2511dce 100644 --- a/man/rtpois.Rd +++ b/man/rtpois.Rd @@ -30,4 +30,5 @@ hist(x) y <- rtpois(1e6, lambda = 5) hist(y) + } diff --git a/man/sample_fct.Rd b/man/sample_fct.Rd index a754cb25..d8a66650 100644 --- a/man/sample_fct.Rd +++ b/man/sample_fct.Rd @@ -4,13 +4,15 @@ \alias{sample_fct} \title{Create a Factor with Random Elements of x} \usage{ -sample_fct(x, N, ...) +sample_fct(x, N, random_seed = NULL, ...) } \arguments{ -\item{x}{(\verb{character vector} or \code{factor})\cr If character vector then it is also used +\item{x}{(\code{character} or \code{factor})\cr If character vector then it is also used as levels of the returned factor. If factor then the levels are used as the new levels.} -\item{N}{(\code{numeric})\cr Number of items to choose.} +\item{N}{(\code{numeric(1)})\cr Number of items to choose.} + +\item{random_seed}{(\code{numeric(1)} or \code{NULL})\cr Seed for random number generation.} \item{...}{Additional arguments to be passed to \code{sample}.} } @@ -23,4 +25,5 @@ Sample elements from \code{x} with replacement to build a factor. \examples{ sample_fct(letters[1:3], 10) sample_fct(iris$Species, 10) + } diff --git a/man/visit_schedule.Rd b/man/visit_schedule.Rd index d42f823e..3cc71a22 100644 --- a/man/visit_schedule.Rd +++ b/man/visit_schedule.Rd @@ -25,4 +25,5 @@ X number of visits, or X number of cycles and Y number of days. \examples{ visit_schedule(visit_format = "WEeK", n_assessments = 10L) visit_schedule(visit_format = "CyCLE", n_assessments = 5L, n_days = 2L) + } diff --git a/tests/testthat/test-utils_dim_control_and_checks.R b/tests/testthat/test-utils_dim_control_and_checks.R new file mode 100644 index 00000000..da8b1406 --- /dev/null +++ b/tests/testthat/test-utils_dim_control_and_checks.R @@ -0,0 +1,93 @@ +test_that("Checking that levels are reduced correctly for multiple variables with defaults", { + expect_message( + out <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD"), + paste0( + "Reducing levels of random.cdisc.data::cadae for variable AEDECOD: ", + "keeping 6 levels out of 10 levels. Total rows kept \\(\\%\\): 63.3" + ) + ) + expect_equal(length(levels(out$AEDECOD)), 6L) +}) + +test_that("reduce_num_levels_in_df(explorative = TRUE) Plots are returned", { + skip_if_not_installed("ggplot2") + suppressMessages(a_plot <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD", explorative = TRUE)) + expect_true(ggplot2::is.ggplot(a_plot)) + suppressMessages(a_plot <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD", + explorative = TRUE, + num_max_values = 5 + )) + expect_true(ggplot2::is.ggplot(a_plot)) + cadae_tmp <- random.cdisc.data::cadae %>% mutate(AEDECOD = as.character(AEDECOD)) + cadae_tmp$AEDECOD[1] <- "an_outlier" + cadae_tmp$AEDECOD[2] <- "another_outlier" + suppressMessages(a_plot <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD", + explorative = TRUE, + num_max_values = 5, add_specific_value = "an_outlier" + )) + expect_true(ggplot2::is.ggplot(a_plot)) + suppressMessages(suppressWarnings(a_plot <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD", + explorative = TRUE, + num_max_values = 5, add_specific_value = c("an_outlier", "another_outlier") + ))) + expect_true(ggplot2::is.ggplot(a_plot)) +}) + +test_that("reduce_num_levels_in_df(num_max_values) works", { + expect_message( + out <- reduce_num_levels_in_df(random.cdisc.data::cadae, "AEDECOD", num_max_values = 5), + "keeping 5 levels out of 10 levels" + ) + expect_equal(length(levels(out$AEDECOD)), 5L) +}) + +test_that("reduce_num_levels_in_df(num_max_values, num_of_rare_values) works", { + cadae_tmp <- random.cdisc.data::cadae %>% mutate(AEDECOD = as.character(AEDECOD)) + cadae_tmp$AEDECOD[1] <- "an_outlier" + expect_message( + out <- reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, num_of_rare_values = 2), + "keeping 5 levels out of 11 levels" + ) + + expect_equal(length(levels(out$AEDECOD)), 5L) + expect_true(cadae_tmp$AEDECOD[1] %in% names(table(out$AEDECOD))) + + expect_error(reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, num_of_rare_values = 6)) +}) + +test_that("reduce_num_levels_in_df(add_specific_value) works", { + cadae_tmp <- random.cdisc.data::cadae %>% mutate(AEDECOD = as.character(AEDECOD)) + cadae_tmp$AEDECOD[1] <- "an_outlier" + expect_message( + out <- reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, add_specific_value = "an_outlier"), + "keeping 6 levels out of 11 levels" + ) + + expect_equal(length(levels(out$AEDECOD)), 6L) + expect_true(cadae_tmp$AEDECOD[1] %in% names(table(out$AEDECOD))) + + expect_error(reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, add_specific_value = 6)) +}) + +test_that("reduce_num_levels_in_df(add_specific_value) works", { + cadae_tmp <- random.cdisc.data::cadae %>% mutate(AEDECOD = as.character(AEDECOD)) + cadae_tmp$AEDECOD[1] <- "an_outlier" + expect_message( + out <- reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, keep_spec_rows = c(1, 4)), + "keeping 5 \\+ 1 \\(from keep_spec_rows\\)" + ) + + expect_equal(length(levels(out$AEDECOD)), 6L) + expect_true(cadae_tmp$AEDECOD[1] %in% names(table(out$AEDECOD))) + + expect_error(reduce_num_levels_in_df(cadae_tmp, "AEDECOD", num_max_values = 5, keep_spec_rows = "asdsa")) +}) + +# describe_cols ---------------------------------------------------------------- +test_that("describe_cols(df) works", { + adae <- random.cdisc.data::cadae + expect_equal( + describe_cols(adae)$col.name, + colnames(adae) + ) +}) diff --git a/vignettes/data_pre_processing.Rmd b/vignettes/data_pre_processing.Rmd new file mode 100644 index 00000000..4f924a5e --- /dev/null +++ b/vignettes/data_pre_processing.Rmd @@ -0,0 +1,29 @@ +--- +title: "Short data preprocessing tutorial" +output: rmarkdown::html_vignette +author: Davide Garolini +vignette: > + %\VignetteIndexEntry{Short data preprocessing tutorial} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8}{inputenc} +--- + +## Introduction + +This short tutorial aims at giving you a couple of simple approaches to massive and seemingly confusing data. We start with general column summaries, that is something you may already know well, and we will end up into reducing number of levels per variable and identify and split the strings that are too long. + +## General data summaries + +For our purposes, we only use `random.cdisc.data::cadae` as example data because it has the right amount of complexity and size. Real version of ADAE have been proven very large too. As this first part covers also direct comparisons, we use `pharmaverseadam` package to get the ADAE data. + +```{r} +library(random.cdisc.data) +data("cadae") +``` + + +## Reducing number of levels per variable + +## Identifying and splitting long strings + +## Find custom issues in data