transfer from old repo
This commit is contained in:
parent
cfa4a5f9cc
commit
277e2b8cf3
1111 changed files with 83736 additions and 0 deletions
248
2 Longterm/funs.R
Normal file
248
2 Longterm/funs.R
Normal file
|
|
@ -0,0 +1,248 @@
|
|||
|
||||
## Utils
|
||||
|
||||
multi_rev <- function(ds, var){
|
||||
ndx <- match(var,colnames(ds))
|
||||
for (i in seq_along(ndx)){
|
||||
j <- ndx[i]
|
||||
ds[[j]]<-as.character(factor(ds[[j]],labels = c(rev(levels(factor(ds[[j]]))))))
|
||||
}
|
||||
ds
|
||||
}
|
||||
|
||||
reg2score <- function(ds){
|
||||
# Removes all padding from registred scores
|
||||
l <- c()
|
||||
for (i in seq_len(ncol(ds))){
|
||||
l[[i]] <- gsub("[^a-zA-Z0-9]","",ds[[i]])
|
||||
}
|
||||
|
||||
d <- do.call(cbind,l) |> data.frame()
|
||||
|
||||
colnames(d) <- colnames(ds)
|
||||
d |> tibble()
|
||||
}
|
||||
|
||||
|
||||
|
||||
## MFI modding
|
||||
|
||||
mfi_domains <- function(ds, reverse=TRUE, var){
|
||||
|
||||
# Subscore indexes
|
||||
indexes <- list(
|
||||
data.frame(grp="gen", ndx=c(1, 5, 12, 16)),
|
||||
data.frame(grp="phy", ndx=c(2, 8, 14, 20)),
|
||||
data.frame(grp="act", ndx=c(3, 6, 10, 17)),
|
||||
data.frame(grp="mot", ndx=c(4, 9, 15, 18)),
|
||||
data.frame(grp="men", ndx=c(7, 11, 13, 19))
|
||||
) |> bind_rows() |> arrange(ndx)
|
||||
|
||||
# Assumes reverse scores are not correctly reversed
|
||||
if (reverse){ds <- ds |> multi_rev(var)}
|
||||
|
||||
# Removes padding and converts to numeric
|
||||
d <- ds |> reg2score() |>
|
||||
mutate_if(is.character, as.numeric)
|
||||
|
||||
split.default(d, factor(indexes$grp)) |>
|
||||
lapply(function(x){
|
||||
apply(x, MARGIN = 1, sum)
|
||||
}) |> bind_cols()
|
||||
|
||||
}
|
||||
|
||||
## Registration correction
|
||||
|
||||
# 1. If the inc_time is 38 days or less MDI 6 scores are moved to MDI 1 and visit 6 is defined as visit 1.
|
||||
# 2. If both visit 1 and 6 dates are NA, use enddate as visit 1 date. This is the case if patients were excluded early.
|
||||
# 3. If visit 6 is recorded later than enddate, use enddate instead. MDI 6 score is dropped.
|
||||
# 4. If visit delay is 7 days or less, and inclusion time is more than 38, MDI 1 is moved to MDI 6 and dropped. If MDI 1 and 6 are different both are kept. Enddate is moved to visit 6 date.
|
||||
# 5. Defining the visit 6 date as same as enddate if visit delay is <7.
|
||||
|
||||
# ds <- ls_nas$mdi
|
||||
# ref <- subjects
|
||||
|
||||
|
||||
time_reg_correction <- function(ds, ref) {
|
||||
|
||||
# Splitting by rnumb, to treat each subj
|
||||
ls <- split(ds, ds$rnumb)
|
||||
|
||||
# ref: https://r-coder.com/progress-bar-r/
|
||||
# Setting up simple progress bar
|
||||
pb <- txtProgressBar(min = 0, max = length(ls), style = 3)
|
||||
|
||||
|
||||
# Getting the rnumbs for subsetting in order of the list
|
||||
nms <- names(ls)
|
||||
# Applying correction to each element in list
|
||||
ls_c <- lapply(seq_along(ls), function(i) {
|
||||
cat(paste(i,"af",length(ls)))
|
||||
# Updates the current state
|
||||
setTxtProgressBar(pb, i)
|
||||
|
||||
# Current rnumb
|
||||
nm <- nms[i]
|
||||
# print(i)
|
||||
df <- ls[[i]]
|
||||
# Only run if both instance 2 and 4 are present
|
||||
if (all(c(2, 4) %in% select(df, matches("instance", ignore.case = TRUE))[[1]])) {
|
||||
|
||||
# Define common variables
|
||||
inc_time <- as.numeric(ref$inc_time[ref$rnumb == nm])
|
||||
end_date <- as.Date(ref$enddate[ref$rnumb == nm])
|
||||
rdate <- as.Date(ref$rdate[ref$rnumb == nm])
|
||||
inst <- grep("instance", tolower(colnames(df)))
|
||||
|
||||
# Define relevant data columns to substitute/modify
|
||||
cols <- (inst + 1):ncol(df)
|
||||
|
||||
# Define date column index
|
||||
date_col_index <-
|
||||
match(colnames(select(df, ends_with("00"))), colnames(df))
|
||||
|
||||
# Step 1
|
||||
|
||||
## Correction if inc_time is performed
|
||||
if (inc_time <= 38 & all(is.na(df[df[inst] == 2, cols]))) {
|
||||
# Substitutions to transfer instance 4 meassures and leave as NA
|
||||
df[df[inst] == 2, cols] <- df[df[inst] == 4, cols]
|
||||
df[df[inst] == 4, -c(inst,date_col_index)] <- NA
|
||||
}
|
||||
|
||||
# Step 2
|
||||
|
||||
if (all(is.na(df[date_col_index]))) {
|
||||
# If both visit dates are missing, instance 2 date is substituted with enddate
|
||||
df[date_col_index][df[inst] == 2] <-
|
||||
as.character(end_date)
|
||||
}
|
||||
|
||||
# Step HELPA
|
||||
## Extra help step to impute enddate as visit 4 if instance 4 is present but no date.
|
||||
if (is.na(df[date_col_index][df[inst] == 4])){
|
||||
df[date_col_index][df[inst] == 4] <- as.character(end_date)
|
||||
}
|
||||
|
||||
## Last steps are only performed if date values are available for both instance 2 and 4
|
||||
if (!any(is.na(df[date_col_index]))){
|
||||
|
||||
# Step 3
|
||||
end_delay <- as.numeric(difftime(df[date_col_index][df[inst] == 4],
|
||||
end_date,
|
||||
units = "days"))
|
||||
|
||||
# If enddate is before last visit, the last visit data is dropped.
|
||||
if (end_delay > 2) {
|
||||
df[df[inst] == 4,-c(inst,date_col_index)] <- NA
|
||||
}
|
||||
|
||||
# Step 4
|
||||
visit_delay <-
|
||||
as.numeric(difftime(df[date_col_index][df[inst] == 4], df[date_col_index][df[inst] ==
|
||||
2], units = "days"))
|
||||
|
||||
if (purrr::is_empty(visit_delay)){
|
||||
visit_delay <- NA
|
||||
}
|
||||
|
||||
|
||||
## Test if data has manually been inserted at visit 2, though should should be visit 4 time wise
|
||||
second2fourth <-
|
||||
if_else((visit_delay <= 7 |
|
||||
all(is.na(df[df[inst] == 2, cols]))) &
|
||||
inc_time > 38,
|
||||
TRUE,
|
||||
FALSE,
|
||||
missing = FALSE)
|
||||
|
||||
## Move data from 2. visit to 4.
|
||||
if (second2fourth) {
|
||||
# df[date_col_index][df[inst] == 2]
|
||||
|
||||
## If all missing at last visit, 1. visit is copied
|
||||
if (all(is.na(df[df[inst] == 4, cols]))) {
|
||||
df[df[inst] == 4, cols] <- df[df[inst] == 2, cols]
|
||||
}
|
||||
|
||||
## If entries at visit 2 and 4 are identical, vist 2 is deleted
|
||||
if (identical(df[df[inst] == 4, cols], df[df[inst] == 2, cols])) {
|
||||
df[df[inst] == 2, -c(inst,date_col_index)] <- NA
|
||||
}
|
||||
|
||||
## If data entries are NA at visit 2, the date is also deleted
|
||||
if (all(is.na(df[df[inst] == 2, cols]))) {
|
||||
df[,date_col_index][df[inst] == 2] <- NA
|
||||
}
|
||||
|
||||
## The registered enddate is copied to the visit 4 date
|
||||
df[,date_col_index][df[inst] == 4] <-
|
||||
as.character(end_date)
|
||||
}
|
||||
|
||||
# Step 5
|
||||
## Ensure enddate is visit 4 if visit delay is <7
|
||||
if (visit_delay < 7) {
|
||||
df[,date_col_index][df[inst] == 4] <- as.character(end_date)
|
||||
}
|
||||
}
|
||||
}
|
||||
df
|
||||
})
|
||||
|
||||
ls_c |> bind_rows()
|
||||
|
||||
}
|
||||
|
||||
longlist2wide <-
|
||||
function(list,
|
||||
id.name = "rnumb",
|
||||
instance = "instance",
|
||||
inst.glue = "{.value}_{instance}") {
|
||||
|
||||
# ref: https://r-coder.com/progress-bar-r/
|
||||
# Setting up simple progress bar
|
||||
pb <- txtProgressBar(min = 0, max = length(list), style = 3)
|
||||
|
||||
l <- lapply(seq_along(list), function(i) {
|
||||
|
||||
# Updates the current state
|
||||
setTxtProgressBar(pb, i)
|
||||
|
||||
lst <- list[[i]] |> data.frame()
|
||||
|
||||
rep_inst <-
|
||||
length(levels(factor(lst[, colnames(lst) == instance]))) > 1
|
||||
|
||||
|
||||
k <- lapply(split(lst, f = lst[[id.name]]), function(j) {
|
||||
cname <- colnames(j)
|
||||
vals <-
|
||||
cname[!cname %in% c(id.name,
|
||||
instance)]
|
||||
s <- tidyr::pivot_wider(
|
||||
j,
|
||||
names_from = instance,
|
||||
values_from = all_of(vals),
|
||||
names_glue = inst.glue
|
||||
)
|
||||
s[!colnames(s) %in% instance]
|
||||
})
|
||||
|
||||
k |> dplyr::bind_rows()
|
||||
|
||||
|
||||
})
|
||||
|
||||
}
|
||||
|
||||
na_recode <- function(ds,vars_na,new_na="no"){
|
||||
for (i in seq_along(vars_na)){
|
||||
ds[i][is.na(ds[i])] <- new_na
|
||||
}
|
||||
ds
|
||||
}
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in a new issue