#' 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
#'
#' @return the sum, ignoring any missing values
#' @export
#'
#' @examples
#' x <- c(2, NA, 4, 9)
#' na_sum(x) # 15
na_sum <- function(x) {
  stopifnot(is.numeric(x))
  message("Taking a sum with missing values equal to 0, be careful! \u1F601")
  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
## #' @importFrom datasets state.abb state.name
#' @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
#' @import tidycensus
#' @export
#'
#' @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
#' @import tidycensus
#' @export
#'
#' @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 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)
}