tests/testthat/helper.R

In healthdb: Working with Healthcare Databases

letters_n <- function(nrows = 25, type = "data.frame", id = 1:50) {
  n_any <- nrows %/% 2
  n_all <- n_any %/% 3
  make_test_dat(vals_kept = letters, nrows = nrows, n_any = n_any, n_all = n_all, answer_id = "ans", type = type, IDs = id)
}

xnum_n <- function(x, nrows = 25, type = "data.frame") {
  n_any <- nrows %/% 2
  n_all <- n_any %/% 3
  make_test_dat(vals_kept = paste0(x, 1:9), nrows = nrows, n_any = n_any, n_all = n_all, answer_id = "ans", type = type)
}

btw_n <- function(date_range, n_ans = 5, type = "data.frame") {
  keep <- make_test_dat(vals_kept = letters, nrows = n_ans, n_any = n_ans, n_all = n_ans, answer_id = "ans", date_range = date_range)
  out <- letters_n()
  all <- dplyr::bind_rows(keep, out)

  if (type == "database") {
    all <- memdb_tbl(all)
  }
  return(all)
}

iclnt_jdates <- function(i, j, dup, date_range = c(as.Date("2015-01-01"), as.Date("2021-01-31")), type = "data.frame") {
  dat <- purrr::map2(i, j, ~ tidyr::expand_grid(clnt_id = .x, dates = seq(date_range[1], date_range[2], length.out = .y)))
  dat <- append(dat, purrr::map2(i, dup, ~ dplyr::tibble(clnt_id = rep(.x, each = .y), dates = date_range[1])))

  test_dat <- purrr::list_rbind(dat)

  if (type == "database") {
    test_dat <- memdb_tbl(test_dat)
  }

  return(test_dat)
}

# internal test function that should be ran on make_test_dat() output
test_apart_within <- function(data, n, apart = 0, within = Inf) {
  data <- data %>%
    dplyr::group_by(.data[["clnt_id"]]) %>%
    dplyr::filter(dplyr::n_distinct(.data[["dates"]]) >= n)

  keep <- data %>%
    dplyr::summarise(met = ifelse(dplyr::n() < n, FALSE,
                                  utils::combn(.data[["dates"]] %>% unique(), n, function(x) all(diff(sort(x)) >= apart) & (diff(c(min(x), max(x))) <= within)) %>% any()))

  keep <- keep %>%
    dplyr::filter(met) %>%
    dplyr::pull(.data[["clnt_id"]])

  return(keep)
}

test_if_dates <- function(x, n, apart = 0, within = Inf, dup.rm = TRUE) {
  if (dup.rm) {
    utils::combn(x %>% unique(), n, function(x) all(diff(sort(x)) >= apart) & (diff(c(min(x), max(x))) <= within)) %>% any()
  } else {
    utils::combn(x, n, function(x) all(diff(sort(x)) >= apart) & (diff(c(min(x), max(x))) <= within)) %>% any()
  }
}

