search

swehip / slrplotfun

https://swehip.github.io/slrplotfun/
GNU Affero General Public License v3.0
0 stars 0 forks source link

För in PROM-funktioner för knä från årsrapporten 2021 #22

Closed eribul closed 2 years ago

eribul commented 2 years ago

Från Z:\SHPR\Arsrapport\2021\code\Data management knee.R

Under rubriken "PROM"

# Pre-PROM
knee_preprom <-
  knee_preprom0 %>%
  # AWD har önskat få hantera KOOS-variabler som numeriska.
  # I övrigt föredras klartext
  mutate(across(c(!matches("koos") & where(has_map)), as_factor)) %>%
  mutate(across(where(~inherits(.x, "POSIXt")), ~as.Date(.x, tz = "CET")))

qs::qsave(knee_preprom, here("..", "data", "knee", "knee_preprom.qs"))

# Post-PROM
knee_postprom <-
  knee_postprom0 %>%
  mutate(across(c(!matches("koos") & where(has_map)), as_factor)) %>%
  mutate(across(where(~inherits(.x, "POSIXt")), ~as.Date(.x, tz = "CET")))

qs::qsave(knee_postprom, here("..", "data", "knee", "knee_postprom.qs"))

# Kombinerat PROM-dataset
knee_preprom <- janitor::clean_names(knee_preprom)
knee_postprom <- janitor::clean_names(knee_postprom)
names(knee_preprom)  <- gsub("prepk_", "", names(knee_preprom))
names(knee_postprom) <- gsub("postpk_", "", names(knee_postprom))

# Lägg ihop och ta bara med PROM-variabler och id
knee_prom_wide <-
  bind_rows(
    pre  = knee_preprom,
    post = knee_postprom,
    .id  = "when"
  ) %>%
  # Standardisera namnsättning avseende vad som berör höger/vänster knä
  rename_with(~ gsub("r_old$", "_oldr", .)) %>%
  rename_with(~ gsub("l_old$", "_oldl", .)) %>%
  rename_with(~ gsub("r$", "_r", .)) %>%
  rename_with(~ gsub("l$", "_l", .)) %>%
  rename_with(~ gsub("__", "_", .)) %>%
  # Namn med r och l i slutet som misstas för right/left behöver kodas tillbaka
  rename(
    smoker = smoke_r,
    eq5d3lprofil_old = eq5d3lprofi_old_l
  ) %>%
  select(
    # county är bra men vi lägger i hop med prim-dataoch tar den därifrån
    -subject_id, -status_code, -skar_id, -unit_code, -county,
    -starts_with("event_id"),
    -contains("date"), date,
    -proxy, -contact, -emai_l, -attend
  ) %>%
  relocate(
    SubjectKey = subject_key,
    side, date, when
  ) %>%
  arrange(SubjectKey, side, date)

# En rad per sida. Dvs en rad för de flesta men två rader för bilaterala
knee_prom_long <-
  knee_prom_wide %>%
  pivot_longer(
    matches("_[lr]$"),
    names_to = c(".value", "var_side"),
    names_pattern = "(.*)_([lr])"
  ) %>%
  mutate(var_side = factor(var_side, c("r", "l"), c("Höger", "Vänster"))) %>%
  filter(as.character(side) == as.character(var_side) | side == "Båda") %>%
  select(-side) %>%
  rename(side = var_side) %>%
  mutate(across(starts_with("eq5d_"), as.numeric, .names = "{.col}_num"))

# Länka in mot primärerna
knee_prom <-
  knee_prim %>%
  select(
    SubjectKey, KP_Side, KP_SurgDate, opyear, KP_County, KP_TypeAWD,
    Protestyp, KP_UnitCode
  ) %>%
  inner_join(knee_prom_long, c("SubjectKey", KP_Side = "side")) %>%
  mutate(
    KP_UnitCode = as.character(KP_UnitCode),
    prom_time   = as.numeric(date - KP_SurgDate),
    prom_period = case_when(
      when == "pre"  & between(prom_time, -90, 0)              ~ "pre",
      when == "post" & between(prom_time, 365 - 90, 365 + 180) ~ "post"
    ),
    prom_time_diff_goal =
      abs(if_else(prom_period == "post", prom_time - 365, prom_time)),
    fyllnadsgrad = apply(., 1, function(x) mean(is.na(x))),

    # Olika versioner av EQ-5D-index
    eq5d3l_index_tto = eq5d3l_index_tto_old(eq5d3lprofil_old),
    eq5d5l_index_tto = eq5d5l_index_tto(
      eq5d_mob_num, eq5d_self_care_num, eq5d_activities_num,
      eq5d_pain_num, eq5d_anxiety_num),
    eq5d5l_index_vas = eq5d5l_index_vas(
      eq5d_mob_num, eq5d_self_care_num, eq5d_activities_num,
      eq5d_pain_num, eq5d_anxiety_num),

    # Gamla VAS-skalor konverteras till likert för smärta och satisfaction
    kn_pain_all = coalesce(ordered(kn_pain), cut_vas(vas_old, when)),
    satisfaction_all =
      coalesce(ordered(satisfaction), cut_vas_satisfaction(knee_op_sat_old))
  ) %>%
  filter(!is.na(prom_period)) %>%
  # Om en primop har fler än en pre- eller post-PROM-enkät så tas i första hand
  # den som ligger närmast tidsgränsen.
  # Vid fler från samma datum tas den enkät som har mest ifylld information.
  # Har de lika mycket information sker valet slumpmässigt
  arrange(SubjectKey, KP_Side, KP_SurgDate, when, prom_time_diff_goal, fyllnadsgrad) %>%
  distinct(SubjectKey, KP_Side, KP_SurgDate, when, .keep_all = TRUE) %>%
  select(-when, -fyllnadsgrad)

