jared
2f1cdcde52
R-CMD-check / R CMD check (pull_request) Failing after 4m43s
- #5: Unwrap _brand.yml for Quarto 1.9+ compatibility (remove top-level brand: wrapper so meta/logo/color/typography are at the top level) - #1: Add quiet parameter to na_sum() to suppress warnings in loops/pipelines - #3: Add beep() function for CLI beep, desktop notifications, and webhook alerts (supports type=beep|notify|webhook|all)
468 lines
13 KiB
R
468 lines
13 KiB
R
#' Safe maximum
|
|
#' Take the max but ignore missing values
|
|
#'
|
|
#' @param x a numeric vector which may contain NA values
|
|
#'
|
|
#' @return the maximum non-missing value
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' safe_max(1:10)
|
|
#' safe_max(c(1:10, NA))# 10
|
|
safe_max <- function(x) {
|
|
if (all(is.na(x))) {
|
|
return(NA)
|
|
} else {
|
|
max(x, na.rm = TRUE)
|
|
}
|
|
}
|
|
|
|
#' Prettify proportion data
|
|
#' Make data expresed as proportions print out as prettily formatted characters with percentages
|
|
#'
|
|
#' @param x a numeric vector of proportions to convert to percentages
|
|
#' @param ndigit a vector of length 1 indicating the number of digits to display in the percent, by
|
|
#' default it represents the digits after the decimal point in the percentage form
|
|
#'
|
|
#' @return a character vector with a % attached
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' pretty_per(0.2, ndigit = 1)
|
|
#' pretty_per(c(0.2, 0.332423, 0.4, 0.342342), ndigit = 2)
|
|
pretty_per <- function(x, ndigit = 1) {
|
|
if (any(x >= 100) & !all(is.na(x))) {
|
|
message("Values over 100 found, did you mean to use proportions?")
|
|
}
|
|
x <- format(round(x, digits = ndigit + 2) * 100, nsmall = ndigit)
|
|
x <- paste0(x, "%")
|
|
x[x == "NA%"] <- " - "
|
|
x <- trimws(x)
|
|
return(x)
|
|
}
|
|
|
|
|
|
#' Zero out missing values
|
|
#'
|
|
#' @param x a numeric vector with missing values
|
|
#'
|
|
#' @return a numeric vector with missing values replaced by 0
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' na_zero(1:10)
|
|
#' na_zero(c(NA, NA, 2:10))
|
|
na_zero <- function(x) {
|
|
x[is.na(x)] <- 0
|
|
return(x)
|
|
}
|
|
|
|
|
|
#' Prettify count data
|
|
#' Make integers propertly formatted as strings which include commas suitable for printing
|
|
#' @param x a numeric vector
|
|
#'
|
|
#' @return a character vector with commas introduced in place positions in the numbers
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' pretty_count(10)
|
|
#' pretty_count(1000)
|
|
#' pretty_count(1e8)
|
|
pretty_count <- function(x) {
|
|
x <- prettyNum(x, big.mark = ",")
|
|
return(x)
|
|
}
|
|
|
|
|
|
|
|
#' Unsuppress data using sampling
|
|
#'
|
|
#' @param x a vector
|
|
#' @param replace_char the character you want to replace in the vector
|
|
#' @param zeros the number of zeroes to oversample when replacing replace_char
|
|
#' @param max_value the numeric maximum value the replacement for the "*" can be
|
|
#' @return a numeric vector with no characters representing suppressed values
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' suppr_data <- c("2", "8", "*", "*", "7", "9", "100")
|
|
#' star_subs(suppr_data, zeros = 1, max_value = 10)
|
|
#' star_subs(suppr_data, zeros = 1, max_value = 200)
|
|
star_subs <- function(x, replace_char = "*",
|
|
zeros = 15, max_value = 20) {
|
|
x[x == "*"] <- sample(c(rep("0", zeros), as.character(0:max_value)),
|
|
sum(x==replace_char), replace = TRUE)
|
|
x <- as.numeric(x)
|
|
return(x)
|
|
}
|
|
|
|
|
|
|
|
#' Recode grade level from character to numeric
|
|
#'
|
|
#' @param x character description of grade levels from NCES style data
|
|
#'
|
|
#' @return a numeric vector
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' grade_level_to_num(c("KG", "Pre-K", "12", "10", "09"))
|
|
grade_level_to_num <- function(x) {
|
|
# Cannot generate new levels if it is a factor so we coerce to character first
|
|
x <- as.character(x)
|
|
x[x %in% c("KG", "Kindergarten")] <- "0"
|
|
x[x %in% c("Pre-K", "Pre-k", "Preschool", "Pre-Kindergarten")] <- "-1"
|
|
x[x %in% c("Adult", "Adult Education")] <- "13"
|
|
y <- as.numeric(x)
|
|
return(y)
|
|
}
|
|
|
|
|
|
#' Recode NCES race categories to shorter names
|
|
#'
|
|
#' @param x a character vector with NCES race codes, often from Urban Institute
|
|
#'
|
|
#' @return recoded race categories following NCES race codes
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' race_short_names(c("Black", "Hispanic Or Latino", "Two Or More Races"))
|
|
race_short_names <- function(x) {
|
|
x <- as.character(x)
|
|
x[x %in% c("Black", "Black Or African American", "Black or African American",
|
|
"African American")] <- "black"
|
|
x[x %in% c("Hispanic", "Hispanic Or Latino", "Hispanic or Latino")] <-
|
|
"hisp_lat"
|
|
x[x %in% c("White", "white", "White and Not Hispanic")] <- "white"
|
|
x[x %in% c("Asian", "Asian American")] <- "asian"
|
|
x[x %in% c("Two Or More Races", "Two or More Races")] <- "two_or_more"
|
|
x[x %in% c("Native Hawaiian Or Other Pacific Islander",
|
|
"Native Hawaiian or Other Pacific Islander",
|
|
"Native Hawaiian Pacific Islander")] <- "native_haw"
|
|
x[x %in% c("American Indian", "American Indian Or Alaska Native",
|
|
"American Indian or Alaska Native", "American Indian or Native Alaskan")] <- "amind"
|
|
x[x %in% c("Not Reported")] <- "other"
|
|
return(x)
|
|
}
|
|
|
|
#' Sum a numeric that contains missing values and ignore missing values
|
|
#'
|
|
#' @param x a numeric vector
|
|
#' @param quiet Logical. If `TRUE` (default `FALSE`), suppress the warning
|
|
#' message. Useful when calling `na_sum()` inside a loop or `dplyr` pipeline
|
|
#' where the message would be emitted repeatedly.
|
|
#'
|
|
#' @return the sum, ignoring any missing values
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' x <- c(2, NA, 4, 9)
|
|
#' na_sum(x) # 15
|
|
#' na_sum(x, quiet = TRUE) # 15 (no message)
|
|
na_sum <- function(x, quiet = FALSE) {
|
|
stopifnot(is.numeric(x))
|
|
if (!quiet) {
|
|
message("Taking a sum with missing values equal to 0, be careful!")
|
|
}
|
|
x <- na_zero(x)
|
|
return(sum(x))
|
|
}
|
|
|
|
# This function looks up the appropriate postal code for states from the
|
|
# state name.
|
|
# It also substitutes in PR and DC for Puerto Rico and District of Columbia
|
|
# which are not included in the lookup table of states and state abbreviations
|
|
# that comes with R.
|
|
#' Title
|
|
#'
|
|
#' @param x a vector of state names
|
|
#' @return state abbreviations matching state naems provided in X
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' postcode_lookup("Montana")
|
|
postcode_lookup <- function(x) {
|
|
modify_name <- c(state.name, "District of Columbia", "Puerto Rico")
|
|
modify_abb <- c(state.abb, "DC", "PR")
|
|
abb <- modify_abb[match(x, modify_name)]
|
|
return(abb)
|
|
}
|
|
|
|
|
|
#' Truncated matching function
|
|
#'
|
|
#' @param x, the character value to match
|
|
#' @param y, a vector of multiple character values to look for a match in
|
|
#' @param n, an integer, how many matches to return
|
|
#' @importFrom stringdist stringsim
|
|
#'
|
|
#' @return an integer giving the position of the table with the most characters
|
|
trunc_match <- function(x, y, n) {
|
|
out <- y[order(stringdist::stringsim(x, y, method = "lv"),
|
|
decreasing = TRUE)]
|
|
if (length(out) < n) {
|
|
n <- length(out)
|
|
}
|
|
out <- out[1:n]
|
|
return(out)
|
|
}
|
|
|
|
|
|
|
|
#' Compute the outersection of two fectors
|
|
#'
|
|
#' @param x first vector, of any type
|
|
#' @param y second vector, same type as x
|
|
#' @param ... additional vectors to be checked
|
|
#'
|
|
#' @return unique values across all of the vectors
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' # desired result is c(1, 2, 3, 6, 9, 10)
|
|
#' outersect(1:5, 4:8, 7:10)
|
|
outersect <- function(x, y, ...) {
|
|
big.vec <- c(x, y, ...)
|
|
duplicates <- big.vec[duplicated(big.vec)]
|
|
setdiff(big.vec, unique(duplicates))
|
|
}
|
|
|
|
# desired result is c(1, 2, 3, 6, 9, 10)
|
|
#outersect(1:5, 4:8, 7:10)
|
|
#[1] 1 2 3 6 9 10
|
|
|
|
|
|
|
|
#' Get the FIPS code for a given state abbreviation
|
|
#'
|
|
#' @param stabbr a two letter abbreviation for a US state
|
|
#'
|
|
#' @return FIPS codes that match the abbreviation
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' get_fips("MT")
|
|
#' get_fips("PR")
|
|
#' }
|
|
get_fips <- function(stabbr) {
|
|
if (!requireNamespace("tidycensus", quietly = TRUE)) {
|
|
stop(
|
|
"Package 'tidycensus' is required for get_fips(). ",
|
|
"Install it with: install.packages('tidycensus')",
|
|
call. = FALSE
|
|
)
|
|
}
|
|
fips <- tidycensus::fips_codes[, 1:2]
|
|
fips <- fips[!duplicated(fips),]
|
|
out <- fips[fips$state == stabbr, 2]
|
|
return(out)
|
|
}
|
|
|
|
#' Get the state abbreviation from a given FIPS Code
|
|
#'
|
|
#' @param fips a character value that captures the FIPS code with leading 0
|
|
#'
|
|
#' @return a character value, length 2, with the state abbreviation
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' \dontrun{
|
|
#' get_stabbr("06")
|
|
#' }
|
|
get_stabbr <- function(fips) {
|
|
if (!requireNamespace("tidycensus", quietly = TRUE)) {
|
|
stop(
|
|
"Package 'tidycensus' is required for get_stabbr(). ",
|
|
"Install it with: install.packages('tidycensus')",
|
|
call. = FALSE
|
|
)
|
|
}
|
|
fips_codes <- tidycensus::fips_codes[, 1:2]
|
|
fips_codes <- fips_codes[!duplicated(fips_codes),]
|
|
if (length(fips) != 1) {
|
|
out <- rep(NA, length(fips))
|
|
for (i in length(fips)) {
|
|
out[i] <- fips_codes[fips_codes$state_code == fips, 1]
|
|
|
|
}
|
|
return(out)
|
|
|
|
} else {
|
|
out <- fips_codes[fips_codes$state_code == fips, 1]
|
|
return(out)
|
|
}
|
|
|
|
}
|
|
|
|
|
|
## Let's calculate the z-score for the gap as well
|
|
# Test statistic needs 4 values
|
|
# Proporation A, Numerator A
|
|
# Proportion B, Numerator B
|
|
|
|
#' Calculate a Z-Score for a comparison between two proportions
|
|
#'
|
|
#' @param a_prop the proportion for group a
|
|
#' @param a_count the count of the population in group a
|
|
#' @param b_prop the proportion for group b
|
|
#' @param b_count the count of the population in group b
|
|
#'
|
|
#' @return a numeric z score
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' z_gap_test(0.0002, 1e4, 0.0003, 1e4)
|
|
z_gap_test <- function(a_prop, a_count, b_prop, b_count) {
|
|
num <- (a_prop - b_prop) - 0
|
|
|
|
denom_a <- (a_prop * (1-a_prop)) / a_count
|
|
denom_b <- (b_prop * (1-b_prop)) / b_count
|
|
|
|
denom <- sqrt(denom_a + denom_b)
|
|
|
|
|
|
z = num / denom
|
|
#if (is.nan)
|
|
return(z)
|
|
}
|
|
|
|
|
|
|
|
# TODO: Consider vectorizing
|
|
#z_univariate_v <- Vectorize(z_univariate, SIMPLIFY = TRUE)
|
|
|
|
|
|
#' Add a random jitter to a count variable to mask its true value
|
|
#'
|
|
#' @param x the vector of numerics
|
|
#' @param fac the range of values to add or subtract to perturb the count
|
|
#'
|
|
#' @details The count in the name means that this function enforces a floor of
|
|
#' 0 on values, so values perturbed to have less than 0 will be capped at 0.
|
|
#'
|
|
#' @return a numeric vector
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' perturb_count(20:30, fac = 3)
|
|
perturb_count <- function(x, fac = 3) {
|
|
x <- sapply(x, function(x) x + sample(-fac:fac, 1))
|
|
x[x < 0] <- 0
|
|
return(x)
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
#' Add random noise to a variable before rounding
|
|
#'
|
|
#' @param x a numeric we want to round
|
|
#'
|
|
#' @return rounded values
|
|
#' @export
|
|
#' @details Credit to Jens von Bergmann for this algo https://github.com/mountainMath/dotdensity/blob/master/R/dot-density.R
|
|
#' @importFrom stats runif
|
|
#'
|
|
#' @examples
|
|
#' random_round(1.93)
|
|
random_round <- function(x) {
|
|
v = as.integer(x)
|
|
r = x-v
|
|
test = runif(length(r), 0.0, 1.0)
|
|
add = rep(as.integer(0),length(r))
|
|
add[r>test] <- as.integer(1)
|
|
value = v + add
|
|
ifelse(is.na(value) | value<0, 0, value)
|
|
return(value)
|
|
}
|
|
|
|
|
|
#' Safely take a ratio and do not fail if 0 is in the denominator
|
|
#'
|
|
#' @param num numerator, a numeric
|
|
#' @param denom denominator, a numeric
|
|
#'
|
|
#' @return The proportion, safely calculated with 0.1 substituting for 0
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' safe_ratio(100, 1)
|
|
#' safe_ratio(100, 0)
|
|
safe_ratio <- function(num, denom) {
|
|
denom <- ifelse(denom == 0, 0.1, denom)
|
|
y <- num / denom
|
|
return(y)
|
|
}
|
|
|
|
|
|
|
|
#' Take the maximum of a number after trimming values
|
|
#'
|
|
#' @param vec a numeric vector
|
|
#' @param n integer, the number of maximum values to trim before taking the maximum
|
|
#'
|
|
#' @return the highest value after removing the highest n values
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' trim_max(c(10, 10, 10, 9, 8, 7), n = 2)
|
|
#' trim_max(c(10, 10, 10, 9, 8, 7), n = 3)
|
|
#' trim_max(c(10, 10, 10, 9, 8, 7), n = 4)
|
|
trim_max <- function(vec, n) {
|
|
# Sort vector ascending
|
|
sorted_vec <- sort(vec)
|
|
end_point <- length(vec) - n
|
|
if (end_point <= 0) {
|
|
return(1)
|
|
}
|
|
# Exclude n largest (most extreme) values
|
|
filtered_vec <- sorted_vec[(1:(length(vec)-n))]
|
|
# Find the maximum value among excluded values if any exist
|
|
max_value <- max(filtered_vec, na.rm = TRUE)
|
|
return(max_value)
|
|
}
|
|
|
|
|
|
#' Round values to the nearest 0.5
|
|
#'
|
|
#' @param x a numeric vector to round
|
|
#'
|
|
#' @return a numeric vector with all elements rounded to 0, 0.5, or 1
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' round_to_nearest_half(0.9)
|
|
#' round_to_nearest_half(0.7)
|
|
#' round_to_nearest_half(0.4)
|
|
round_to_nearest_half <- function(x) {
|
|
if (x %% 1 == 0) { # If x is already an integer, no change needed
|
|
return(as.integer(x))
|
|
} else {
|
|
decimal_part <- x - floor(x)
|
|
if (decimal_part >= 0.25 & decimal_part < 0.75) {
|
|
rounded_x <- floor(x) + 0.5
|
|
} else {
|
|
rounded_x <- round(x, 0)
|
|
}
|
|
return(rounded_x)
|
|
}
|
|
}
|
|
|
|
|
|
#' Round values to the nearest 0.5
|
|
#'
|
|
#' @inheritParams round_to_nearest_half
|
|
#'
|
|
#' @return a numeric vector with all elements rounded to 0, 0.5, or 1
|
|
#' @export
|
|
#'
|
|
#' @examples
|
|
#' rnh(c(0.2, 0.3, 0.4, 0.8, 0.09, 0.9))
|
|
rnh <- function(x) {
|
|
tmp <- Vectorize(round_to_nearest_half)
|
|
tmp(x)
|
|
}
|