add additional functions

R/utils.R

@@ -163,3 +163,232 @@ na_sum <- function(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.
+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
+#'
+#' @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
+#' @importFrom tidycensus fips_codes
+#'
+#' @examples
+#' get_fips("MT")
+#' get_fips("PR")
+#' get_fips("CC")
+get_fips <- function(stabbr) {
+  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
+#' @importFrom tidycensus fips_codes
+#'
+#' @examples
+#' get_stabbr("06")
+get_stabbr <- function(fips) {
+  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 making a vectorized version
+# z_gap_test_v <- Vectorize(z_gap_test,
+#                           SIMPLIFY = TRUE)# we only want to return a scalar
+
+
+#z_gap_test(a_prop = 0.051, a_count = 2000, b_prop = 0.11, b_count = 100)
+
+
+#' Calculate a univariate z score by comparing to a population
+#'
+#' @param unit_prop proportion for the group we are comparing
+#' @param global_prop the global proportion
+#' @param unit_denom the population size for the group we are comparing
+#'
+#' @return a z-score
+#' @export
+#'
+#' @examples
+#' z_univariate(unit_prop = 0.13, global_prop = 0.11, unit_denom = 2500)
+z_univariate <- function(unit_prop, global_prop, unit_denom) {
+  num <- unit_prop - global_prop
+  denom <- sqrt(
+    (global_prop * (1-global_prop))/unit_denom
+  )
+  z = num / denom
+  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
+#' @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
+#'
+#' @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)
+}