Från Z:\SHPR\Arsrapport\2021\code\lib\prom.R


any_na <- function(...) apply(cbind(...), 1, anyNA)

# EQ-5D-index -------------------------------------------------------------

# Burström et al 2014, TTO MOdel 4 (Table 3)
# https://dx.doi.org/10.1007%2Fs11136-013-0496-4
eq5d3l_index_tto <- function(mobility, selfcare, usual, pain, anxiety) {
  ifelse(
    any_na(mobility, selfcare, usual, pain, anxiety), NA,
    0.9694 -
      c(0, 0.0666, 0.1247)[mobility] -
      c(0, 0.0276, 0.0276)[selfcare] -
      c(0, 0.1012, 0.1355)[usual]    -
      c(0, 0.0345, 0.0904)[pain]     -
      c(0, 0.0552, 0.2077)[anxiety]  -
      ifelse(pmax(mobility, selfcare, usual, pain, anxiety) == 3, 0.0433, 0)
  )
}

# eq5d3l_index_tto(1, 1, 1, 1, 1) # 0,969
# eq5d3l_index_tto(1, 2, 2, 3, 3) # 0,499
# eq5d3l_index_tto(2, 1, 3, 1, 1) # 0,724

# Gamla arkiverade EQ5D-data har sparats som kommaavgränsade textsträngar för knä
eq5d3l_index_tto_old <- function(x) {
  x %>%
  strsplit(",") %>%
  map(~tibble(.[1], .[2], .[3], .[4], .[5])) %>%
  bind_rows() %>%
  setNames(c("mobility", "selfcare", "usual", "pain", "anxiety")) %>%
  mutate(across(.fns = as.numeric)) %>%
  {do.call(eq5d3l_index_tto, .)}
}

eq5d3l_index_tto_old(c("2,2,2,2,3", NA, "2,2,2,3,3", "2,2,2,2,2"))

# Burström, model 5 TTO
# https://link.springer.com/article/10.1007/s40273-020-00905-7/tables/9
eq5d5l_index_tto <- function(mobility, selfcare, usual, pain, anxiety) {
  ifelse(
    any_na(mobility, selfcare, usual, pain, anxiety), NA,
    0.9755 -
    c(0, 0.0287, 0.0346, 0.0523, 0.0523)[mobility] -
    c(0, 0.0254, 0.0817, 0.0824, 0.0824)[selfcare] -
    c(0, 0.0549, 0.1143, 0.1639, 0.1639)[usual]    -
    c(0, 0.0108, 0.0428, 0.1024, 0.1974)[pain]     -
    c(0, 0.0325, 0.0868, 0.2002, 0.2339)[anxiety]  -
    ifelse(pmax(mobility, selfcare, usual, pain, anxiety) == 5, 0.0023, 0)
  )
}

# eq5d5l_index_tto(3,4,5,4,3) # 0.503
# eq5d5l_index_tto(rep(3, 10), rep(4, 10),rep(5, 10), rep(4, 10), rep(3, 10))

# Burström, model 5 VAS
# https://link.springer.com/article/10.1007/s40273-020-00905-7/tables/9
eq5d5l_index_vas <- function(mobility, selfcare, usual, pain, anxiety) {
  maxp <- pmax(mobility, selfcare, usual, pain, anxiety)
  ifelse(
    any_na(mobility, selfcare, usual, pain, anxiety), NA,
    88.85 -
    c(0, 3.37,  5.53,  9.05,  9.05)[mobility] -
    c(0, 2.25,  2.82,  6.07,  7.83)[selfcare] -
    c(0, 5.23, 10.12, 14.07, 17.05)[usual]    -
    c(0, 1.63,  4.43, 10.14, 17.05)[pain]     -
    c(0, 4.97, 10.75, 16.52, 27.30)[anxiety]  -
    ifelse(maxp >= 2, 2.75, 0) -
    ifelse(maxp >= 3, 4.19, 0) -
    ifelse(maxp >= 4, 1.85, 0)
  )
}

# eq5d5l_index_vas(3,4,5,4,3) # 30.5
# eq5d5l_index_vas(rep(3, 10), rep(4, 10),rep(5, 10), rep(4, 10), rep(3, 10))

# VAS2Likert --------------------------------------------------------------

# when anger om PROM kommer är "pre" eller "post", vilket (lite oturligt)
# har olika gränser
cut_vas <- function(x, when) {
  labs <- c("Ingen", "Mycket lindrig", "Lindrig", "Måttlig", "Svår")
  case_when(
    when == "pre"  ~ cut2(x, c(0, 3,  7, 27, 70, 101), labs),
    when == "post" ~ cut2(x, c(0, 5, 20, 36, 70, 101), labs),
  )
}

# Satisfaction from VAS to likert
cut_vas_satisfaction <- function(x) {
  cut2(x, c(0, 10,  31, 60, 81, 101),
       c("Mycket nöjd", "Nöjd", "Varken nöjd eller missnöjd",
         "Missnöjd", "Mycket missnöjd")
  ) %>%
  forcats::fct_rev()
}
eribul commented 2 years ago

Denna funktionalitet utvecklas istället här: https://gitlab.com/registercentrum/statistikenheten/rcstat/-/issues/3