diff --git a/DESCRIPTION b/DESCRIPTION index 62f5d65..9206ef7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -22,11 +22,10 @@ Imports: grDevices, grid, janitor, + keyring, labelled, - lazyeval, lubridate (>= 1.7.4), magrittr (>= 1.5), - plyr, purrr (>= 0.3.3), readr, rlang, @@ -34,18 +33,22 @@ Imports: scales, stringr (>= 1.4.0), tibble (>= 2.1.3), - tidyr (>= 1.0.0) + tidyr (>= 1.0.0), + tidyselect Suggests: devtools, knitr, rmarkdown, - testthat, + testthat (>= 3.0.0), usethis, ggridges, ggalt, - forcats + forcats, + qualtRics, + haven VignetteBuilder: knitr Encoding: UTF-8 LazyData: true -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.0 +Config/testthat/edition: 3 diff --git a/NAMESPACE b/NAMESPACE index 7849b48..41521cd 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -32,11 +32,14 @@ export(tableN) export(theme_tntp) export(theme_tntp_2018) export(tntp_colors) +export(tntp_cred) +export(tntp_cred_list) +export(tntp_cred_set) export(tntp_palette) export(tntp_style) export(update_geom_font_defaults) export(update_tntpr) importFrom(formattable,percent) -importFrom(ggplot2,'%+replace%') +importFrom(ggplot2,"%+replace%") importFrom(ggplot2,theme_minimal) importFrom(magrittr,"%>%") diff --git a/R/bar_chart_counts.R b/R/bar_chart_counts.R index bc5898e..bfe9470 100644 --- a/R/bar_chart_counts.R +++ b/R/bar_chart_counts.R @@ -7,7 +7,7 @@ #' @param var unquoted column name for variable to count #' @param group_var (optional) unquoted column name for group variable. If this is specified, you get a 2-variable clustered bar chart. If left blank, a single variable bar chart. #' @param labels should labels show the count (\code{"n"}) or the percentage (\code{"pct"})? -#' @param var_color color for non-grouped charts; set to medium_blue by default. For both this and \code{group_colors}, strings will be tried in \code{palette_tntp} automatically. So \code{c("orange", "dark_blue")} will get you the official TNTP colors, while \code{c("orange", "blue")} will get you TNTP orange but generic blue. +#' @param var_color color for non-grouped charts; set to TNTP green by default. For both this and \code{group_colors}, strings will be tried in \code{tntp_colors} automatically. So \code{c("red", "green")} will get you the official TNTP colors, while \code{c("red", "brown")} will get you base R red and blue. #' @param group_colors character vector of group colors, if a specific palette is desired #' @param title main chart title #' @param var_label label for x-axis @@ -17,40 +17,45 @@ #' @export #' @examples #' -#' # all examples not run b/c of Travis CI failures -#' # failure due to not having Segoe UI font imported -#' # library(dplyr) # for %>% pipe -#' # # An N bar chart by default -#' # mtcars %>% -#' # bar_chart_counts(var = cyl, -#' # title = "Number of mtcars by cylinder") -#' # -#' # # Use a grouping variable -#' # mtcars %>% -#' # bar_chart_counts(var = cyl, -#' # group_var = vs, -#' # labels = "pct", -#' # title = "Percentage of V vs. Straight engines by # of cylinders") -#' # -#' # # Change default color -#' # mtcars %>% -#' # bar_chart_counts(var = cyl, -#' # var_color = "orange", -#' # title = "Number of mtcars by cylinder") -#' # # Specify color by group -#' # bar_chart_counts(mtcars, am, cyl, -#' # group_colors = c("orange", "green", "dark_blue"), -#' # labels = "pct") +#' # An N bar chart by default +#' # All examples use font = "sans" to avoid triggering font warnings +#' mtcars |> +#' bar_chart_counts(var = cyl, +#' title = "Number of mtcars by cylinder", +#' font = "sans") +#' +#' # Use a grouping variable +#' mtcars |> +#' bar_chart_counts(var = cyl, +#' group_var = vs, +#' labels = "pct", +#' title = "% of V vs. Straight engines by # of cylinders", +#' font = "sans") +#' +#' # Change default color +#' mtcars |> +#' bar_chart_counts(var = cyl, +#' var_color = "orange", +#' title = "Number of mtcars by cylinder", +#' font = "sans") +#' +#' # Specify color by group +#' mtcars |> +#' bar_chart_counts(am, cyl, +#' group_colors = c("orange", "green", "navy"), +#' labels = "pct", +#' font = "sans") + bar_chart_counts <- function(df, var, - group_var, + group_var = NULL, labels = "n", - var_color = "medium_blue", - group_colors, + var_color = "green", + group_colors = NULL, title = NULL, - var_label, + var_label = NULL, digits = 1, - font = "Segoe UI", + font = "Halyard Display", font_size = 12) { # QC: Throw an error if object supplied to df is not a data.frame ----------- if (!is.data.frame(df)) { @@ -62,86 +67,87 @@ bar_chart_counts <- function(df, stop("You must supply a column name to the var argument") } + # Ensure the specified font is valid + font <- get_usable_family(font) + + # Store whether there is a grouping variable + grouped <- !rlang::quo_is_null(rlang::enquo(group_var)) # Create a plot_data object ------------------------------------------------- # plot_data should contain user specified column and its factor equivalent # Check if a grouping variable was specified - if (missing(group_var)) { - plot_data <- df %>% - dplyr::select_(.dots = list(vec = lazyeval::lazy(var))) %>% - dplyr::mutate(vec.factor = as.factor(vec)) %>% - dplyr::group_by(vec.factor) %>% - dplyr::tally() %>% + if (!grouped) { + plot_data <- df |> + dplyr::select(vec = {{var}}) |> + dplyr::mutate(vec.factor = as.factor(vec)) |> + dplyr::group_by(vec.factor) |> + dplyr::tally() |> dplyr::mutate(perc = n / sum(n)) } else { - plot_data <- df %>% - dplyr::select_(.dots = list( - vec = lazyeval::lazy(var), - group.vec = lazyeval::lazy(group_var) - )) %>% + plot_data <- df |> + dplyr::select(vec = {{var}}, + group.vec = {{group_var}}) |> dplyr::mutate( vec.factor = as.factor(vec), group.factor = as.factor(group.vec) - ) %>% - dplyr::group_by(vec.factor, group.factor) %>% - dplyr::tally() %>% - dplyr::group_by(vec.factor) %>% - dplyr::mutate(perc = n / sum(n)) %>% - dplyr::ungroup() %>% + ) |> + dplyr::group_by(vec.factor, group.factor) |> + dplyr::tally() |> + dplyr::group_by(vec.factor) |> + dplyr::mutate(perc = n / sum(n)) |> + dplyr::ungroup() |> tidyr::complete(vec.factor, group.factor, fill = list(n = NA, perc = NA)) } # Create a color palette ---------------------------------------------------- # Check if group_var is supplied - if (!missing(group_var)) { - if (missing(group_colors)) { + if (grouped) { + if (is.null(group_colors)) { # QC: If group_var is supplied, but no colors, create a color palette # while also making sure there are enough colors for each group # Select a color for each level of the factor-ed grouping variable. Must # be less than or equal to 11 (because we only have 11 TNTP colors) - num_groups <- plot_data$group.factor %>% - levels() %>% + num_groups <- plot_data$group.factor |> + levels() |> length() - if (num_groups > 11) { - stop("The maximum number of levels allowed in group_var is 11") + if (num_groups > 7) { + stop("The maximum number of levels in group_var with the default color palette is 7") } - tntp_col_pal <- palette_tntp( - "dark_blue", "medium_blue", "light_blue", - "orange", "gold", "green", "dark_grey", - "medium_grey", "light_grey", "white", - "black" - )[1:num_groups] + # Use the new colorful palette by default + tntp_col_pal <- tntp_palette('colorful') + } else { # QC: Throw an error if the number of levels in supplied group_var does # not equal the number of group_colors - num_group_var <- plot_data$group.factor %>% - levels() %>% + num_group_var <- plot_data$group.factor |> + levels() |> length() - num_group_col <- group_colors %>% length() + num_group_col <- group_colors |> length() if (num_group_var != num_group_col) { stop("The number of group_colors must equal the number of levels supplied to group_var") } - # Switch color name strings to the HEX codes + + # Match provided color names to either TNTP or base R colors tntp_col_pal <- swap_colors(group_colors) } } # Check whether user specified an x axis label ------------------------------ - if (missing(var_label)) { + if (is.null(var_label)) { var_label <- deparse(substitute(var)) } # Build the N bar chart ----------------------------------------------------- # Condition on presence of group_var - if (missing(group_var)) { + if (!grouped) { if (labels == "pct") { nbc <- ggplot2::ggplot(data = plot_data, ggplot2::aes(x = vec.factor, y = perc)) + ggplot2::geom_bar(fill = swap_colors(var_color), stat = "identity") + @@ -200,7 +206,7 @@ bar_chart_counts <- function(df, # Polish the plot to presentation standards --------------------------------- - # so labels don't get cropped, set the y scale 5% higher than the highest bar + # so labels don't get cropped, set the y scale 10% higher than the highest bar max_height <- dplyr::if_else(labels == "pct", max(plot_data$perc, na.rm = TRUE) * 1.1, max(plot_data$n, na.rm = TRUE) * 1.1 @@ -211,64 +217,25 @@ bar_chart_counts <- function(df, limits = c(0, max_height) ) + ggplot2::labs(title = title, x = var_label) + - ggplot2::theme( - axis.line.y = ggplot2::element_blank(), - axis.line.x = ggplot2::element_line( - color = "grey70", - size = 0.20 - ), - axis.text.y = ggplot2::element_blank(), - axis.text.x = ggplot2::element_text( - family = font, - size = font_size - ), - axis.ticks = ggplot2::element_blank(), - axis.title.x = ggplot2::element_text( - family = font, - size = font_size - ), - axis.title.y = ggplot2::element_blank(), - legend.key = ggplot2::element_blank(), - legend.position = "bottom", - legend.text = ggplot2::element_text( - family = font, - size = font_size - ), - legend.title = ggplot2::element_blank(), - panel.background = ggplot2::element_blank(), - panel.grid.major = ggplot2::element_blank(), - panel.grid.minor = ggplot2::element_blank(), - plot.title = ggplot2::element_text( - family = font, - face = "bold", - size = font_size - ) - ) + tntp_style(family = font) + + ggplot2::theme(axis.text.y = ggplot2::element_blank()) nbc } # function to swap in custom TNTP colors - swap_colors <- function(x) { - plyr::mapvalues(x, - from = c( - "dark_blue", "medium_blue", - "light_blue", "green", - "orange", "gold", - "dark_grey", "dark_gray", - "medium_grey", "medium_gray", - "light_grey", "light_gray", - "white", "black" - ), - to = c( - "#034772", "#2888BC", - "#73B7CE", "#699D46", - "#EA8936", "#F9C347", - "#58595B", "#58595B", - "#7D7E81", "#7D7E81", - "#C1C2C4", "#C1C2C4", - "#FFFFFF", "#000000" - ), - warn_missing = FALSE - ) + # Attempt to match to TNTP colors first + tryCatch(tntp_colors(x), + error = \(e) { + # Attempt to test all values as R colors next + if(is_color(x)) { + cli::cli_inform(c("i" = "Unable to map some colors from {.val {x}} to TNTP colors. Using base R colors instead.")) + x + } else { + cli::cli_warn(c("!" = "Unable to map some colors from {.val {x}} to either TNTP colors or base R colors.", + "i" = "Using values from {.code tntp_palette('colorful')} instead.")) + tntp_palette('colorful') + } + + }) } diff --git a/R/data.R b/R/data.R index 6a73341..078cdec 100644 --- a/R/data.R +++ b/R/data.R @@ -34,44 +34,44 @@ #' #' @format A data frame with 39,339 rows and 38 variables: #' \describe{ -#' \\item{tid}{double: Teacher ID} -#' \\item{fake_data}{double: Record Is Simulated} -#' \\item{school_year}{double: School Year} -#' \\item{school_code}{double: School Code} -#' \\item{school_name}{character: School Name} -#' \\item{t_male}{double: Teacher Is Male} -#' \\item{t_race_ethnicity}{double: Teacher Race/Ethnicity} -#' \\item{t_job_area}{double: Teacher Assignment Type} -#' \\item{t_salary}{double: Monthly Salary} -#' \\item{t_nbpts}{double: Teacher Has National Board Certification} -#' \\item{t_tenured}{double: Teacher Is Tenured} -#' \\item{t_experience}{double: Years of Teaching Experience} -#' \\item{t_fte}{double: Teacher's FTE Status} -#' \\item{t_highest_degree}{double: Teacher's Highest Degree} -#' \\item{t_licensed_stem}{double: Teacher Is Licensed In STEM Field} -#' \\item{t_eval_obs}{double: Evaluation Summary Observation Score} -#' \\item{t_eval_growth}{double: Evaluation Summary Student Growth Score} -#' \\item{t_stay}{double: Teacher in Same School in Following Year} -#' \\item{t_transfer}{double: Teacher in Different School in Following Year} -#' \\item{t_leave}{double: Teacher Not Teaching in Fake County Schools in Following Year} -#' \\item{t_novice}{double: Teacher Is Novice First-Year Teacher} -#' \\item{t_new_hire}{double: Teacher Did Not Teach in Fake County in Prior Year} -#' \\item{sch_elem}{double: School Is Elementary School} -#' \\item{sch_middle}{double: School Is Middle School} -#' \\item{sch_high}{double: School Is High School} -#' \\item{sch_alternative}{double: School Is Alternative School} -#' \\item{sch_regular}{double: School Is Regular School} -#' \\item{sch_title_1}{double: School Is Title 1 School} -#' \\item{sch_magnet}{double: School Is Magnet School} -#' \\item{sch_vocati~l}{double: School is Vocational School} -#' \\item{sch_region}{double: School Region Code} -#' \\item{sch_calendar_type}{double: School Calendar Type} -#' \\item{sch_iep_pct}{double: School Special Education Student Share in 2012-15} -#' \\item{sch_minority_pct}{double: School Minority Student Share in 2012-15} -#' \\item{sch_frpl_pct}{double: School Free and Reduced Price Lunch Student Share in 2012-15} -#' \\item{sch_ela_avg}{double: School ELA Test Score Average in 2012-15 (in standard deviations)} -#' \\item{sch_math_avg}{double: School Math Test Score Average in 2012-15 (in standard deviations)} -#' \\item{sch_enrollment_2015}{double: School Enrollment in 2015} +#' \item{tid}{double: Teacher ID} +#' \item{fake_data}{double: Record Is Simulated} +#' \item{school_year}{double: School Year} +#' \item{school_code}{double: School Code} +#' \item{school_name}{character: School Name} +#' \item{t_male}{double: Teacher Is Male} +#' \item{t_race_ethnicity}{double: Teacher Race/Ethnicity} +#' \item{t_job_area}{double: Teacher Assignment Type} +#' \item{t_salary}{double: Monthly Salary} +#' \item{t_nbpts}{double: Teacher Has National Board Certification} +#' \item{t_tenured}{double: Teacher Is Tenured} +#' \item{t_experience}{double: Years of Teaching Experience} +#' \item{t_fte}{double: Teacher's FTE Status} +#' \item{t_highest_degree}{double: Teacher's Highest Degree} +#' \item{t_licensed_stem}{double: Teacher Is Licensed In STEM Field} +#' \item{t_eval_obs}{double: Evaluation Summary Observation Score} +#' \item{t_eval_growth}{double: Evaluation Summary Student Growth Score} +#' \item{t_stay}{double: Teacher in Same School in Following Year} +#' \item{t_transfer}{double: Teacher in Different School in Following Year} +#' \item{t_leave}{double: Teacher Not Teaching in Fake County Schools in Following Year} +#' \item{t_novice}{double: Teacher Is Novice First-Year Teacher} +#' \item{t_new_hire}{double: Teacher Did Not Teach in Fake County in Prior Year} +#' \item{sch_elem}{double: School Is Elementary School} +#' \item{sch_middle}{double: School Is Middle School} +#' \item{sch_high}{double: School Is High School} +#' \item{sch_alternative}{double: School Is Alternative School} +#' \item{sch_regular}{double: School Is Regular School} +#' \item{sch_title_1}{double: School Is Title 1 School} +#' \item{sch_magnet}{double: School Is Magnet School} +#' \item{sch_vocational}{double: School is Vocational School} +#' \item{sch_region}{double: School Region Code} +#' \item{sch_calendar_type}{double: School Calendar Type} +#' \item{sch_iep_pct}{double: School Special Education Student Share in 2012-15} +#' \item{sch_minority_pct}{double: School Minority Student Share in 2012-15} +#' \item{sch_frpl_pct}{double: School Free and Reduced Price Lunch Student Share in 2012-15} +#' \item{sch_ela_avg}{double: School ELA Test Score Average in 2012-15 (in standard deviations)} +#' \item{sch_math_avg}{double: School Math Test Score Average in 2012-15 (in standard deviations)} +#' \item{sch_enroll_2015}{double: School Enrollment in 2015} #' } #' @source \url{https://github.com/OpenSDP/fake-county}, posted under a Creative Commons license. "fake_county" diff --git a/R/date_to_sy.R b/R/date_to_sy.R index 198dab4..6935d7f 100644 --- a/R/date_to_sy.R +++ b/R/date_to_sy.R @@ -1,10 +1,12 @@ #' @title Convert a date value into its school year. #' +#' @md +#' #' @description #' Checks to see if a date is past the user-specified cutoff point for delineating school years, then maps to the appropriate year. #' -#' @param date_var the date to convert. -#' @param last_day_of_sy the cutoff date, after which a date is considered part of the following school year. The year of this argument does not matter. +#' @param date_var the date to convert. Can be a `Date` object or a string in the form 'YYYY-MM-DD' or 'MM/DD/YYYY' +#' @param last_day_of_sy the cutoff date, after which a date is considered part of the following school year. The year of this argument does not matter. Defaults (noisily) to July 1st. #' @return Returns a character vector in the format of "2013 - 2014" #' @examples @@ -16,10 +18,15 @@ ## Date to SY function ## Year of 2nd argument does not matter ## Turns 2015-10-02 into "2015-16", and 2016-04-05 into "2015-16", with cutoff day = 2010-07-01 -date_to_sy <- function(date_var, last_day_of_sy) { - if (!(lubridate::is.Date(date_var) & lubridate::is.Date(last_day_of_sy))) { - stop("`date_var` and `last_day_of_sy` must both be class Date") +date_to_sy <- function(date_var, last_day_of_sy = NULL) { + if(is.null(last_day_of_sy)) { + last_day_of_sy <- as.Date("2000-07-01") + cli::cli_inform(c("!" = "No cutoff date provided. Using a default cutoff date of {.val {format(last_day_of_sy, '%B %d')}}")) } + + date_var <- parse_date(date_var) + last_day_of_sy <- parse_date(last_day_of_sy) + cutoff_day <- lubridate::day(last_day_of_sy) cutoff_month <- lubridate::month(last_day_of_sy) dplyr::case_when( @@ -29,3 +36,37 @@ date_to_sy <- function(date_var, last_day_of_sy) { TRUE ~ paste0(lubridate::year(date_var) - 1, " - ", lubridate::year(date_var)) # prior to cutoff = SY X-1 to X ) } + +#' Attempt to parse a date with common formats +#' +#' Helper function for date_to_sy. Returns a date object as is, or noisily attempts to parse +#' a string in the form YYYY-MM-DD or MM/DD/YYYY. If the date cannot be parsed, +#' throws an error. +#' +#' @param date a character or Date vector to parse +#' +#' @return Date vector +#' +parse_date <- function(date) { + + parse_formats <- c("%Y-%m-%d", + "%m/%d/%Y") + + if(lubridate::is.Date(date)) { + date + } else { + parsed_date <- tryCatch( + as.Date(date, tryFormats = parse_formats), + error = \(e) { + cli::cli_abort(c("x" = "Could not parse date {.val {date}}", + "i" = "Pass a {.cls Date} object or a string in the form {.val YYYY-MM-DD} or {.val MM/DD/YYYY} instead")) + }) + + # Fix two-digit years (assumes 20..) + yr <- lubridate::year(parsed_date) + lubridate::year(parsed_date) <- yr + ifelse(yr < 100, 2000, 0) + + cli::cli_inform(c("i" = "Parsed {.val {date}} as {.val {format(parsed_date, '%B %d, %Y')}}")) + parsed_date + } +} diff --git a/R/factorize.R b/R/factorize.R index c96f97b..6a478d7 100644 --- a/R/factorize.R +++ b/R/factorize.R @@ -2,68 +2,116 @@ #' #' @param vec character vector. #' @param valid_strings the values that the variable can possibly take on. +#' @param ignore.case if TRUE, ignores case in matching #' #' @return numeric proportion between 0 and 1. -prop_matching <- function(vec, valid_strings) { +prop_matching <- function(vec, valid_strings, ignore.case = FALSE) { vec <- as.character(vec) if (all(is.na(vec))) { message("Fully NA column detected; consider janitor::remove_empty()") return(0) } + if(ignore.case) { + vec <- tolower(vec) + valid_strings <- tolower(valid_strings) + } mean(vec[!is.na(vec)] %in% valid_strings) } +#' Update case of a character vector +#' +#' Helper function for factorize_df(). Returns a vector of the same length as vec, +#' with any values that match values in valid_strings updated to the case in valid_strings +#' +#' @param vec The character vector you want to update +#' @param new_case A character vector of correctly cased strings +#' +#' @return a character vector the same length as vec +#' +standardize_case <- function(vec, new_case) { + + names(new_case) <- tolower(new_case) + vec_l <- tolower(vec) + + ifelse(vec_l %in% names(new_case), + new_case[vec_l], vec) +} + #' @title Convert all character vectors containing a set of values in a data.frame to factors. #' @description This function examines each column in a data.frame; when it finds a column composed solely of the values provided to the \code{lvls} argument it updates them to be factor variables, with levels in the order provided. #' #' This is an alternative to calling \code{dplyr::mutate_at} with \code{factor()} and identifying the specific variables you want to transform, if you have several repeated sets of responses. #' +#' @md #' @param dat data.frame with some factor variables stored as characters. #' @param lvls The factor levels in your variable(s), in order. If you have a question whose possible responses are a subset of another question's, don't use this function; manipulate the specific columns with \code{dplyr::mutate_at}. +#' @param ignore.case Logical. If TRUE, will match without checking case, using the capitalization from the `lvls` parameter for the final output. If not provided, the function will provide a warning if it detects columns that would match without checking case but will NOT coerce them. #' #' @return data.frame with factorization completed in place. #' @export #' @examples -#' library(dplyr) -#' mtcars %>% -#' dplyr::mutate(agr = rep(c("Somewhat agree", "Strongly disagree"), 16)) %>% -#' factorize_df(lvls = c("Strongly disagree", "Somewhat disagree", -#' "Somewhat agree", "Strongly agree")) +#' teacher_survey |> +#' factorize_df(lvls = c("Strongly Disagree", "Disagree", "Somewhat Disagree", +#' "Somewhat Agree", "Agree", "Strongly Agree")) #' #' # prints warning due to case mismatches: -#' mtcars %>% -#' dplyr::mutate(agr = rep(c("Somewhat Agree", "Strongly Disagree"), 16)) %>% -#' factorize_df(lvls = c("Strongly disagree", "Somewhat disagree", -#' "Somewhat agree", "Strongly agree")) -factorize_df <- function(dat, lvls) { - dat_out <- dat %>% - dplyr::mutate_if(~ prop_matching(.x, lvls) == 1, ~ factor(., lvls)) +#' teacher_survey |> +#' factorize_df(lvls = c("Strongly disagree", "Disagree", "Somewhat disagree", +#' "Somewhat agree", "Agree", "Strongly agree")) +factorize_df <- function(dat, lvls, ignore.case = NULL) { + match_exact <- sapply(dat, prop_matching, lvls) + match_all <- sapply(dat, prop_matching, lvls, ignore.case=TRUE) + + # Do any columns match without case, but not match exactly? + match_nocase <- (match_all == 1) & (match_exact < 1) + + dat_out <- dat + + if(is.null(ignore.case) || !ignore.case) { + transform_cols <- names(match_exact[match_exact == 1]) + + } else { + transform_cols <- names(match_all[match_all == 1]) + # Update capitalization if ignoring case + dat_out <- dat_out |> + dplyr::mutate(dplyr::across(tidyselect::all_of(transform_cols), + ~standardize_case(., lvls))) + } + + dat_out <- dat_out |> + dplyr::mutate(dplyr::across(tidyselect::all_of(transform_cols), + ~factor(., lvls))) # col types stored as list-columns to be robust to multi-part col classes, e.g., POSIX dates with two parts col_diffs <- cbind( - lapply(dat, class), - lapply(dat_out, class) - ) %>% - tibble::as_tibble(., rownames = "var_name") %>% + V1 = lapply(dat, class), + V2 = lapply(dat_out, class) + ) |> + tibble::as_tibble(rownames = "var_name") |> dplyr::mutate(match_prop = purrr::map_dbl(dat, ~ prop_matching(.x, lvls))) types_changed <- purrr::map2_lgl(col_diffs$V1, col_diffs$V2, purrr::negate(identical)) changed_cols <- col_diffs$var_name[types_changed] + # ignore.case messages + if(is.null(ignore.case) && any(match_nocase)) { + cli::cli_warn(c("!" = "Column{?s} {.var {names(match_nocase)[match_nocase]}} {?was/were} NOT matched, but would match if {.var ignore.case} was set to {.val TRUE}")) + } + # message if a match was _already_ a factor, the transformations made, or if no matches new_text <- "" - if (any(col_diffs$match_prop == 1 & purrr::map_lgl(dat, inherits, "factor"))) { - warning("at least one matching column was already a factor, though this call will have reordered it if different levels provided. Could be caused by overlapping sets of factor levels, e.g., \"Yes\", \"Maybe\", \"No\" and \"Yes\", \"No\".") + if(any(col_diffs$match_prop == 1 & purrr::map_lgl(dat, inherits, "factor"))) { + cli::cli_warn(c("!" = "At least one matching column was already a factor, though this call will have reordered it if different levels were provided. This could be caused by overlapping sets of factor levels, e.g., {.val Yes}, {.val Maybe}, {.val No} and {.val Yes}, {.val No}")) new_text <- "new " } - if (length(changed_cols) > 0) { - message(paste("Transformed these columns: \n", paste("* ", changed_cols, collapse = ", \n"))) + if(length(changed_cols) > 0) { + cli::cli_inform(c("i" = "Changed the following columns to factors: {.var {changed_cols}}")) } else { - warning(paste0("No ", new_text, "columns matched. Check spelling & capitalization of your levels.")) + cli::cli_warn(c("!" = "No {new_text}columns matched. Check spelling & capitalization of your levels.")) } tibble::as_tibble(dat_out) diff --git a/R/labelled_to_factors.R b/R/labelled_to_factors.R index b183e23..09901c9 100644 --- a/R/labelled_to_factors.R +++ b/R/labelled_to_factors.R @@ -1,16 +1,24 @@ -#' @title Convert all \code{labelled}-class columns to factors. +#' @title Convert all `labelled`-class columns to factors. +#' +#' @md #' #' @description -#' Takes a data.frame, checks for columns that are class \code{labelled} from the \code{haven} package, and converts them to factor class. +#' Deprecated. Use the `as_factor()` function from the `haven` package instead for the same functionality. +#' +#' Takes a data.frame, checks for columns that are class `labelled` from the `haven` package, and converts them to factor class. #' #' @param labels_df a data.frame containing some columns of class labelled #' @return Returns a data.frame. #' @export #' @examples -#' # not run -#' # haven::read_spss(filepath) %>% labelled_to_factor() -# Convert labelled columns to factors +#' +#' tntpr::fake_county |> +#' haven::as_factor() +#' labelled_to_factors <- function(labels_df) { + + .Deprecated() + labeled_var_index <- unlist( lapply(labels_df, function(x) class(x) == "labelled") ) diff --git a/R/survey_utils.R b/R/survey_utils.R index 4d07bd2..db40a27 100644 --- a/R/survey_utils.R +++ b/R/survey_utils.R @@ -106,7 +106,7 @@ convert_to_top_2_agree <- function(x, custom_vals = NULL) { #' check_all_recode(contains("q1")) #' check_all_recode <- function(dat, ..., set_labels = TRUE) { - dat <- dplyr::as_data_frame(dat) # so that single bracket subsetting behaves as expected later and returns a data.frame + dat <- tibble::as_tibble(dat) # so that single bracket subsetting behaves as expected later and returns a data.frame original_order <- names(dat) cols_of_interest <- dat %>% dplyr::select(...) %>% @@ -128,7 +128,7 @@ check_all_recode <- function(dat, ..., set_labels = TRUE) { cols_of_interest[responded, ][!is.na(cols_of_interest[responded, ])] <- 1 cols_of_interest[responded, ][is.na(cols_of_interest[responded, ])] <- 0 # convert columns to numeric - cols_of_interest <- lapply(cols_of_interest, as.numeric) %>% dplyr::as_data_frame() + cols_of_interest <- lapply(cols_of_interest, as.numeric) %>% as.data.frame() # restore labels if (set_labels) { diff --git a/R/theme_tntp.R b/R/theme_tntp.R index e354fa5..a6ba79e 100644 --- a/R/theme_tntp.R +++ b/R/theme_tntp.R @@ -19,7 +19,7 @@ #' @param caption_align alignment of caption, defaults to "right"; also accepts "left" or "center" #' @param caption_color color of caption text #' @param caption_size size of caption text -#' @importFrom ggplot2 '%+replace%' +#' @importFrom ggplot2 %+replace% #' @export #' @rdname theme_tntp @@ -73,8 +73,8 @@ theme_tntp <- function(show_legend_title = TRUE, legend.key = ggplot2::element_blank(), # Remove border from legend boxes panel.grid.major = ggplot2::element_line(color = grid_color), panel.grid.minor = ggplot2::element_blank(), # Remove minor gridlines entirely - axis.line.y = ggplot2::element_line(color = "black", size = 0.25), - axis.line.x = ggplot2::element_line(color = "black", size = 0.25), + axis.line.y = ggplot2::element_line(color = "black", linewidth = 0.25), + axis.line.x = ggplot2::element_line(color = "black", linewidth = 0.25), plot.title = ggplot2::element_text( hjust = title_h_just, colour = title_color, diff --git a/R/theme_tntp_2018.R b/R/theme_tntp_2018.R index 33b3d0a..20cfd35 100644 --- a/R/theme_tntp_2018.R +++ b/R/theme_tntp_2018.R @@ -92,9 +92,9 @@ theme_tntp_2018 <- function(base_family = "Segoe UI", base_size = 11.5, ret <- ret + ggplot2::theme(legend.key = ggplot2::element_blank()) if (inherits(grid, "character") | grid == TRUE) { - ret <- ret + ggplot2::theme(panel.grid = ggplot2::element_line(color = grid_col, size = 0.2)) - ret <- ret + ggplot2::theme(panel.grid.major = ggplot2::element_line(color = grid_col, size = 0.2)) - ret <- ret + ggplot2::theme(panel.grid.minor = ggplot2::element_line(color = grid_col, size = 0.15)) + ret <- ret + ggplot2::theme(panel.grid = ggplot2::element_line(color = grid_col, linewidth = 0.2)) + ret <- ret + ggplot2::theme(panel.grid.major = ggplot2::element_line(color = grid_col, linewidth = 0.2)) + ret <- ret + ggplot2::theme(panel.grid.minor = ggplot2::element_line(color = grid_col, linewidth = 0.15)) if (inherits(grid, "character")) { if (regexpr("X", grid)[1] < 0) ret <- ret + ggplot2::theme(panel.grid.major.x = ggplot2::element_blank()) @@ -123,22 +123,22 @@ theme_tntp_2018 <- function(base_family = "Segoe UI", base_size = 11.5, } if (inherits(axis, "character") | axis == TRUE) { - ret <- ret + ggplot2::theme(axis.line = ggplot2::element_line(color = "#2b2b2b", size = 0.15)) + ret <- ret + ggplot2::theme(axis.line = ggplot2::element_line(color = "#2b2b2b", linewidth = 0.15)) if (inherits(axis, "character")) { axis <- tolower(axis) if (regexpr("x", axis)[1] < 0) { ret <- ret + ggplot2::theme(axis.line.x = ggplot2::element_blank()) } else { - ret <- ret + ggplot2::theme(axis.line.x = ggplot2::element_line(color = axis_col, size = 0.15)) + ret <- ret + ggplot2::theme(axis.line.x = ggplot2::element_line(color = axis_col, linewidth = 0.15)) } if (regexpr("y", axis)[1] < 0) { ret <- ret + ggplot2::theme(axis.line.y = ggplot2::element_blank()) } else { - ret <- ret + ggplot2::theme(axis.line.y = ggplot2::element_line(color = axis_col, size = 0.15)) + ret <- ret + ggplot2::theme(axis.line.y = ggplot2::element_line(color = axis_col, linewidth = 0.15)) } } else { - ret <- ret + ggplot2::theme(axis.line.x = ggplot2::element_line(color = axis_col, size = 0.15)) - ret <- ret + ggplot2::theme(axis.line.y = ggplot2::element_line(color = axis_col, size = 0.15)) + ret <- ret + ggplot2::theme(axis.line.x = ggplot2::element_line(color = axis_col, linewidth = 0.15)) + ret <- ret + ggplot2::theme(axis.line.y = ggplot2::element_line(color = axis_col, linewidth = 0.15)) } } else { ret <- ret + ggplot2::theme(axis.line = ggplot2::element_blank()) @@ -149,9 +149,9 @@ theme_tntp_2018 <- function(base_family = "Segoe UI", base_size = 11.5, ret <- ret + ggplot2::theme(axis.ticks.x = ggplot2::element_blank()) ret <- ret + ggplot2::theme(axis.ticks.y = ggplot2::element_blank()) } else { - ret <- ret + ggplot2::theme(axis.ticks = ggplot2::element_line(size = 0.15)) - ret <- ret + ggplot2::theme(axis.ticks.x = ggplot2::element_line(size = 0.15)) - ret <- ret + ggplot2::theme(axis.ticks.y = ggplot2::element_line(size = 0.15)) + ret <- ret + ggplot2::theme(axis.ticks = ggplot2::element_line(linewidth = 0.15)) + ret <- ret + ggplot2::theme(axis.ticks.x = ggplot2::element_line(linewidth = 0.15)) + ret <- ret + ggplot2::theme(axis.ticks.y = ggplot2::element_line(linewidth = 0.15)) ret <- ret + ggplot2::theme(axis.ticks.length = grid::unit(5, "pt")) } diff --git a/R/tntp_colors.R b/R/tntp_colors.R index 7eefbaf..dbb5200 100644 --- a/R/tntp_colors.R +++ b/R/tntp_colors.R @@ -136,13 +136,21 @@ tntp_colors <- function(...) { tntp_color_list[supplied_colors] |> unname() } -# Validate color inputs +#' Validate color inputs +#' +#' @param x a color +#' +#' @return TRUE if x can be interpreted as a color is_color <- function(x) { res <- try(grDevices::col2rgb(x), silent = TRUE) return(!"try-error" %in% class(res)) } -# Choose a text color given a background color +#' Choose a text color given a background color +#' +#' @param bg_color a color +#' +#' @return "black" or "white" choose_text_color <- function(bg_color) { stopifnot(is_color(bg_color)) ifelse(colSums(grDevices::col2rgb(bg_color) * c(.299, .587, .114)) > 150, diff --git a/R/tntp_cred.R b/R/tntp_cred.R new file mode 100644 index 0000000..6cf340a --- /dev/null +++ b/R/tntp_cred.R @@ -0,0 +1,110 @@ +#' TNTP Credential Get/Set Command +#' +#' @description +#' A wrapper around the `keyring` package for secure credential management. +#' +#' `tntp_cred()` will attempt to get a credential, and if no credential is found +#' it will prompt you to add it (and then return it). +#' +#' `tntp_cred_set()` will set a credential. By default it will prompt before +#' overwriting any current credentials. +#' +#' `tntp_cred_list()` will list all current credentials by sorted by service +#' and username. +#' +#' @md +#' +#' @param service The identifier for the credential you are pulling or setting +#' @param username OPTIONAL. Can be used to specify different usernames for the same service +#' @param keyring OPTIONAL. Can be used to specify a specific keyring +#' @param prompt OPTIONAL. What text should be displayed above the input box for the key while setting? +#' @param overwrite OPTIONAL. By default, `tntp_cred_set()` will prompt if it finds a credential already saved. Set this to `TRUE` to overwrite without prompting or `FALSE` to throw an error if a current credential is found. +#' +#' @return A stored (or newly created) credential +#' @export +#' +#' @examples +#' \dontrun{ +#' # Using tntp_cred() with qualtRics +#' library(qualtRics) +#' +#' # If no credential is set, this command will prompt for it first +#' qualtrics_token <- tntp_cred("QUALTRICS_TOKEN") +#' qualtrics_api_credentials(api_key = qualtrics_token, +#' base_url = 'tntp.co1.qualtrics.com') +#' +#' # To overwrite your Qualtrics credential +#' tntp_cred("QUALTRICS_TOKEN", .set = TRUE) +#' } +#' +tntp_cred <- function(service, username = NULL, keyring = NULL, prompt = NULL) { + + # Pull with key_get, or return an error + cred <- tryCatch(keyring::key_get(service, username, keyring), + error = function(e) e) + + # If a credential isn't found, prompt user to create it + if(("error" %in% attr(cred, "class"))) { + + cli::cli_inform(c("i" = "No credentials found for {.val {service}}", + "i" = "To list all current credentials stop the script and run {.run tntpr::tntp_cred_list()}", + "","Would you like to set new credentials for {.val {service}} now?")) + + input <- utils::select.list(c("Yes","No")) + + # If not, end with an error + if(input != "Yes") { + cli::cli_abort("No credentials found for {.val {service}}.") + } + + # If yes, set and then re-pull the credential + tntp_cred_set(service, username, keyring, prompt, overwrite = TRUE) + cred <- keyring::key_get(service, username, keyring) + + } + + # Return the credential + cred + +} + +#' @export +#' @rdname tntp_cred +tntp_cred_set <- function(service = NULL, username = NULL, keyring = NULL, prompt = NULL, overwrite = NULL) { + + if(is.null(prompt)) prompt <- paste0("Enter credential for '", service, "': ") + + # If overwrite is not TRUE, check for existing credential first + if(!isTRUE(overwrite)) { + + # Check for existence of key by looking for an error in key_get() + cred <- tryCatch(keyring::key_get(service, username, keyring), + error = function(e) e) + + # If a credential is found + if(!("error" %in% attr(cred, "class"))) { + + # If overwrite == FALSE, end with error + if(isFALSE(overwrite)) cli::cli_abort(c("x" = "Credential already found for this service and username.", + "i" = "To overwrite, run with parameter {.code overwrite = TRUE}")) + + # If overwrite is anything else (NULL), warn about duplicate and prompt to overwrite + cli::cli_inform(c("i" = "Credential already found for this service and username. Overwrite?")) + if(utils::select.list(c('Overwrite with new credential','Cancel')) == 'Cancel') cli::cli_abort("Credentials not updated") + } + } + + # Write credential + keyring::key_set(service, username, keyring, prompt) + +} + +#' @export +#' @rdname tntp_cred +tntp_cred_list <- function(service = NULL, keyring = NULL) { + # Pull with key_list + list <- keyring::key_list(service, keyring) + + # Sort by service, then username + list[order(list$service, list$username),] +} diff --git a/R/tntp_style.R b/R/tntp_style.R index 441babd..3c78378 100644 --- a/R/tntp_style.R +++ b/R/tntp_style.R @@ -1,25 +1,49 @@ -# Changes from BBC Style: -# - added options for title presence (legend, axis) -# - added options for title / legend / caption alignment (and defaults) -# - added options for grid lines -# - added options for font -# - added caption and legend/axis title styling (originally empty) -# - adjusted facet-title styling -# Unresolved: -# - font management (2018)? -# Questions: -# - do we add all the parameters with proper defaults? OR use + theme() -# - Include "most used" parameters, don't include others. -# - Add base_size to scale all text sizes -# - function name: keep as tntp_style() or match tntp_theme_xxxx() or theme_tntp() +#' Checks if a font family is usable and returns a usable font if not +#' +#' Helper function. Checks if a given family value is available, and if not returns +#' the default font family ("sans" or user provided) +#' +#' @param family the font family to check as a character +#' @param silent logical. If TRUE doesn't raise a warning if the font family is unavailable +#' @param default_family defaults to "sans", but can be set to another fallback family. +#' +#' @return a character of a usable font family +get_usable_family <- function(family, silent = FALSE, default_family = "sans") { -# Next steps - get to polished draft stage, then get feedback from folks. -# - We start using / testing. Think through questions above -# - Sam adds / drafts documentation -# - Finalize next meeting, then roll out to data team. + # Get a platform-independent list of usable fonts + if (.Platform$OS.type == "windows") { + font_list <- names(grDevices::windowsFonts()) + } else { + font_list <- names(grDevices::quartzFonts()) + } + # Make sure the default family is available + if(!default_family %in% font_list) { + cli::cli_abort(c( + "x" = "Default family {.val {default_family}} is not registered in the font table.", + "i" = "Run {.code extrafont::loadfonts()} to register non-core fonts (needs to be done once each session)", + "i" = "If you've never imported your fonts before, run {.code extrafont::font_import()} first, then {.code extrafont::loadfonts()}" + )) + } + + # Check to see if the provided family is available + if (!family %in% font_list) { + if(!silent) { + cli::cli_warn(c( + "x" = "Family {.val {family}} is not registered in the font table.", + "v" = "Using standard {.val sans} font instead", + "i" = "Run {.code extrafont::loadfonts()} to register non-core fonts (needs to be done once each session)", + "i" = "If you've never imported your fonts before, run {.code extrafont::font_import()} first, then {.code extrafont::loadfonts()}" + )) + } + + default_family + } else { + family + } +} #' Create TNTP themed [ggplot2] charts @@ -186,33 +210,13 @@ tntp_style <- function(family = "Halyard Display", } # Check that specified font(s) are available for use - if (.Platform$OS.type == "windows") { - font_list <- names(grDevices::windowsFonts()) + if(header_family != family) { + family <- get_usable_family(family) + header_family <- get_usable_family(header_family) } else { - font_list <- names(grDevices::quartzFonts()) - } - if (!header_family %in% font_list && header_family != family) { - cli::cli_warn(c( - "x" = "Family {.val {header_family}} is not registered in the font table.", - "v" = "Using standard {.val sans} font instead", - "i" = "Run {.code extrafont::loadfonts()} to register non-core fonts (needs to be done once each session)", - "i" = "If you've never imported your fonts before, run {.code extrafont::font_import()} first, then {.code extrafont::loadfonts()}" - )) - header_family <- "sans" + family <- get_usable_family(family) + header_family <- family } - if (!family %in% font_list) { - cli::cli_warn(c( - "x" = "Family {.val {family}} is not registered in the font table.", - "v" = "Using standard {.val sans} font instead", - "i" = "Run {.code extrafont::loadfonts()} to register non-core fonts (needs to be done once each session)", - "i" = "If you've never imported your fonts before, run {.code extrafont::font_import()} first, then {.code extrafont::loadfonts()}" - )) - - if(header_family == family) header_family <- "sans" - family <- "sans" - - } - # Convert text position to a numeric value to supply title_h_just <- switch(title_align, diff --git a/R/tntpr.R b/R/tntpr.R index ff258ff..d15aa3f 100644 --- a/R/tntpr.R +++ b/R/tntpr.R @@ -3,9 +3,8 @@ #' @description An in-house TNTP R package. Includes tools for data manipulation, #' analysis, and reporting, including making TNTP-themed charts and documents. #' By and for TNTP data-using staff, though available to the broader public. -#' @docType package #' @aliases tntpr tntpr-package #' @importFrom ggplot2 theme_minimal #' @importFrom magrittr %>% #' @importFrom formattable percent -NULL +"_PACKAGE" diff --git a/README.Rmd b/README.Rmd index 06c816c..2c2860b 100644 --- a/README.Rmd +++ b/README.Rmd @@ -36,33 +36,33 @@ Package summary Some of the highlights of the package include: +- TNTP brand colors and palettes with the `tntp_colors()` and + `tntp_palette()` functions +- A TNTP ggplot2 theme using brand fonts (`tntp_style()`) - TNTP-themed RMarkdown templates, for starting a new analysis with a shell that can already generate a TNTP-themed .docx report -- TNTP-specific ggplot2 theme and color palette - Functions for initializing a new repository or project folder with TNTP-standard directories and documentation -- Survey analysis tools +- Survey analysis tools such as `factorize_df()`, `recode_to_binary()`, + and functions for dealing with check-all style questions - Wrappers for quickly making typical TNTP-style charts (e.g., bar chart of means on variable 1 grouped by variable 2) -- Education-specific data management functions (e.g., `date_to_SY()` +- Education-specific data management functions (e.g., `date_to_sy()` to convert continuous hire dates into school years using a specified - cutoff date), and a built-in fake student achievement dataset to - play with called `wisc`. + cutoff date) +- Built-in fake data sets to practice with, including student achievement + data (`wisc`), teacher data (`fake_county`) and survey data + (`teacher_survey`) `tntpr` is built to work with the tidyverse set of packages. -Installing the package ----------------------- +Installing the `tntpr` package +------------------------------ -This package is not on CRAN, and probably will not ever be. You’ll need -to install this package from its GitHub repository. You can add this to -the top of your analysis script: - -## Install the `tntpr` package - -`tntpr` is not on CRAN, so you will have to install it directly from Github using `devtools`. - -If you do not have the `devtools` package installed, you will have to run the first line in the code below as well. +`tntpr` is not currently on CRAN, so you’ll need to install this package +from its GitHub repository using `devtools`. If you do not have the +`devtools` package installed, you will have to run the first line in the code +below as well: ```{r eval=FALSE} # install.packages('devtools') @@ -75,7 +75,8 @@ Once installed, you load it like any other package. library(tntpr) ``` -Once installed, you can update the package with `update_tntpr()`. +To update `tntpr`, you'll need to unload it (or start a fresh R session) and +then run the `install_github('tntp/tntpr')` command again. Feature Requests and Bug Reports diff --git a/README.md b/README.md index 05aaede..059e8fe 100644 --- a/README.md +++ b/README.md @@ -22,34 +22,32 @@ can be tailored to our exact use cases. Some of the highlights of the package include: +- TNTP brand colors and palettes with the `tntp_colors()` and + `tntp_palette()` functions +- A TNTP ggplot2 theme using brand fonts (`tntp_style()`) - TNTP-themed RMarkdown templates, for starting a new analysis with a shell that can already generate a TNTP-themed .docx report -- TNTP-specific ggplot2 theme and color palette - Functions for initializing a new repository or project folder with TNTP-standard directories and documentation -- Survey analysis tools +- Survey analysis tools such as `factorize_df()`, `recode_to_binary()`, + and functions for dealing with check-all style questions - Wrappers for quickly making typical TNTP-style charts (e.g., bar chart of means on variable 1 grouped by variable 2) -- Education-specific data management functions (e.g., `date_to_SY()` to +- Education-specific data management functions (e.g., `date_to_sy()` to convert continuous hire dates into school years using a specified - cutoff date), and a built-in fake student achievement dataset to play - with called `wisc`. + cutoff date) +- Built-in fake data sets to practice with, including student + achievement data (`wisc`), teacher data (`fake_county`) and survey + data (`teacher_survey`) `tntpr` is built to work with the tidyverse set of packages. -## Installing the package +## Installing the `tntpr` package -This package is not on CRAN, and probably will not ever be. You’ll need -to install this package from its GitHub repository. You can add this to -the top of your analysis script: - -## Install the `tntpr` package - -`tntpr` is not on CRAN, so you will have to install it directly from -Github using `devtools`. - -If you do not have the `devtools` package installed, you will have to -run the first line in the code below as well. +`tntpr` is not currently on CRAN, so you’ll need to install this package +from its GitHub repository using `devtools`. If you do not have the +`devtools` package installed, you will have to run the first line in the +code below as well: ``` r # install.packages('devtools') @@ -62,7 +60,8 @@ Once installed, you load it like any other package. library(tntpr) ``` -Once installed, you can update the package with `update_tntpr()`. +To update `tntpr`, you’ll need to unload it (or start a fresh R session) +and then run the `install_github('tntp/tntpr')` command again. ## Feature Requests and Bug Reports diff --git a/man/bar_chart_counts.Rd b/man/bar_chart_counts.Rd index a7f4959..34d06ce 100644 --- a/man/bar_chart_counts.Rd +++ b/man/bar_chart_counts.Rd @@ -7,14 +7,14 @@ bar_chart_counts( df, var, - group_var, + group_var = NULL, labels = "n", - var_color = "medium_blue", - group_colors, + var_color = "green", + group_colors = NULL, title = NULL, - var_label, + var_label = NULL, digits = 1, - font = "Segoe UI", + font = "Halyard Display", font_size = 12 ) } @@ -27,7 +27,7 @@ bar_chart_counts( \item{labels}{should labels show the count (\code{"n"}) or the percentage (\code{"pct"})?} -\item{var_color}{color for non-grouped charts; set to medium_blue by default. For both this and \code{group_colors}, strings will be tried in \code{palette_tntp} automatically. So \code{c("orange", "dark_blue")} will get you the official TNTP colors, while \code{c("orange", "blue")} will get you TNTP orange but generic blue.} +\item{var_color}{color for non-grouped charts; set to TNTP green by default. For both this and \code{group_colors}, strings will be tried in \code{tntp_colors} automatically. So \code{c("red", "green")} will get you the official TNTP colors, while \code{c("red", "brown")} will get you base R red and blue.} \item{group_colors}{character vector of group colors, if a specific palette is desired} @@ -47,28 +47,32 @@ an N bar chart (uses position dodge from ggplot2). } \examples{ -# all examples not run b/c of Travis CI failures -# failure due to not having Segoe UI font imported -# library(dplyr) # for \%>\% pipe -# # An N bar chart by default -# mtcars \%>\% -# bar_chart_counts(var = cyl, -# title = "Number of mtcars by cylinder") -# -# # Use a grouping variable -# mtcars \%>\% -# bar_chart_counts(var = cyl, -# group_var = vs, -# labels = "pct", -# title = "Percentage of V vs. Straight engines by # of cylinders") -# -# # Change default color -# mtcars \%>\% -# bar_chart_counts(var = cyl, -# var_color = "orange", -# title = "Number of mtcars by cylinder") -# # Specify color by group -# bar_chart_counts(mtcars, am, cyl, -# group_colors = c("orange", "green", "dark_blue"), -# labels = "pct") +# An N bar chart by default +# All examples use font = "sans" to avoid triggering font warnings +mtcars |> + bar_chart_counts(var = cyl, + title = "Number of mtcars by cylinder", + font = "sans") + +# Use a grouping variable +mtcars |> + bar_chart_counts(var = cyl, + group_var = vs, + labels = "pct", + title = "\% of V vs. Straight engines by # of cylinders", + font = "sans") + +# Change default color +mtcars |> + bar_chart_counts(var = cyl, + var_color = "orange", + title = "Number of mtcars by cylinder", + font = "sans") + +# Specify color by group +mtcars |> + bar_chart_counts(am, cyl, + group_colors = c("orange", "green", "navy"), + labels = "pct", + font = "sans") } diff --git a/man/choose_text_color.Rd b/man/choose_text_color.Rd new file mode 100644 index 0000000..6b376ca --- /dev/null +++ b/man/choose_text_color.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tntp_colors.R +\name{choose_text_color} +\alias{choose_text_color} +\title{Choose a text color given a background color} +\usage{ +choose_text_color(bg_color) +} +\arguments{ +\item{bg_color}{a color} +} +\value{ +"black" or "white" +} +\description{ +Choose a text color given a background color +} diff --git a/man/date_to_sy.Rd b/man/date_to_sy.Rd index 23f2dee..e425c62 100644 --- a/man/date_to_sy.Rd +++ b/man/date_to_sy.Rd @@ -4,12 +4,12 @@ \alias{date_to_sy} \title{Convert a date value into its school year.} \usage{ -date_to_sy(date_var, last_day_of_sy) +date_to_sy(date_var, last_day_of_sy = NULL) } \arguments{ -\item{date_var}{the date to convert.} +\item{date_var}{the date to convert. Can be a \code{Date} object or a string in the form 'YYYY-MM-DD' or 'MM/DD/YYYY'} -\item{last_day_of_sy}{the cutoff date, after which a date is considered part of the following school year. The year of this argument does not matter.} +\item{last_day_of_sy}{the cutoff date, after which a date is considered part of the following school year. The year of this argument does not matter. Defaults (noisily) to July 1st.} } \value{ Returns a character vector in the format of "2013 - 2014" diff --git a/man/factorize_df.Rd b/man/factorize_df.Rd index b8dfb05..d2fa114 100644 --- a/man/factorize_df.Rd +++ b/man/factorize_df.Rd @@ -4,12 +4,14 @@ \alias{factorize_df} \title{Convert all character vectors containing a set of values in a data.frame to factors.} \usage{ -factorize_df(dat, lvls) +factorize_df(dat, lvls, ignore.case = NULL) } \arguments{ \item{dat}{data.frame with some factor variables stored as characters.} \item{lvls}{The factor levels in your variable(s), in order. If you have a question whose possible responses are a subset of another question's, don't use this function; manipulate the specific columns with \code{dplyr::mutate_at}.} + +\item{ignore.case}{Logical. If TRUE, will match without checking case, using the capitalization from the \code{lvls} parameter for the final output. If not provided, the function will provide a warning if it detects columns that would match without checking case but will NOT coerce them.} } \value{ data.frame with factorization completed in place. @@ -20,15 +22,12 @@ This function examines each column in a data.frame; when it finds a column compo This is an alternative to calling \code{dplyr::mutate_at} with \code{factor()} and identifying the specific variables you want to transform, if you have several repeated sets of responses. } \examples{ -library(dplyr) -mtcars \%>\% - dplyr::mutate(agr = rep(c("Somewhat agree", "Strongly disagree"), 16)) \%>\% - factorize_df(lvls = c("Strongly disagree", "Somewhat disagree", - "Somewhat agree", "Strongly agree")) +teacher_survey |> + factorize_df(lvls = c("Strongly Disagree", "Disagree", "Somewhat Disagree", + "Somewhat Agree", "Agree", "Strongly Agree")) # prints warning due to case mismatches: -mtcars \%>\% - dplyr::mutate(agr = rep(c("Somewhat Agree", "Strongly Disagree"), 16)) \%>\% - factorize_df(lvls = c("Strongly disagree", "Somewhat disagree", - "Somewhat agree", "Strongly agree")) +teacher_survey |> + factorize_df(lvls = c("Strongly disagree", "Disagree", "Somewhat disagree", + "Somewhat agree", "Agree", "Strongly agree")) } diff --git a/man/fake_county.Rd b/man/fake_county.Rd index f51a3ed..61a3d3c 100644 --- a/man/fake_county.Rd +++ b/man/fake_county.Rd @@ -7,44 +7,44 @@ \format{ A data frame with 39,339 rows and 38 variables: \describe{ - \\item{tid}{double: Teacher ID} - \\item{fake_data}{double: Record Is Simulated} - \\item{school_year}{double: School Year} - \\item{school_code}{double: School Code} - \\item{school_name}{character: School Name} - \\item{t_male}{double: Teacher Is Male} - \\item{t_race_ethnicity}{double: Teacher Race/Ethnicity} - \\item{t_job_area}{double: Teacher Assignment Type} - \\item{t_salary}{double: Monthly Salary} - \\item{t_nbpts}{double: Teacher Has National Board Certification} - \\item{t_tenured}{double: Teacher Is Tenured} - \\item{t_experience}{double: Years of Teaching Experience} - \\item{t_fte}{double: Teacher's FTE Status} - \\item{t_highest_degree}{double: Teacher's Highest Degree} - \\item{t_licensed_stem}{double: Teacher Is Licensed In STEM Field} - \\item{t_eval_obs}{double: Evaluation Summary Observation Score} - \\item{t_eval_growth}{double: Evaluation Summary Student Growth Score} - \\item{t_stay}{double: Teacher in Same School in Following Year} - \\item{t_transfer}{double: Teacher in Different School in Following Year} - \\item{t_leave}{double: Teacher Not Teaching in Fake County Schools in Following Year} - \\item{t_novice}{double: Teacher Is Novice First-Year Teacher} - \\item{t_new_hire}{double: Teacher Did Not Teach in Fake County in Prior Year} - \\item{sch_elem}{double: School Is Elementary School} - \\item{sch_middle}{double: School Is Middle School} - \\item{sch_high}{double: School Is High School} - \\item{sch_alternative}{double: School Is Alternative School} - \\item{sch_regular}{double: School Is Regular School} - \\item{sch_title_1}{double: School Is Title 1 School} - \\item{sch_magnet}{double: School Is Magnet School} - \\item{sch_vocati~l}{double: School is Vocational School} - \\item{sch_region}{double: School Region Code} - \\item{sch_calendar_type}{double: School Calendar Type} - \\item{sch_iep_pct}{double: School Special Education Student Share in 2012-15} - \\item{sch_minority_pct}{double: School Minority Student Share in 2012-15} - \\item{sch_frpl_pct}{double: School Free and Reduced Price Lunch Student Share in 2012-15} - \\item{sch_ela_avg}{double: School ELA Test Score Average in 2012-15 (in standard deviations)} - \\item{sch_math_avg}{double: School Math Test Score Average in 2012-15 (in standard deviations)} - \\item{sch_enrollment_2015}{double: School Enrollment in 2015} + \item{tid}{double: Teacher ID} + \item{fake_data}{double: Record Is Simulated} + \item{school_year}{double: School Year} + \item{school_code}{double: School Code} + \item{school_name}{character: School Name} + \item{t_male}{double: Teacher Is Male} + \item{t_race_ethnicity}{double: Teacher Race/Ethnicity} + \item{t_job_area}{double: Teacher Assignment Type} + \item{t_salary}{double: Monthly Salary} + \item{t_nbpts}{double: Teacher Has National Board Certification} + \item{t_tenured}{double: Teacher Is Tenured} + \item{t_experience}{double: Years of Teaching Experience} + \item{t_fte}{double: Teacher's FTE Status} + \item{t_highest_degree}{double: Teacher's Highest Degree} + \item{t_licensed_stem}{double: Teacher Is Licensed In STEM Field} + \item{t_eval_obs}{double: Evaluation Summary Observation Score} + \item{t_eval_growth}{double: Evaluation Summary Student Growth Score} + \item{t_stay}{double: Teacher in Same School in Following Year} + \item{t_transfer}{double: Teacher in Different School in Following Year} + \item{t_leave}{double: Teacher Not Teaching in Fake County Schools in Following Year} + \item{t_novice}{double: Teacher Is Novice First-Year Teacher} + \item{t_new_hire}{double: Teacher Did Not Teach in Fake County in Prior Year} + \item{sch_elem}{double: School Is Elementary School} + \item{sch_middle}{double: School Is Middle School} + \item{sch_high}{double: School Is High School} + \item{sch_alternative}{double: School Is Alternative School} + \item{sch_regular}{double: School Is Regular School} + \item{sch_title_1}{double: School Is Title 1 School} + \item{sch_magnet}{double: School Is Magnet School} + \item{sch_vocational}{double: School is Vocational School} + \item{sch_region}{double: School Region Code} + \item{sch_calendar_type}{double: School Calendar Type} + \item{sch_iep_pct}{double: School Special Education Student Share in 2012-15} + \item{sch_minority_pct}{double: School Minority Student Share in 2012-15} + \item{sch_frpl_pct}{double: School Free and Reduced Price Lunch Student Share in 2012-15} + \item{sch_ela_avg}{double: School ELA Test Score Average in 2012-15 (in standard deviations)} + \item{sch_math_avg}{double: School Math Test Score Average in 2012-15 (in standard deviations)} + \item{sch_enroll_2015}{double: School Enrollment in 2015} } } \source{ diff --git a/man/get_usable_family.Rd b/man/get_usable_family.Rd new file mode 100644 index 0000000..13328c0 --- /dev/null +++ b/man/get_usable_family.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tntp_style.R +\name{get_usable_family} +\alias{get_usable_family} +\title{Checks if a font family is usable and returns a usable font if not} +\usage{ +get_usable_family(family, silent = FALSE, default_family = "sans") +} +\arguments{ +\item{family}{the font family to check as a character} + +\item{silent}{logical. If TRUE doesn't raise a warning if the font family is unavailable} + +\item{default_family}{defaults to "sans", but can be set to another fallback family.} +} +\value{ +a character of a usable font family +} +\description{ +Helper function. Checks if a given family value is available, and if not returns +the default font family ("sans" or user provided) +} diff --git a/man/is_color.Rd b/man/is_color.Rd new file mode 100644 index 0000000..26362b6 --- /dev/null +++ b/man/is_color.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tntp_colors.R +\name{is_color} +\alias{is_color} +\title{Validate color inputs} +\usage{ +is_color(x) +} +\arguments{ +\item{x}{a color} +} +\value{ +TRUE if x can be interpreted as a color +} +\description{ +Validate color inputs +} diff --git a/man/labelled_to_factors.Rd b/man/labelled_to_factors.Rd index d6d0729..beb96d9 100644 --- a/man/labelled_to_factors.Rd +++ b/man/labelled_to_factors.Rd @@ -13,9 +13,13 @@ labelled_to_factors(labels_df) Returns a data.frame. } \description{ +Deprecated. Use the \code{as_factor()} function from the \code{haven} package instead for the same functionality. + Takes a data.frame, checks for columns that are class \code{labelled} from the \code{haven} package, and converts them to factor class. } \examples{ -# not run -# haven::read_spss(filepath) \%>\% labelled_to_factor() + +tntpr::fake_county |> + haven::as_factor() + } diff --git a/man/parse_date.Rd b/man/parse_date.Rd new file mode 100644 index 0000000..48042ea --- /dev/null +++ b/man/parse_date.Rd @@ -0,0 +1,19 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/date_to_sy.R +\name{parse_date} +\alias{parse_date} +\title{Attempt to parse a date with common formats} +\usage{ +parse_date(date) +} +\arguments{ +\item{date}{a character or Date vector to parse} +} +\value{ +Date vector +} +\description{ +Helper function for date_to_sy. Returns a date object as is, or noisily attempts to parse +a string in the form YYYY-MM-DD or MM/DD/YYYY. If the date cannot be parsed, +throws an error. +} diff --git a/man/prop_matching.Rd b/man/prop_matching.Rd index 93d3eb9..2668bcd 100644 --- a/man/prop_matching.Rd +++ b/man/prop_matching.Rd @@ -4,12 +4,14 @@ \alias{prop_matching} \title{Calculate the percent of non-missing values in a character vector containing the values of interest. This is a helper function for factorize_df().} \usage{ -prop_matching(vec, valid_strings) +prop_matching(vec, valid_strings, ignore.case = FALSE) } \arguments{ \item{vec}{character vector.} \item{valid_strings}{the values that the variable can possibly take on.} + +\item{ignore.case}{if TRUE, ignores case in matching} } \value{ numeric proportion between 0 and 1. diff --git a/man/standardize_case.Rd b/man/standardize_case.Rd new file mode 100644 index 0000000..7f98e48 --- /dev/null +++ b/man/standardize_case.Rd @@ -0,0 +1,20 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/factorize.R +\name{standardize_case} +\alias{standardize_case} +\title{Update case of a character vector} +\usage{ +standardize_case(vec, new_case) +} +\arguments{ +\item{vec}{The character vector you want to update} + +\item{new_case}{A character vector of correctly cased strings} +} +\value{ +a character vector the same length as vec +} +\description{ +Helper function for factorize_df(). Returns a vector of the same length as vec, +with any values that match values in valid_strings updated to the case in valid_strings +} diff --git a/man/tntp_cred.Rd b/man/tntp_cred.Rd new file mode 100644 index 0000000..721da86 --- /dev/null +++ b/man/tntp_cred.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tntp_cred.R +\name{tntp_cred} +\alias{tntp_cred} +\alias{tntp_cred_set} +\alias{tntp_cred_list} +\title{TNTP Credential Get/Set Command} +\usage{ +tntp_cred(service, username = NULL, keyring = NULL, prompt = NULL) + +tntp_cred_set( + service = NULL, + username = NULL, + keyring = NULL, + prompt = NULL, + overwrite = NULL +) + +tntp_cred_list(service = NULL, keyring = NULL) +} +\arguments{ +\item{service}{The identifier for the credential you are pulling or setting} + +\item{username}{OPTIONAL. Can be used to specify different usernames for the same service} + +\item{keyring}{OPTIONAL. Can be used to specify a specific keyring} + +\item{prompt}{OPTIONAL. What text should be displayed above the input box for the key while setting?} + +\item{overwrite}{OPTIONAL. By default, \code{tntp_cred_set()} will prompt if it finds a credential already saved. Set this to \code{TRUE} to overwrite without prompting or \code{FALSE} to throw an error if a current credential is found.} +} +\value{ +A stored (or newly created) credential +} +\description{ +A wrapper around the \code{keyring} package for secure credential management. + +\code{tntp_cred()} will attempt to get a credential, and if no credential is found +it will prompt you to add it (and then return it). + +\code{tntp_cred_set()} will set a credential. By default it will prompt before +overwriting any current credentials. + +\code{tntp_cred_list()} will list all current credentials by sorted by service +and username. +} +\examples{ +\dontrun{ +# Using tntp_cred() with qualtRics +library(qualtRics) + +# If no credential is set, this command will prompt for it first +qualtrics_token <- tntp_cred("QUALTRICS_TOKEN") +qualtrics_api_credentials(api_key = qualtrics_token, + base_url = 'tntp.co1.qualtrics.com') + +# To overwrite your Qualtrics credential +tntp_cred("QUALTRICS_TOKEN", .set = TRUE) +} + +} diff --git a/man/tntpr.Rd b/man/tntpr.Rd index 8fd0f48..e3d7e04 100644 --- a/man/tntpr.Rd +++ b/man/tntpr.Rd @@ -10,3 +10,11 @@ An in-house TNTP R package. Includes tools for data manipulation, analysis, and reporting, including making TNTP-themed charts and documents. By and for TNTP data-using staff, though available to the broader public. } +\seealso{ +Useful links: +\itemize{ + \item \url{https://github.com/tntp/tntpr} + \item \url{https://tntp.github.io/tntpr/} +} + +} diff --git a/notes/TNTP Rebrand Color Recommendations.R b/notes/TNTP Rebrand Color Recommendations.R index d0ceea5..4e700f3 100644 --- a/notes/TNTP Rebrand Color Recommendations.R +++ b/notes/TNTP Rebrand Color Recommendations.R @@ -40,3 +40,154 @@ scales::show_col(c(dark_red, light_red, light_gray, light_green, dark_green), nc # 6pt likert scales::show_col(c(dark_red, medium_red, light_red, light_green, medium_green, dark_green), ncol = 6) + + + +# Example bar graph ------------------------------------------------------- + + + +county_data <- tntpr::fake_county |> + filter(t_salary > 0) + +school_salary <- county_data |> + filter(t_salary != 0) |> + group_by(school_year, school_name) |> + summarize(avg_salary = mean(t_salary, na.rm = TRUE), .groups = "drop") + +# create list of school names so we can easily filter data set for the number of schools we want +school_names <- unique(school_salary$school_name) + +# only plot two schools +line_plot_schools <- school_salary |> + filter(school_name %in% school_names[1:2]) + +bar_df <- school_salary |> + filter( + school_year == 2015, + school_name %in% school_names[1:5] + ) |> + # add line breaks for better plotting + mutate(school_name = str_wrap(school_name, 7)) + +ggplot(bar_df, aes(x = school_name, y = avg_salary)) + + geom_bar(stat ="identity", + position="identity", + fill = if_else(bar_df$school_name == 'Acacia\nMiddle', tntp_colors('yellow'), tntp_colors('dark_green'))) + + scale_y_continuous(labels = scales::dollar, limits = c(0, 5000)) + + labs( + title="Acacia had higher average salaries in 2015", + subtitle = "Average teacher salaries in 2015 by school" + ) + + tntp_style(base_size = 16) + +bar_df$school_name + + +# Likert ------------------------------------------------------------------ + +# the y-axis will contain text of an entire survey question +# we want to place line breaks in this text so plots look better +axis_line_breaks <- 40 + +# scales in HE questions, in order starting with the strongest +agree_disagree_scale <- rev(c("Strongly Agree", "Agree", "Somewhat Agree", "Somewhat Disagree", "Disagree", "Strongly Disagree")) + +# put survey into long form and clean up question names +teacher_survey_he <- teacher_survey |> + select(-timing) |> + pivot_longer(cols = everything(), names_to = 'question', values_to = 'response') + +# calculate percentage of responses to each high expectations question +teacher_survey_he_perc <- teacher_survey_he |> + drop_na("response") |> + # calculate the number of responses for each response option + count(question, response, name = 'n_response') |> + # calculate the number of responses for each question + group_by(question) |> + mutate(n_question = sum(n_response)) |> + ungroup() |> + # calculate percentages + mutate( + # calculate percentages + percent = n_response / n_question, + # make a column that is text of the percent for plotting + percent_pretty = scales::percent(percent, accuracy = 1) + ) + +# calculate percentage of strongly agree and agree +teacher_survey_he_perc <- teacher_survey_he_perc |> + mutate(scale_strength = ifelse(response %in% !!agree_disagree_scale[c(5,6)], 'Strong response', 'Weak response')) |> + group_by(question, scale_strength) |> + mutate(strong_response_percent = sum(percent)) |> + ungroup() |> + mutate( + strong_response_percent = ifelse(response == 'Agree', strong_response_percent, NA), + # create line breaks for questions ,which will make plots look better + question = str_wrap(question, axis_line_breaks), + response = factor(response, levels = agree_disagree_scale) + ) + +# colors to use +div_scale_colors <- tntp_palette('likert_6', reverse = TRUE) + +# mapping of colors and responses for plot +div_color_pal <- div_scale_colors |> + set_names(agree_disagree_scale) + +legend_order <- c(agree_disagree_scale[c(1,2,3)], agree_disagree_scale[c(6,5,4)]) + +teacher_survey_div <- teacher_survey_he_perc |> + mutate( + perc_diverge = ifelse(str_detect(response, '[D|d]isagree'), percent * -1, percent), + response = factor(response, levels = legend_order) + ) + +ggplot(teacher_survey_div, aes(x = perc_diverge, y = question, fill = response)) + + geom_col() + + scale_fill_manual( + values = div_color_pal, drop = FALSE, + breaks = agree_disagree_scale, + labels = agree_disagree_scale + ) + + geom_vline(aes(xintercept = 0), linetype = 1, linewidth = 1.2, alpha = .7) + + scale_x_continuous(limits = c(-1, 1), breaks = seq(-1, 1, .25), labels = function(x) scales::percent(abs(x))) + + labs( + title = "High Expectations Survey Responses", + x = NULL, + y = NULL + ) + + tntp_style(base_size = 16) + + +# Multiple Lines ---------------------------------------------------------- + + +#Prepare data +school_salary <- county_data |> + filter(t_salary != 0) |> + group_by(school_year, school_name) |> + summarize(avg_salary = mean(t_salary, na.rm = TRUE), .groups = "drop") + +# create list of school names so we can easily filter data set for the number of schools we want +school_names <- unique(school_salary$school_name) + +# only plot two schools +line_plot_schools <- school_salary |> + filter(school_name %in% school_names[1:4]) + +line_colors <- tntp_colors('dark_green', 'medium_blue', 'dark_red', 'yellow') + +ggplot(line_plot_schools, aes(x = school_year, y = avg_salary, color = school_name)) + + geom_line(linewidth = 2) + + scale_y_continuous(labels = scales::dollar, limits = c(0, 5000)) + + scale_colour_manual(values = line_colors) + + labs( + title="Average Teacher Salaries", + subtitle = "Relatively constant from 2012 to 2015", + x = NULL, + y = 'Average teacher salary' + ) + + tntp_style() + + guides(color = guide_legend(nrow = 2)) + diff --git a/tests/testthat.R b/tests/testthat.R index 70155ec..8b51b8a 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,3 +1,11 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + library(testthat) library(tntpr) diff --git a/tests/testthat/test-bar_chart_counts.R b/tests/testthat/test-bar_chart_counts.R new file mode 100644 index 0000000..45cc177 --- /dev/null +++ b/tests/testthat/test-bar_chart_counts.R @@ -0,0 +1,44 @@ +test_that("bar_chart_counts accurately summarizes data", { + + df <- tibble::tibble(col = c("c", "d", "e", "e", "d", "c", "c"), + grp = c("a", "b", "a", "b", "a", "a", "a"), + val = c(1, 2, 3, 4, 5, 6, 7)) + + plt <- bar_chart_counts(df, col) + exp <- tibble::tibble( + vec.factor = factor(c("c", "d", "e"), levels = c("c", "d", "e")), + n = c(3, 2, 2), + perc = c(3/7, 2/7, 2/7)) + expect_equal(plt$data, exp) + +}) + +test_that("bar_chart_counts grouping variable works", { + + df <- tibble::tibble(col = c("c", "d", "e", "e", "d", "c", "c"), + grp = c("a", "b", "a", "b", "a", "a", "a"), + val = c(1, 2, 3, 4, 5, 6, 7)) + + plt <- bar_chart_counts(df, col, grp) + exp <- tibble::tibble( + vec.factor = factor(rep(c("c", "d", "e"), each = 2), levels = c("c", "d", "e")), + group.factor = factor(rep(c("a", "b"), 3), levels = c("a", "b")), + n = c(3, NA, 1, 1, 1, 1), + perc = c(3/3, NA, 1/2, 1/2, 1/2, 1/2)) + expect_equal(plt$data, exp) + +}) + +test_that("swap_colors provides TNTP colors if possible", { + expect_equal(swap_colors(c('navy', 'mint')), tntp_colors('navy', 'mint')) +}) + +test_that("swap_colors uses R colors if TNTP colors aren't found", { + expect_message(swap_colors(c("brown", "orange")), "Unable to map some colors.* to TNTP colors") + expect_equal(suppressMessages(swap_colors(c("brown", "orange"))), c("brown", "orange")) +}) + +test_that("swqp_colors raises a warning and uses the colorful TNTP palette if no mapping is found", { + expect_warning(swap_colors(c("blue", "notacolor")), "Unable to map some colors") + expect_equal(suppressWarnings(swap_colors(c("blue", "notacolor"))), tntp_palette('colorful')) +}) diff --git a/tests/testthat/test-date-to-sy.R b/tests/testthat/test-date-to-sy.R index a9a9a55..0febb6c 100644 --- a/tests/testthat/test-date-to-sy.R +++ b/tests/testthat/test-date-to-sy.R @@ -1,9 +1,5 @@ # Tests for date-to-school year function -library(dplyr) -library(lubridate) -context("date_to_sy") - test_that("conversion is accurate", { expect_equal(date_to_sy(as.Date("2014-05-05"), as.Date("2000-07-01")), "2013 - 2014") expect_equal(date_to_sy(as.Date("2014-07-05"), as.Date("2000-07-01")), "2014 - 2015") diff --git a/tests/testthat/test-date_to_sy.R b/tests/testthat/test-date_to_sy.R new file mode 100644 index 0000000..621fb44 --- /dev/null +++ b/tests/testthat/test-date_to_sy.R @@ -0,0 +1,61 @@ + +test_that("date_to_sy works", { + + test_dates <- c(as.Date("2013-10-10"), + as.Date("2013-10-11"), + as.Date("2013-10-12")) + + exp <- c("2012 - 2013", + "2012 - 2013", + "2013 - 2014") + + expect_equal(date_to_sy(test_dates, as.Date("2010-10-11")), exp) + +}) + +test_that("date_to_sy defaults to a cutoff date of 7/1", { + test_dates <- c("6/30/19", + "7/1/19", + "7/2/19") + + exp <- c("2018 - 2019", + "2018 - 2019", + "2019 - 2020") + + expect_equal(suppressMessages(date_to_sy(test_dates)), exp) + + + expect_message(date_to_sy(as.Date("2013-01-01")), "Using a default cutoff date") + +}) + +test_that("parse_date works for different date formats", { + + d <- as.Date("2013-01-03") + + suppressMessages({ + expect_equal(parse_date("2013-1-3"), d) + expect_equal(parse_date("1/3/2013"), d) + expect_equal(parse_date(d), d) + expect_equal(parse_date("1/3/13"), d) + expect_equal(parse_date("13-1-3"), d) + }) + +}) + +test_that("parse_date works for character vectors", { + + dates <- c("1/1/13", "1/2/13", "1/3/13") + exp <- as.Date(c("2013-01-01", "2013-01-02", "2013-01-03")) + + expect_equal(suppressMessages(parse_date(dates)), exp) +}) + +test_that("parse_date is noisy when parsing, and silent when not", { + expect_message(parse_date("2013-1-3"), "Parsed") + expect_no_message(parse_date(as.Date("2013-01-013"))) +}) + +test_that("parse_date fails with bad input", { + expect_error(parse_date("notadate"), "Could not parse") +}) diff --git a/tests/testthat/test-factorize-df.R b/tests/testthat/test-factorize-df.R deleted file mode 100644 index 05e185a..0000000 --- a/tests/testthat/test-factorize-df.R +++ /dev/null @@ -1,50 +0,0 @@ -# Tests for factorizing columns based on string matching - -library(tntpr) -library(testthat) -context("factorize_df") - -x <- data.frame( - a = c("a lot", "a little", "some", "some"), - b = 1:4, - c = rep(as.POSIXct(Sys.Date()), 4), - stringsAsFactors = FALSE -) - -test_that("works with POSIX (two-class) columns present", { - y <- x - y$a <- factor(y$a, c("a little", "some", "a lot")) - expect_equal(tibble::as_tibble(y), factorize_df(x, c("a little", "some", "a lot"))) -}) - -test_that("warning message if no matches found", { - expect_warning(factorize_df(x, c("bugs", "birds")), - "No columns matched. Check spelling & capitalization of your levels.", - fixed = TRUE - ) -}) - -test_that("appropriate message prints if matched but already factor", { - aa <- factorize_df(x, 4:1) - ab <- aa - ab$d <- 1:4 - expect_warning(suppressMessages(factorize_df(aa, 4:1)), - "at least one matching column was already a factor, though this call will have reordered it if different levels provided. Could be caused by overlapping sets of factor levels, e.g., \"Yes\", \"Maybe\", \"No\" and \"Yes\", \"No\".", - fixed = TRUE - ) - - expect_warning(suppressMessages(factorize_df(aa, 4:1)), # it says no NEW columns, acknowledging that there was a match but it was already a factor - "No new columns matched. Check spelling & capitalization of your levels.", - fixed = TRUE - ) - - # the unusual case where there's a match on a non-factor and an already-present factor match - expect_warning(factorize_df(ab, 4:1), - "at least one matching column was already a factor, though this call will have reordered it if different levels provided. Could be caused by overlapping sets of factor levels, e.g., \"Yes\", \"Maybe\", \"No\" and \"Yes\", \"No\".", - fixed = TRUE - ) - expect_message(suppressWarnings(factorize_df(ab, 4:1)), - paste("Transformed these columns: \n", paste("* ", "d", collapse = ", \n")), - fixed = TRUE - ) -}) diff --git a/tests/testthat/test-factorize.R b/tests/testthat/test-factorize.R new file mode 100644 index 0000000..c2dd425 --- /dev/null +++ b/tests/testthat/test-factorize.R @@ -0,0 +1,82 @@ +# Example data frame for testing +x <- data.frame( + a = c("a lot", "a little", "some", "some"), + b = 1:4, + c = rep(as.POSIXct(Sys.Date()), 4), + stringsAsFactors = FALSE +) + +# Tests +test_that("prop_matching works as expected", { + a <- c("frog", "lizard", "frog", "frog") + b <- c("FroG", "LIZard", "FROG", "frog") + c <- c("frog", "bunny", "frog", "lizard") + + valid <- c("frog", "lizard") + + expect_equal(prop_matching(a, valid), 1) + expect_equal(prop_matching(b, valid, ignore.case = FALSE), 0.25) + expect_equal(prop_matching(b, valid, ignore.case = TRUE), 1) + expect_equal(prop_matching(c, valid), 0.75) +}) + +test_that("standardize_case works as expected", { + a <- c("yes", "no", "Yes", "Yess", "NO") + expect_equal(standardize_case(a, "Yes"), c("Yes", "no", "Yes", "Yess", "NO")) + expect_equal(standardize_case(a, c("YES", "NO")), c("YES", "NO", "YES", "Yess", "NO")) +}) + +test_that("ignore.case works", { + df <- tibble::tibble( + a = c("Yes", "yes", "No", "nO"), + b = c("Yes", "yes", "yes", "YES"), + c = c("yes", "maybe", "no", "no") + ) + + ymn <- c("yes", "maybe", "no") + YN <- c("Yes", "No") + + # Warning when not provided: + expect_equal(factorize_df(df, ymn), df |> dplyr::mutate(c = factor(c, levels = ymn))) |> + expect_warning("NOT matched, but would match if") |> + suppressMessages() + + # No warning when set to FALSE + expect_equal(factorize_df(df, ymn, ignore.case = FALSE), df |> dplyr::mutate(c = factor(c, levels = ymn))) |> + suppressMessages() + + # Ignores case and no warning when set to TRUE: + factorize_df(df, YN, ignore.case = TRUE) |> + expect_equal(df |> dplyr::mutate(a = factor(c("Yes", "Yes", "No", "No"), levels = YN), + b = factor(c("Yes", "Yes", "Yes", "Yes"), levels = YN))) |> + suppressMessages() +}) + +test_that("works with POSIX (two-class) columns present", { + y <- x + y$a <- factor(y$a, c("a little", "some", "a lot")) + expect_equal(tibble::as_tibble(y), factorize_df(x, c("a little", "some", "a lot"))) +}) + +test_that("warning message if no matches found", { + expect_warning(factorize_df(x, c("bugs", "birds")), + "No columns matched.", + fixed = TRUE + ) +}) + +test_that("appropriate message prints if matched but already factor", { + aa <- suppressMessages(factorize_df(x, 4:1)) + ab <- aa + ab$d <- 1:4 + + factorize_df(aa, 4:1) |> + suppressMessages() |> + expect_warning("matching column was already a factor") |> + expect_warning("No new columns matched.") # Includes "new " in message + + # the unusual case where there's a match on a non-factor and an already-present factor match + factorize_df(ab, 4:1) |> + expect_warning("matching column was already a factor") |> + expect_message("Changed the following columns to factors:") +}) diff --git a/tests/testthat/test-show-in-excel.R b/tests/testthat/test-show-in-excel.R index 20feab9..139597f 100644 --- a/tests/testthat/test-show-in-excel.R +++ b/tests/testthat/test-show-in-excel.R @@ -1,4 +1,2 @@ -# Tests for date-to-school year function -context("show_in_excel") diff --git a/tests/testthat/test-survey-utils.R b/tests/testthat/test-survey-utils.R index 8f9d81f..c3edd3c 100644 --- a/tests/testthat/test-survey-utils.R +++ b/tests/testthat/test-survey-utils.R @@ -4,7 +4,6 @@ library(testthat) library(janitor) library(labelled) library(dplyr) -context("survey utilities") x <- data.frame( # 4th person didn't respond at all @@ -165,8 +164,10 @@ test_that("bad inputs error or warn appropriately", { "input vectors should only have values of 0, 1, and NA; run check_all_recode() before calling this function", fixed = TRUE ) - expect_warning(mtcars %>% check_all_recode(cyl:carb), - "column 1 has multiple values besides NA; not sure which is the question text. Guessing this an \"Other (please specify)\" column.", - fixed = TRUE - ) + mtcars %>% + check_all_recode(cyl:disp) |> + expect_warning("column 1 has multiple values besides NA; not sure which is the question text. Guessing this an \"Other (please specify)\" column.", + fixed = TRUE) |> + expect_warning("column 2 has multiple values besides NA; not sure which is the question text. Guessing this an \"Other (please specify)\" column.", + fixed = TRUE) }) diff --git a/tests/testthat/test-theme_tntp.R b/tests/testthat/test-theme_tntp.R new file mode 100644 index 0000000..271bb2c --- /dev/null +++ b/tests/testthat/test-theme_tntp.R @@ -0,0 +1,4 @@ +test_that("theme_tntp is a theme", { + expect_s3_class(theme_tntp(), "theme") |> + expect_warning("deprecated") +}) diff --git a/tests/testthat/test-theme_tntp_2018.R b/tests/testthat/test-theme_tntp_2018.R new file mode 100644 index 0000000..5f31e72 --- /dev/null +++ b/tests/testthat/test-theme_tntp_2018.R @@ -0,0 +1,4 @@ +test_that("theme_tntp_2018 is a theme", { + expect_s3_class(theme_tntp_2018(), "theme") |> + expect_warning("deprecated") +}) diff --git a/tests/testthat/test-tntp_colors.R b/tests/testthat/test-tntp_colors.R new file mode 100644 index 0000000..c5645d2 --- /dev/null +++ b/tests/testthat/test-tntp_colors.R @@ -0,0 +1,51 @@ +test_that("tntp_colors returns duplicated colors", { + expect_equal(tntp_colors("navy", "navy"), c(tntp_colors("navy"), tntp_colors("navy"))) +}) + +test_that("tntp_colors returns colors in the correct order", { + expect_equal(tntp_colors("navy", "mint"), rev(tntp_colors("mint", "navy"))) +}) + +test_that("tntp_colors and tntp_palette return an unnamed vector when run with arguments", { + expect_equal(tntp_colors("navy"), tntp_colors("navy") |> unname()) + expect_equal(tntp_colors("navy", "mint"), tntp_colors("navy", "mint") |> unname()) + expect_equal(tntp_palette("likert_4"), tntp_palette("likert_4") |> unname()) +}) + +test_that("tntp_colors returns named vector when run empty", { + expect_equal(length(names(tntp_colors())), length(tntp_colors())) +}) + +test_that("tntp_colors returns no duplicates when run empty", { + expect_equal(unname(tntp_colors()), unique(tntp_colors())) +}) + +test_that("tntp_colors and tntp_palette raise an error for unmatched colors or palettes", { + expect_error(tntp_colors("notacolor"), "No match") + expect_error(show_tntp_colors("notacolor"), "No match") + expect_error(tntp_palette("notapalette"), "No TNTP palette found") + expect_error(show_tntp_palette("notapalette"), "No match") +}) + +test_that("choose_text_color works as expected for very light and dark colors", { + expect_equal(choose_text_color("#111111"), "white") + expect_equal(choose_text_color("#EEEEEE"), "black") +}) + +test_that("is_color recognizes common words and hex values", { + expect_equal(is_color("blue"), TRUE) + expect_equal(is_color("#FFFFFF"), TRUE) + expect_equal(is_color("notacolor"), FALSE) + expect_equal(is_color("#BAD10"), FALSE) +}) + +test_that("tntp_palette reverse works as expected", { + expect_equal(rev(tntp_palette()), tntp_palette(reverse = TRUE)) +}) + +test_that("show_tntp_colors and show_tntp_palette parameter validation is working", { + expect_warning(show_tntp_colors(labels = "yes"), "Invalid") + expect_warning(show_tntp_colors(borders = "notacolor"), "Invalid") + expect_error(show_tntp_palette(pattern = FALSE), "No palettes") + expect_error(show_tntp_colors(pattern = FALSE), "No colors") +}) diff --git a/tests/testthat/test-tntp_cred.R b/tests/testthat/test-tntp_cred.R new file mode 100644 index 0000000..445c4c5 --- /dev/null +++ b/tests/testthat/test-tntp_cred.R @@ -0,0 +1,14 @@ +test_that("Credentials can be retrieved with tntp_cred()", { + cred <- "tntp_cred TEST CREDENTIAL" + pw <- "abc" + + # set programmatically + keyring::key_set_with_value(cred, password = pw) + + # Test that pulling works + expect_equal(tntp_cred(cred), pw) + + # Remove test key + keyring::key_delete(cred) + +}) diff --git a/tests/testthat/test-tntp_style.R b/tests/testthat/test-tntp_style.R new file mode 100644 index 0000000..ba94c2d --- /dev/null +++ b/tests/testthat/test-tntp_style.R @@ -0,0 +1,39 @@ + + +test_that("get_usable_family returns a usable family", { + expect_equal(get_usable_family('serif'), 'serif') + expect_equal(suppressWarnings(get_usable_family('notafamily')), 'sans') +}) + +test_that("get_usable_family errors and warnings work as expected", { + expect_error(get_usable_family('notafamily', default_family = 'alsonotafamily'), "not registered") + expect_error(get_usable_family('notafamily', default_family = 'alsonotafamily', silent = TRUE), "not registered") + expect_warning(get_usable_family('notafamily'), "not registered") + expect_no_warning(get_usable_family('notafamily', silent = TRUE)) +}) + +test_that("get_usable_family default_family works as expected", { + expect_equal(suppressWarnings(get_usable_family('notafamily', default_family = 'serif')), 'serif') +}) + + +test_that("tntp_style parameter validation is working", { + expect_warning(tntp_style(base_size = 5), "not recommended") + + expect_error(tntp_style(base_size = FALSE), "Invalid") +}) + +test_that("tntp_style font validation works", { + thm <- suppressWarnings(tntp_style(family = "serif")) + families <- unique(c(thm$axis.text$family, + thm$legend.text$family, + thm$plot.title$family, + thm$plot.subtitle$family, + thm$plot.caption$family, + thm$strip.text$family)) + expect_equal(families, "serif") +}) + +test_that("tntp_style is a theme", { + expect_s3_class(tntp_style(), "theme") +}) diff --git a/vignettes/visualization-cookbook.Rmd b/vignettes/visualization-cookbook.Rmd index 5990c81..d8b54d4 100644 --- a/vignettes/visualization-cookbook.Rmd +++ b/vignettes/visualization-cookbook.Rmd @@ -92,7 +92,7 @@ The `family` parameter lets you set the text font family. This changes the font You will need to manually import additional fonts, including the Halyard fonts, using the `extrafont` package before they are available to R. Follow these steps to import fonts: -1. Download the Halyard Display Fonts in .ttf forms from the [Data Analytics Sharepoint](https://tntp.sharepoint.com/sites/DataAnalytics/Shared%20Documents/Forms/AllItems.aspx?viewid=ed2700f4%2D6b5b%2D4d23%2Da5c5%2D5567e8a5ccce) under the "Fonts" category. +1. Download the Halyard Display Fonts in .ttf forms from the [Data Analytics Sharepoint](https://tntp.sharepoint.com/sites/DataAnalytics/Shared%20Documents/Forms/AllItems.aspx) under the "Fonts" category. 2. Open the fonts folder on your laptop (Settings -> Personalization -> Fonts) and drag and drop the Halyard Fonts there to install them on your computer. 3. In RStudio, install the `extrafont` package with `install.packages('extrafont)`. 4. Import fonts into the extrafont database with `extrafont::font_import()`. This only needs to be done once. The process is long, and can be significantly shortened by only importing the Halyard fonts using `extrafont::font_import(pattern = 'Halyard')`.