transfer from old repo

R/functions.R

@@ -0,0 +1,279 @@
+ready_clin <- function(data) {
+  data |>
+    correct_na() |>
+    dplyr::mutate(
+      reg_smoker = dplyr::case_match(
+        reg_rygning, "1" ~ TRUE,
+        c("2", "3", "4") ~ FALSE,
+        "9" ~ NA
+      ),
+      reg_cohabiting = dplyr::case_match(
+        reg_civil, "1" ~ TRUE,
+        c("2", "3") ~ FALSE,
+        "9" ~ NA
+      ),
+      # Living alone defined as not together with somebody
+      reg_alone = dplyr::case_match(
+        reg_civil, "1" ~ FALSE,
+        c("2", "3") ~ TRUE,
+        "9" ~ NA
+      ),
+      reg_more_alc = dplyr::case_match(
+        reg_alkohol, "1" ~ FALSE,
+        "2" ~ TRUE,
+        "9" ~ NA
+      ),
+      reg_female = sex == "Kvinde",
+      dplyr::across(
+        .cols = c(
+          "reg_hyperten",
+          "reg_diabetes",
+          "reg_atriefli",
+          "reg_perifer_arteriel",
+          "reg_tidl_tci",
+          "reg_ami"
+        ),
+        ~ dplyr::case_match(
+          .x, "1" ~ TRUE,
+          "2" ~ FALSE,
+          "9" ~ NA
+        )
+      ),
+      dplyr::across(
+        .cols = c(
+          "reg_trombolyse",
+          "reg_trombektomi"
+        ),
+        ~ dplyr::case_match(
+          .x, "1" ~ TRUE,
+          c("3", "4") ~ FALSE,
+          "9" ~ NA
+        )
+      ),
+      reg_any_perf = reg_trombolyse | reg_trombektomi
+    ) |>
+    bmi_calc()
+}
+
+#' Formatting the complete data set
+#'
+#' @param data the merged raw data set
+#'
+#' @return tibble
+#' @examples
+#' ds <- targets::tar_read(df_all_data) |>
+#'   data_formatting() |>
+#'   subset_df("mdi")
+#' ds |> skimr::skim()
+#' ds |> View()
+data_formatting <- function(data) {
+  to_logical <- grep(match_str_grepl(c("missings", "incompletes")), names(data))
+
+  suppressWarnings(
+    data |>
+      correct_na() |>
+      dplyr::mutate(dplyr::across(all_of(to_logical), ~ .x == "TRUE")) |>
+      dplyr::mutate(
+        # This uses the work-corrected score
+        # pase_0 = dplyr::if_else(pase_score_missings_w_0 | is.na(talos_pase10_0), NA, pase_score_sum_w_0),
+        # pase_4 = dplyr::if_else(pase_score_missings_w_4 | is.na(talos_pase10_4), NA, pase_score_sum_w_4),
+        # Below is the plain PASE scor used according to the manual used with TALOS
+        pase_0 = dplyr::if_else(pase_score_missings_0, NA, pase_score_sum_0),
+        pase_4 = dplyr::if_else(pase_score_missings_4, NA, pase_score_sum_4),
+        who_0 = as.numeric(talos_who07_0),
+        who_4 = as.numeric(talos_who07_4),
+        mrs_0 = factor(substr(talos_mrs01_0, 1, 1), ordered = FALSE),
+        mrs_0_above0 = (as.numeric(mrs_0) - 1) > 0,
+        mrs_4 = factor(substr(talos_mrs01_4, 1, 1), ordered = FALSE),
+        mrs_4_above1 = (as.numeric(mrs_4) - 1) > 1,
+        mdi_4 = as.numeric(talos_mdi12_4),
+        mfi_gen_4 = as.numeric(talos_mfi_gen_4),
+        nihss_0 = as.numeric(talos_nihss16_0),
+        # soc_status = dst_SOC_STATUS_KODE.latest,
+        # fam_indk = cut(dst_FAMAEKVIVADISP_13.5.mean,
+        #                breaks = quantile(dst_FAMAEKVIVADISP_13.5.mean, probs = seq(0, 1, 1 / 3), na.rm = TRUE),
+        #                ordered_results = FALSE,
+        #                labels = c("low", "medium", "high"),
+        #                include.lowest = TRUE
+        # ),
+        # fam_indk_bin = cut(dst_FAMAEKVIVADISP_13.5.mean,
+        #                    breaks = quantile(dst_FAMAEKVIVADISP_13.5.mean, probs = seq(0, 1, 1 / 2), na.rm = TRUE),
+        #                    ordered_results = FALSE,
+        #                    labels = c("low", "high"),
+        #                    include.lowest = TRUE
+        # ),
+        # fam_indk_hl=forcats::fct_rev(fam_indk),
+        # fam_indk_high = dplyr::if_else(fam_indk_bin=="high",TRUE,FALSE),
+        # fam_indk_low = dplyr::if_else(fam_indk_bin=="low",TRUE,FALSE),
+        # edu_level = factor(dst_ISCED_lvl, ordered = FALSE, levels = c("low", "medium", "high")),
+        # edu_high = dplyr::if_else(dst_ISCED_bin=="high",TRUE,FALSE),
+        # edu_low = dplyr::if_else(dst_ISCED_lvl=="low",TRUE,FALSE),
+        # edu_level_hl=forcats::fct_rev(edu_level),
+        rtreat_placebo = rtreat == "Placebo"
+      ) #|>
+    # group_soc_status() |>
+    # define_status_time()
+  )
+}
+
+#' Store of variable names for data sub-setting
+#'
+#' @return list
+#' @examples
+#' define_variables()
+define_variables <- function() {
+  list(
+    clin = c(
+      "age",
+      "reg_female",
+      "nihss_0",
+      "reg_trombolyse",
+      "reg_trombektomi",
+      # "rtreat",
+      "rtreat_placebo"
+    ),
+    lifestyle = c(
+      "pase_0",
+      "pase_4",
+      "reg_alone",
+      "reg_bmi",
+      # "reg_hojde",
+      # "reg_vaegt_alt",
+      "reg_smoker",
+      "reg_more_alc",
+      "reg_hyperten",
+      "reg_diabetes",
+      "reg_tidl_tci",
+      "reg_atriefli",
+      "reg_ami",
+      "reg_perifer_arteriel"
+    ),
+    ses = c(
+      # "soc_status",
+      # "soc_status_work",
+      # "soc_status_nowork",
+      # "fam_indk",
+      # "fam_indk_hl",
+      # "fam_indk_high",
+      # "fam_indk_low",
+      # "edu_level",
+      # "edu_high",
+      # "edu_low",
+      # "edu_level_hl"
+    ),
+    assess.events = c(
+      "who_4",
+      "mdi_4",
+      "mrs_4_above1",
+      "mfi_gen_4",
+      "time",
+      "status",
+      "event.include"
+    ),
+    assess.pred = c(
+      "who_0",
+      "mrs_0_above0"
+    ),
+    extra = c(
+      "soc_status",
+      "pase_0",
+      "pase_4"
+    )
+  )
+}
+
+
+#' Wrapper to print summary table with extended info
+#'
+#' @param data formatted and subset data set
+#' @param by.var stratify by
+#'
+#' @return
+#' @examples
+print_table_summary <- function(data, by.var = "pase_change", adds = TRUE, missing="ifany") {
+  out <- data |>
+    pragmatic_imputation(vec=c("reg_trombolyse", "reg_trombektomi","reg_any_perf")) |> 
+    # pase_cutter(drop.pase = TRUE) |>
+    gtsummary::tbl_summary(
+      missing = missing,
+      by = tidyselect::all_of(by.var) # ,
+      # value = list(where(is.logical) ~ TRUE),
+      # type = list(gtsummary::all_continuous() ~ "continuous2"),
+      # statistic = list(gtsummary::all_continuous() ~ c(
+      #   # "{N_nonmiss} ({p_nonmiss}%)",
+      #   "{median} ({p25}, {p75})",
+      #   # "{min}, {max}",
+      #   "{mean} ({sd})"#,
+      #   # "{N_miss} ({p_miss}%)"
+      # )#,
+      # # gtsummary::all_categorical() ~ c(
+      # #   "{N_obs} ({p_nonmiss}%)"#,
+      # #   # "{N_miss} ({p_miss})"
+      # # )
+      # )
+    ) #|>
+    # gtsummary::add_n()
+
+  if (adds) {
+    out |>
+      gtsummary::add_overall() #|>
+    # gtsummary::add_p()
+  } else {
+    out
+  }
+}
+
+#' Title
+#'
+#' @param data
+#'
+#' @return
+#' @export
+#'
+#' @examples
+#' targets::tar_read(df_all_data_formatted) |> View()
+#' targets::tar_read(df_pred_data) |>
+#'   dplyr::transmute(stRoke::quantile_cut(pase_0, 4, group.names = 1:4), soc_status_work, fam_indk, edu_level) |>
+#'   summary_tblone()
+summary_tblone <- function(data, by = names(data)[1], adds = FALSE, missing="ifany") {
+  # data <- targets::tar_read(df_pred_data)
+  data |>
+    labelling_data() |>
+    # prediction_ready() |>
+    # dplyr::select(-reg_bmi) |>
+    # pase_cutter(drop.pase = TRUE) |>
+    # dplyr::filter(!is.na(pase_change)) |>
+    # dplyr::mutate(pase_change=forcats::fct_rev(pase_change)) |>
+    print_table_summary(by.var = by, adds = adds, missing=missing)
+}
+
+#' Creating a truthful stratified table for predictions
+#'
+#' @param data data frame
+#'
+#' @return list
+#' @export
+#'
+#' @examples
+#' targets::tar_read(df_pred_data) |> true_pred_sum_plot()
+#' data <- pred_data
+true_pred_sum_plot <- function(data,by="pase_change") {
+  true_sum <- data |>
+    pase_cutter(drop.pase = TRUE) |>
+    dplyr::mutate(pase_change = forcats::fct_rev(pase_change))
+    
+
+  list( # true_sum,
+    true_sum |>
+      (function(.x) {
+        split(.x, .x$pase_change %in% c("Persistently low", "Increase"))
+      })() |>
+      purrr::map(function(.y) {
+        .y |> dplyr::mutate(pase_change = factor(pase_change))
+      })
+  ) |>
+    purrr::list_flatten() |>
+    purrr::map(summary_tblone, by = by) |>
+    purrr::map(micRo::mask_micro_summary) |>
+    gtsummary::tbl_merge()
+}