R/utils.R

In HunterRatliff1/hcup: Implementation of HCUP Software Tools in R

#' @importFrom rlang .data
#' @keywords internal
`%||%` <- function(x, y) if (is.null(x)) y else x
# https://design.tidyverse.org/def-short.html



#' Check that the ICD codes are in the correct format
#'
#' Internal function to warn users if their ICD codes aren't in the
#' right format (i.e. have decimals, not character)
#'
#' @param icd_codes Vector of ICD codes that should NOT have decimals
#' @keywords internal
check_icd_format <- function(icd_codes){
  # formerly known as `warn_decimals`

  # labellise the function argument `icd_codes`
  labellised <- rlang::expr_label(base::substitute(icd_codes))

  # Check conditions
  has_decimals <- any(grepl(pattern = "\\.", x = icd_codes))
  is_vct       <- rlang::is_vector(icd_codes)
  is_char      <- rlang::is_character(icd_codes)
  is_fct       <- rlang::inherits_any(icd_codes, "factor")

  # If not a vector, fail
  if(!is_vct){
    msg <- glue::glue("{labellised} is not a vector, it's a {class(icd_codes)}")
    rlang::abort(msg)
  }

  # If not char or factor, fail
  if(!is_char & !is_fct){
    msg <- glue::glue("{labellised} is not a character vector, it's a {class(icd_codes)}")
    rlang::abort(msg)
  }

  # If is a factor, warn & coerce to character
  if(is_fct){
    msg <- glue::glue("{labellised} is a factor, coercing to character")
    rlang::warn(msg)
    icd_codes <- as.character(icd_codes)
  }

  # If has decimals, warn & regex them out
  if(has_decimals){
    rlang::warn("ICD codes should not be in decimal format")
    msg <- glue::glue("Will attempt to coerce decimals to short format, but ",
                      "you may want to use `icd::decimal_to_short()` to do this")
    rlang::inform(msg, .frequency = "regularly", .frequency_id="decimals")
    icd_codes <- purrr::map_chr(icd_codes, stringr::str_remove_all, "\\.")
  }
  icd_codes
}


#' Provide a message if heuristic is used
#'
#' @param var_name Variable that was not supplied
#' @param default The default value to be used
#' @keywords internal
heuristic_msg <- function(var_name, default){
  # message("No default value provided for `", var_name, "`. Using ")
  rlang::inform(message = stringr::str_glue("No value provided for `{var_name}`. Using `{var_name} = {default}` as the default"))
  rlang::inform(message = stringr::str_glue("You can specify `{var_name} = {default}` to silence this alert"),
                .frequency="regularly", .frequency_id=var_name)
  default
}


#' Random sample of ICD codes
#'
#' Generates a vector of random ICD codes
#'
#' @param code_type Type and version of ICD code to use. Must be one of:
#'   `dx9`, `dx10`, `pr9`, or `pr10`.
#' @param n Number of codes to return. Defaults to 5.
#' @param seed Optional seed to use (via `set.seed`) for reproducibility.
#'  Defaults to `NULL`, unless an integer is provided
#'
#' @return A character vector of ICD codes
#' @keywords internal
#' @export
#'
#' @examples
#' get_sample_codes("dx10")
#' get_sample_codes("dx9", n=2)
#' get_sample_codes("pr10", n=1, seed=0) # should be "047A36Z"
get_sample_codes <- function(code_type, n=5, seed=NULL){
  code_type <- rlang::arg_match(code_type, c("dx9", "dx10", "pr9", "pr10"))

  # All of the codes used in this package
  code_set <- hcup.data::valid_codes

  # Wrapper function to sample codes
  get_codes_wrapper <- function(df, n, seed){
    if(is.null(seed)) {
      sample(df, size = n, replace = TRUE)
    }
    else(withr::with_seed(
      seed = seed,
      code = sample(df, size = n, replace = TRUE))
    )
  }

  dplyr::case_when(
    code_type=="dx9"  ~ get_codes_wrapper(code_set$dx9, n, seed),
    code_type=="pr9"  ~ get_codes_wrapper(code_set$pr9, n, seed),
    code_type=="dx10" ~ get_codes_wrapper(code_set$dx10, n, seed),
    code_type=="pr10" ~ get_codes_wrapper(code_set$pr10, n, seed),
  )
}

# get_sample_codes <- function(code_type, n=5, seed=NULL){
#   code_type <- rlang::arg_match(code_type, c("dx9", "dx10", "pr9", "pr10"))
#
#   # get_codes_wrapper <- function(df, n){
#   #   sample(df, size = n, replace = TRUE)
#   # }
#   #
#   #
#   # if(!is.integer(seed)){
#   #
#   # }
#
#   # If provided seed, set seed
#   set.seed(seed)
#   # withr::with_seed()
#
#   if(code_type=="dx9"){
#     codes <- sample(hcup.data::CCS_dx9_map[["I9_DX"]], size = n, replace = TRUE)
#     return(codes)
#   }
#   if(code_type=="pr9"){
#     codes <- sample(hcup.data::CCS_pr9_map[["I9_PR"]], size = n, replace = TRUE)
#     return(codes)
#   }
#   if(code_type=="dx10"){
#     codes <- sample(hcup.data::CCSR_DX_mapping[["I10_DX"]], size = n, replace = TRUE)
#     return(codes)
#   }
#   if(code_type=="pr10"){
#     codes <- sample(hcup.data::CCSR_PR_mapping[["I10_PR"]], size = n, replace = TRUE)
#     return(codes)
#   }
# }



check_icd_valid <- function(icd_codes, versions=NULL){

  # Set of valid codes
  code_set <- hcup.data::valid_codes

  dplyr::tibble(icd_codes = icd_codes) %>%
    dplyr::mutate(dx9 = icd_codes %in% code_set$dx9,
                  pr9 = icd_codes %in% code_set$pr9,
                  dx10 = icd_codes %in% code_set$dx10,
                  pr10 = icd_codes %in% code_set$pr10) %>%
    dplyr::rowwise() %>%
    dplyr::mutate(any = any(dplyr::c_across(-icd_codes)),
                  multi = sum(dplyr::c_across(dx9:pr10))) %>%
    dplyr::ungroup() %>%
    dplyr::mutate(dplyr::across(dx9:pr10, as.numeric))



}

if(FALSE) {
  load_all()
  c("dx9", "dx10", "pr9", "pr10") %>%
    # purrr::map(get_sample_codes, n=2, seed=0) %>%
    purrr::map(get_sample_codes, n=10, seed=0) %>%
    purrr::flatten_chr() %>%
    c("bad", .) %>%
    check_icd_valid()
}