transfer from old repo
This commit is contained in:
parent
cfa4a5f9cc
commit
277e2b8cf3
1111 changed files with 83736 additions and 0 deletions
236
fun/functions.R
Normal file
236
fun/functions.R
Normal file
|
|
@ -0,0 +1,236 @@
|
|||
create_log_tics <- function(data){
|
||||
sort(round(unique(c(1/data,data)),2))
|
||||
}
|
||||
|
||||
|
||||
#' Test if input is within specified range or range of vector
|
||||
#'
|
||||
#' @param data numeric vector
|
||||
#' @param vec numeric vector
|
||||
#'
|
||||
#' @returns logical
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' in_range(2,c(3,5))
|
||||
#' in_range(c(2,4),c(3,5))
|
||||
in_range <- function(data, vec) {
|
||||
## Extra safety to ensure correct order of min/max
|
||||
rng <- range(vec)
|
||||
## Test
|
||||
sapply(data, \(.x){
|
||||
.x >= rng[1] & .x <= rng[2]
|
||||
})
|
||||
}
|
||||
|
||||
simple_shap_plot <- function(data, title = "Coefficients") {
|
||||
df <- data |> dplyr::mutate(var = forcats::as_factor(as.character(var)))
|
||||
|
||||
d.tics <- c(.5, .8, 1, 1.5, 3)
|
||||
# browser()
|
||||
|
||||
all.tics <- create_log_tics(d.tics)
|
||||
|
||||
if (all(range(df$val) < 1)) {
|
||||
if (!in_range(min(df$val), all.tics)) {
|
||||
all.tics <- create_log_tics(c(d.tics, floor(min(df$val))))
|
||||
}
|
||||
# log(df$val)
|
||||
x.tics <- all.tics[all.tics <= 1]
|
||||
} else if (all(range(df$val) > 1)) {
|
||||
if (!in_range(max(df$val), all.tics)) {
|
||||
all.tics <- create_log_tics(c(d.tics, ceiling(max(df$val))))
|
||||
}
|
||||
|
||||
x.tics <- all.tics[all.tics >= 1]
|
||||
} else {
|
||||
x.tics <- all.tics
|
||||
}
|
||||
|
||||
ggplot2::ggplot(df, ggplot2::aes(x = val, y = var)) +
|
||||
ggplot2::geom_bar(fill = "#fca50a", width = 2 / 3, stat = "identity") +
|
||||
# ggplot2::geom_text(ggplot2::aes(label=val), hjust=-1)+
|
||||
ggplot2::scale_y_discrete(limits = rev) +
|
||||
# ggplot2::scale_x_continuous(labels=function(x)x+1)+
|
||||
ggplot2::scale_x_continuous(
|
||||
transform = "log",
|
||||
breaks = x.tics,
|
||||
labels = x.tics,
|
||||
limits = range(x.tics)
|
||||
) +
|
||||
ggplot2::ggtitle(title) +
|
||||
ggplot2::labs(x = "median(OR)", y = ggplot2::element_blank()) +
|
||||
ggplot2::theme_bw() +
|
||||
ggplot2::theme(
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
# legend.title = ggplot2::element_text(""),
|
||||
legend.position = "bottom"
|
||||
)
|
||||
}
|
||||
|
||||
|
||||
forest_plot <- function(data,
|
||||
only_sign=FALSE) {
|
||||
|
||||
df <- data |>
|
||||
dplyr::mutate(var = forcats::as_factor(as.character(var)))
|
||||
|
||||
# browser()
|
||||
df$is_sign <- apply(df[c("lo","hi")],1,\(.x){
|
||||
!in_range(0,.x)
|
||||
})
|
||||
|
||||
if (!isTRUE(only_sign)){
|
||||
cols <- c("gray50","#82AE36")
|
||||
} else {
|
||||
cols <- "#82AE36"
|
||||
df <- df[df$is_sign,]
|
||||
}
|
||||
|
||||
df |>
|
||||
ggplot2::ggplot(ggplot2::aes(x = beta, y = var,color=is_sign))+
|
||||
ggplot2::geom_vline(ggplot2::aes(xintercept = 0), linewidth = .5, linetype = "dashed") +
|
||||
ggplot2::geom_point(#ggplot2::aes(shape = model),
|
||||
# position = ggplot2::position_dodge(width = dodge.width),
|
||||
size = 6
|
||||
) +
|
||||
ggplot2::geom_errorbarh(ggplot2::aes(xmax = hi, xmin = lo),
|
||||
# position = ggplot2::position_dodge(width = dodge.width),
|
||||
size = .8,
|
||||
height = .5,
|
||||
color = "gray50"
|
||||
) +
|
||||
# ggplot2::position_dodge(width = 2, preserve = "total")+
|
||||
ggplot2::scale_x_continuous(
|
||||
# breaks = seq(min(df$lo,na.rm=TRUE),max(df$hi,na.rm=TRUE))
|
||||
) +
|
||||
ggplot2::scale_y_discrete(limits = rev) +
|
||||
ggplot2::scale_color_manual(values = cols)+
|
||||
ggplot2::theme_bw() +
|
||||
ggplot2::theme(
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
# legend.title = ggplot2::element_text(""),
|
||||
legend.position = "none"
|
||||
) +
|
||||
ggplot2::ylab("") +
|
||||
ggplot2::xlab("Mean PASE score difference")
|
||||
}
|
||||
|
||||
|
||||
pase_table_clean <- function(data){
|
||||
suppressWarnings(
|
||||
list(Univariate=data[1:3],
|
||||
Multivariate=data[c(1,4,5)],
|
||||
"Imputed multivariate"=data[c(1,6,7)]) |>
|
||||
purrr::imap(\(.x,.i){
|
||||
out <- setNames(.x,c("var","val","ci")) |>
|
||||
tidyr::separate(
|
||||
col = "ci", into = c("lo", "hi"), sep = ", ", convert = TRUE
|
||||
)|>
|
||||
dplyr::mutate(dplyr::across(tidyselect::all_of(c("val", "lo", "hi")), as.numeric))
|
||||
# browser()
|
||||
out$var <- sapply(out$var,\(.s){
|
||||
l <- nchar(.s)
|
||||
substr(.s,5,l)
|
||||
})
|
||||
# out[1,2:4] <- 1
|
||||
out$model <- .i
|
||||
out$var <- sapply(out$var,\(.x){
|
||||
paste(strwrap(.x, 25), collapse = "\n")})
|
||||
|
||||
out
|
||||
}) |>
|
||||
dplyr::bind_rows()
|
||||
)
|
||||
}
|
||||
|
||||
forest_plot_grp <- function(data,
|
||||
# group.colors = viridisLite::viridis(4,option = "D"),
|
||||
group.colors=NULL,
|
||||
dodge.width=-.8,
|
||||
rev_y=TRUE) {
|
||||
|
||||
df <- data |>
|
||||
dplyr::mutate(var = forcats::as_factor(as.character(var)),
|
||||
model = forcats::as_factor(as.character(model)))
|
||||
|
||||
d.tics <- c(.5, 1, 1.5, 3)
|
||||
# browser()
|
||||
|
||||
all.tics <- create_log_tics(d.tics)
|
||||
|
||||
if (!in_range(min(df$lo,na.rm=TRUE), all.tics)) {
|
||||
all.tics <- create_log_tics(c(d.tics, floor(min(df$lo,na.rm=TRUE)*10)/10))
|
||||
}
|
||||
|
||||
if (!in_range(max(df$hi,na.rm=TRUE), all.tics)) {
|
||||
all.tics <- create_log_tics(c(d.tics, ceiling(max(df$hi,na.rm=TRUE))))
|
||||
}
|
||||
|
||||
if (all(range(df$val) < 1)) {
|
||||
x.tics <- all.tics[all.tics <= 1]
|
||||
} else if (all(range(df$val) > 1)) {
|
||||
x.tics <- all.tics[all.tics >= 1]
|
||||
} else {
|
||||
x.tics <- all.tics
|
||||
}
|
||||
|
||||
df$is_sign <- apply(df[c("lo","hi")],1,\(.x){
|
||||
out <- !in_range(1,.x)
|
||||
out[is.na(out)] <- FALSE
|
||||
out
|
||||
})
|
||||
#
|
||||
# if (!isTRUE(only_sign)){
|
||||
# cols <- c("gray50","#82AE36")
|
||||
# } else {
|
||||
# cols <- "#82AE36"
|
||||
# df <- df[df$is_sign,]
|
||||
# }
|
||||
# browser()
|
||||
|
||||
out <- df |>
|
||||
ggplot2::ggplot(ggplot2::aes(x = val, y = var, xmax = hi, xmin = lo))+
|
||||
ggplot2::geom_vline(ggplot2::aes(xintercept = 1), linewidth = .5, linetype = "dashed") +
|
||||
## Adding the grouping solved the errorbar not dodging correctly
|
||||
## found here: https://www.reddit.com/r/rstats/comments/1ew20sh/ggplot2s_position_dodge_doesnt_work_with_geom/
|
||||
ggplot2::geom_errorbarh(ggplot2::aes(group = interaction(var,model)),
|
||||
position = ggplot2::position_dodge(width = dodge.width,preserve = "total"),
|
||||
size = .8,
|
||||
height = .5,
|
||||
color = "gray50"
|
||||
) +
|
||||
ggplot2::geom_point(ggplot2::aes(color = var, fill=var, shape=model),
|
||||
position = ggplot2::position_dodge(width = dodge.width,preserve = "total"),
|
||||
size = 6
|
||||
) +
|
||||
# ggplot2::position_dodge(width = 2, preserve = "total")+
|
||||
ggplot2::scale_x_continuous(
|
||||
transform = "log",
|
||||
breaks = x.tics,
|
||||
labels = x.tics,
|
||||
limits = range(x.tics)
|
||||
) +
|
||||
# ggplot2::scale_color_manual(values = cols)+
|
||||
ggplot2::theme_bw() +
|
||||
ggplot2::theme(
|
||||
panel.grid.minor = ggplot2::element_blank(),
|
||||
# legend.title = ggplot2::element_text(""),
|
||||
legend.position = "bottom"
|
||||
) +
|
||||
ggplot2::ylab("") +
|
||||
ggplot2::xlab("OR")
|
||||
|
||||
if (isTRUE(rev_y)){
|
||||
out <- out +
|
||||
ggplot2::scale_y_discrete(limits = rev)
|
||||
}
|
||||
|
||||
if (!is.null(group.colors)){
|
||||
out <- out+
|
||||
ggplot2::scale_color_manual(values = group.colors) +
|
||||
ggplot2::scale_fill_manual(values = group.colors)
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
Loading…
Reference in a new issue