test_comorbidity <- function(n_row = 10, n_col = 31, n_clnt = 3, icd10 = TRUE) {
  # make answer df
  ans <- sample(0:1, 31, prob = c(0.8, 0.05), replace = TRUE)
  ans <- replicate(n_row, sample(0:1, 31, prob = c(0.8, 0.05), replace = TRUE)) %>%
    t() %>%
    as.data.frame()
  colnames(ans) <- c("chf", "arrhy", "vd", "pcd", "pvd", "hptn_nc", "hptn_c", "para", "othnd", "copd", "diab_nc", "diab_c", "hptothy", "rf", "ld", "pud_nb", "hiv", "lymp", "mets", "tumor", "rheum_a", "coag", "obesity", "wl", "fluid", "bla", "da", "alcohol", "drug", "psycho", "dep")

  # make data
  # make code pool and draw from it
  if (icd10) {
    code_list <- list(
      c(
        "I099", "I110", "I130", "I132", "I255", "I420", "I425", "I427", "I428",
        "I429", "I43", "I50", "P290"
      ),
      c(
        "I441", "I442", "I443", "I456", "I459", "I47", "I48", "I49", "R000", "R001",
        "R008", "T821", "Z450", "Z950"
      ),
      c(
        "A520", "I05", "I06", "I07", "I08", "I091", "I098", "I34", "I35", "I36", "I37",
        "I38", "I39", "Q230", "Q231", "Q232", "Q233", "Z952", "Z953", "Z954"
      ),
      c("I26", "I27", "I280", "I288", "I289"),
      c(
        "I70", "I71", "I731", "I738", "I739", "I771", "I790", "I792", "K551", "K558",
        "K559", "Z958", "Z959"
      ),
      c("I10"),
      c("I11", "I12", "I13", "I15"),
      c(
        "G041", "G114", "G801", "G802", "G81", "G82", "G830", "G831", "G832", "G833",
        "G834", "G839"
      ),
      c(
        "G10", "G11", "G12", "G13", "G20", "G21", "G22", "G254", "G255", "G312", "G318",
        "G319", "G32", "G35", "G36", "G37", "G40", "G41", "G931", "G934", "R470", "R56"
      ),
      c(
        "I278", "I279", "J40", "J41", "J42", "J43", "J44", "J45", "J46", "J47", "J60", "J61",
        "J62", "J63", "J64", "J65", "J66", "J67", "J684", "J701", "J703"
      ),
      c(
        "E100", "E101", "E109", "E110", "E111", "E119", "E120", "E121", "E129", "E130",
        "E131", "E139", "E140", "E141", "E149"
      ),
      c(
        "E102", "E103", "E104", "E105", "E106", "E107", "E108", "E112", "E113", "E114", "E115",
        "E116", "E117", "E118", "E122", "E123", "E124", "E125", "E126", "E127", "E128", "E132",
        "E133", "E134", "E135", "E136", "E137", "E138", "E142", "E143", "E144", "E145", "E146",
        "E147", "E148"
      ), #
      c("E00", "E01", "E02", "E03", "E890"),
      c("I120", "I131", "N18", "N19", "N250", "Z490", "Z491", "Z492", "Z940", "Z992"),
      c(
        "B18", "I85", "I864", "I982", "K70", "K711", "K713", "K714", "K715", "K717", "K72", "K73",
        "K74", "K760", "K762", "K763", "K764", "K765", "K766", "K767", "K768", "K769", "Z944"
      ),
      c("K257", "K259", "K267", "K269", "K277", "K279", "K287", "K289"),
      c("B20", "B21", "B22", "B24"),
      c("C81", "C82", "C83", "C84", "C85", "C88", "C96", "C900", "C902"),
      c("C77", "C78", "C79", "C80"),
      c(
        "C00", "C01", "C02", "C03", "C04", "C05", "C06", "C07", "C08", "C09", "C10", "C11", "C12", "C13",
        "C14", "C15", "C16", "C17", "C18", "C19", "C20", "C21", "C22", "C23", "C24", "C25", "C26", "C30",
        "C31", "C32", "C33", "C34", "C37", "C38", "C39", "C40", "C41", "C43", "C45", "C46", "C47", "C48",
        "C49", "C50", "C51", "C52", "C53", "C54", "C55", "C56", "C57", "C58", "C60", "C61", "C62", "C63",
        "C64", "C65", "C66", "C67", "C68", "C69", "C70", "C71", "C72", "C73", "C74", "C75", "C76", "C97"
      ),
      c(
        "L940", "L941", "L943", "M05", "M06", "M08", "M120", "M123", "M30", "M310", "M311", "M312", "M313",
        "M32", "M33", "M34", "M35", "M45", "M461", "M468", "M469"
      ),
      c("D65", "D66", "D67", "D68", "D691", "D693", "D694", "D695", "D696"),
      c("E66"),
      c("E40", "E41", "E42", "E43", "E44", "E45", "E46", "R634", "R64"),
      c("E222", "E86", "E87"), #
      c("D500"),
      c("D508", "D509", "D51", "D52", "D53"),
      c("F10", "E52", "G621", "K292", "K700", "K703", "K709", "T51", "Z502", "Z714", "Z721"),
      c("F11", "F12", "F13", "F14", "F15", "F16", "F18", "F19", "Z715", "Z722"),
      c("F20", "F22", "F23", "F24", "F25", "F28", "F29", "F302", "F312"),
      c("F204", "F313", "F314", "F32", "F33", "F341", "F412", "F432")
    )
  } else {
    code_list <- list(
      c(
        "39891", "40201", "40211", "40291", "40401", "40411", "40491", "4254", "4257", "4258", "4259", "428"
      ),
      c(
        "4260", "42613", "4267", "4269", "42610", "42612", "4270", "4271", "4272", "4273",
        "4274", "4276", "4278", "4279", "7850", "99601", "99604", "V450", "V533"
      ),
      c("0932", "394", "395", "396", "397", "424", "7463", "7464", "7465", "7466", "V422", "V433"),
      c("4150", "4151", "416", "4170", "4178", "4179"),
      c("0930", "4373", "440", "441", "4431", "4432", "4438", "4439", "4471", "5571", "5579", "V434"),
      c("401"),
      c("402", "403", "404", "405"),
      c("3341", "342", "343", "3440", "3441", "3442", "3443", "3444", "3445", "3446", "3449"),
      c(
        "3319", "3320", "3321", "3334", "3335", "33392", "334", "335", "3362", "340", "341",
        "345", "3481", "3483", "7803", "7843"
      ),
      c(
        "4168", "4169", "490", "491", "492", "493", "494", "495", "496", "500", "501", "502",
        "503", "504", "505", "5064", "5081", "5088"
      ),
      c("2500", "2501", "2502", "2503"),
      c("2504", "2505", "2506", "2507", "2508", "2509"), #
      c("2409", "243", "244", "2461", "2468"),
      c(
        "40301", "40311", "40391", "40402", "40412", "40492",
        "585", "586", "5880", "V420", "V451", "V56"
      ),
      c(
        "07022", "07023", "07032", "07033", "07044", "07054", "0706", "0709", "4560", "4561",
        "4562", "570", "571", "5722", "5723", "5724", "5728", "5733", "5734", "5738", "5739", "V427"
      ),
      c("5317", "5319", "5327", "5329", "5337", "5339", "5347", "5349"),
      c("042", "043", "044"),
      c("200", "201", "202", "2030", "2386"),
      c("196", "197", "198", "199"),
      c("140", "141", "142", "143", "144", "145", "146", "147", "148", "149", "150", "151", "152", "153", "154", "155", "156", "157", "158", "159", "160", "161", "162", "163", "164", "165", "166", "167", "168", "169", "170", "171", "172", "174", "175", "176", "177", "178", "179", "180", "181", "182", "183", "184", "185", "186", "187", "188", "189", "190", "191", "192", "193", "194", "195"),
      c(
        "446", "7010", "7100", "7101", "7102", "7103", "7104", "7108", "7109", "7112", "714",
        "7193", "720", "725", "7285", "72889", "72930"
      ),
      c("286", "2871", "2873", "2874", "2875"),
      c("2780"),
      c("260", "261", "262", "263", "7832", "7994"),
      c("2536", "276"),
      c("2800"), #
      c("2801", "2808", "2809", "281"),
      c(
        "2652", "2911", "2912", "2913", "2915", "2918", "2919", "3030", "3039", "3050",
        "3575", "5353", "5710", "5711", "5712", "5713", "980", "V113"
      ),
      c("292", "304", "3052", "3053", "3054", "3055", "3056", "3057", "3058", "3059", "V6542"),
      c("2938", "295", "29604", "29614", "29644", "29654", "297", "298"),
      c("2962", "2963", "2965", "3004", "309", "311")
    )
    # code_list <- list(
    #   c("398", "402", "425", "428"),
    #   c("426", "427"),
    #   c("394", "395", "396", "397", "424", "746"),
    #   c("415", "416", "417"),
    #   c("440", "441", "443", "447", "557"),
    #   c("401"),
    #   c("402", "403", "404", "405"),
    #   c("334", "342", "343", "344"),
    #   c("331", "332", "333", "334", "335", "336", "340", "341", "345", "348"),
    #   c("416", "490", "491", "492", "493", "494", "495", "496", "500", "501", "502", "503", "504", "505"),
    #   c("250"),
    #   c("250"),#
    #   c("240", "243", "244", "246"),
    #   c("403", "585", "586", "588", "V56"),
    #   c("070", "456", "570", "571", "572", "573"),
    #   c("531", "532", "533", "534"),
    #   c("042", "043", "044"),
    #   c("200", "201", "202", "203"),
    #   c("196", "197", "198", "199"),
    #   c("140", "141", "142", "143", "144", "145", "146", "147", "148", "149", "150", "151", "152", "153", "154", "155", "156", "157", "158", "159", "160", "161", "162", "163", "164", "165", "166", "167", "168", "169", "170", "171", "172", "174", "175", "176", "177", "178", "179", "180", "181", "182", "183", "184", "185", "186", "187", "188", "189", "190", "191", "192", "193", "194", "195"),
    #   c("446", "701", "710", "711", "714", "719", "720", "725", "728"),
    #   c("286", "287"),
    #   c("278"),
    #   c("260", "261", "262", "263"),
    #   c("276"),
    #   c("280", "281"),#
    #   c("280", "281"),
    #   c("291", "303", "980"),
    #   c("292", "304", "305"),
    #   c("293", "295", "297", "298"),
    #   c("296", "300", "309", "311")
    # )
  }


  drew_code <- purrr::map(1:n_row, function(x) purrr::map_chr(code_list[ans[x, ] == 1], ~ sample(., 1)))
  fill_code <- purrr::map(drew_code, ~ c(., rep(NA, n_col - length(.))))
  code_df <- purrr::list_c(fill_code) %>%
    matrix(nrow = n_row, ncol = n_col, byrow = TRUE) %>%
    as.data.frame()
  colnames(code_df) <- paste("diagx", 1:n_col, sep = "_")
  code_df <- code_df %>%
    dplyr::mutate(
      uid = 1:n_row,
      clnt_id = sample(1:n_clnt, n_row, replace = TRUE),
      .before = dplyr::everything()
    )

  # add total score after using ans for sampling
  ans <- ans %>%
    dplyr::rowwise() %>%
    dplyr::mutate(total_eci = sum(dplyr::c_across(dplyr::everything()))) %>%
    dplyr::ungroup()

  list(answer = ans, data = code_df)
}