mirror of
https://github.com/agdamsbo/FreesearchR.git
synced 2026-06-19 12:37:30 +02:00
updated ui/ux
This commit is contained in:
parent
1bfad4ba4c
commit
16adb622ee
10 changed files with 389 additions and 363 deletions
|
|
@ -1 +1 @@
|
|||
app_version <- function()'250320_1310'
|
||||
app_version <- function()'250324_1432'
|
||||
|
|
|
|||
|
|
@ -20,3 +20,55 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary,
|
|||
return(out)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Create a baseline table
|
||||
#'
|
||||
#' @param data data
|
||||
#' @param ... passed as fun.arg to baseline_table()
|
||||
#' @param strat.var grouping/strat variable
|
||||
#' @param add.p add comparison/p-value
|
||||
#' @param add.overall add overall column
|
||||
#'
|
||||
#' @returns gtsummary table list object
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes")
|
||||
create_baseline <- function(data,...,by.var,add.p=FALSE,add.overall=FALSE){
|
||||
if (by.var == "none" | !by.var %in% names(data)) {
|
||||
by.var <- NULL
|
||||
}
|
||||
|
||||
## These steps are to handle logicals/booleans, that messes up the order of columns
|
||||
## Has been reported
|
||||
|
||||
if (!is.null(by.var)) {
|
||||
if (identical("logical",class(data[[by.var]]))){
|
||||
data[by.var] <- as.character(data[[by.var]])
|
||||
}
|
||||
}
|
||||
|
||||
out <- data |>
|
||||
baseline_table(
|
||||
fun.args =
|
||||
list(
|
||||
by = by.var,
|
||||
...
|
||||
)
|
||||
)
|
||||
|
||||
if (!is.null(by.var)) {
|
||||
if (isTRUE(add.overall)){
|
||||
out <- out |> gtsummary::add_overall()
|
||||
}
|
||||
if (isTRUE(add.p)) {
|
||||
out <- out |>
|
||||
gtsummary::add_p() |>
|
||||
gtsummary::bold_p()
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
out
|
||||
}
|
||||
|
|
|
|||
|
|
@ -302,6 +302,7 @@ data_visuals_server <- function(id,
|
|||
{
|
||||
tryCatch(
|
||||
{
|
||||
shiny::withProgress(message = "Drawing the plot. Hold tight for a moment..", {
|
||||
rv$plot <- create_plot(
|
||||
data = data(),
|
||||
type = rv$plot.params()[["fun"]],
|
||||
|
|
@ -309,6 +310,7 @@ data_visuals_server <- function(id,
|
|||
y = input$secondary,
|
||||
z = input$tertiary
|
||||
)
|
||||
})
|
||||
},
|
||||
# warning = function(warn) {
|
||||
# showNotification(paste0(warn), type = "warning")
|
||||
|
|
|
|||
76
R/helpers.R
76
R/helpers.R
|
|
@ -29,7 +29,7 @@ getfun <- function(x) {
|
|||
#' @return output file name
|
||||
#' @export
|
||||
#'
|
||||
write_quarto <- function(data,...) {
|
||||
write_quarto <- function(data, ...) {
|
||||
# Exports data to temporary location
|
||||
#
|
||||
# I assume this is more secure than putting it in the www folder and deleting
|
||||
|
|
@ -50,7 +50,7 @@ write_quarto <- function(data,...) {
|
|||
)
|
||||
}
|
||||
|
||||
write_rmd <- function(data,...) {
|
||||
write_rmd <- function(data, ...) {
|
||||
# Exports data to temporary location
|
||||
#
|
||||
# I assume this is more secure than putting it in the www folder and deleting
|
||||
|
|
@ -210,17 +210,17 @@ file_export <- function(data, output.format = c("df", "teal", "list"), filename,
|
|||
#' default_parsing() |>
|
||||
#' str()
|
||||
default_parsing <- function(data) {
|
||||
name_labels <- lapply(data,\(.x) REDCapCAST::get_attr(.x,attr = "label"))
|
||||
name_labels <- lapply(data, \(.x) REDCapCAST::get_attr(.x, attr = "label"))
|
||||
|
||||
out <- data |>
|
||||
REDCapCAST::parse_data() |>
|
||||
REDCapCAST::as_factor() |>
|
||||
REDCapCAST::numchar2fct(numeric.threshold = 8,character.throshold = 10) |>
|
||||
REDCapCAST::numchar2fct(numeric.threshold = 8, character.throshold = 10) |>
|
||||
REDCapCAST::as_logical() |>
|
||||
REDCapCAST::fct_drop()
|
||||
|
||||
purrr::map2(out,name_labels,\(.x,.l){
|
||||
if (!(is.na(.l) | .l=="")) {
|
||||
purrr::map2(out, name_labels, \(.x, .l){
|
||||
if (!(is.na(.l) | .l == "")) {
|
||||
REDCapCAST::set_attr(.x, .l, attr = "label")
|
||||
} else {
|
||||
attr(x = .x, which = "label") <- NULL
|
||||
|
|
@ -238,12 +238,14 @@ default_parsing <- function(data) {
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x,label=NA,attr = "label"))
|
||||
#' ds |> remove_na_attr() |> str()
|
||||
remove_na_attr <- function(data,attr="label"){
|
||||
#' ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label"))
|
||||
#' ds |>
|
||||
#' remove_na_attr() |>
|
||||
#' str()
|
||||
remove_na_attr <- function(data, attr = "label") {
|
||||
out <- data |> lapply(\(.x){
|
||||
ls <- REDCapCAST::get_attr(data = .x,attr = attr)
|
||||
if (is.na(ls) | ls == ""){
|
||||
ls <- REDCapCAST::get_attr(data = .x, attr = attr)
|
||||
if (is.na(ls) | ls == "") {
|
||||
attr(x = .x, which = attr) <- NULL
|
||||
}
|
||||
.x
|
||||
|
|
@ -261,10 +263,10 @@ remove_na_attr <- function(data,attr="label"){
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#'data.frame(a=1:10,b=NA, c=c(2,NA)) |> remove_empty_cols(cutoff=.5)
|
||||
remove_empty_cols <- function(data,cutoff=.7){
|
||||
filter <- apply(X = data,MARGIN = 2,FUN = \(.x){
|
||||
sum(as.numeric(!is.na(.x)))/length(.x)
|
||||
#' data.frame(a = 1:10, b = NA, c = c(2, NA)) |> remove_empty_cols(cutoff = .5)
|
||||
remove_empty_cols <- function(data, cutoff = .7) {
|
||||
filter <- apply(X = data, MARGIN = 2, FUN = \(.x){
|
||||
sum(as.numeric(!is.na(.x))) / length(.x)
|
||||
}) >= cutoff
|
||||
data[filter]
|
||||
}
|
||||
|
|
@ -280,18 +282,18 @@ remove_empty_cols <- function(data,cutoff=.7){
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' ls_d <- list(test=c(1:20))
|
||||
#' ls_d <- list(test = c(1:20))
|
||||
#' ls_d <- list()
|
||||
#' data.frame(letters[1:20],1:20) |> append_list(ls_d,"letters")
|
||||
#' letters[1:20]|> append_list(ls_d,"letters")
|
||||
append_list <- function(data,list,index){
|
||||
#' data.frame(letters[1:20], 1:20) |> append_list(ls_d, "letters")
|
||||
#' letters[1:20] |> append_list(ls_d, "letters")
|
||||
append_list <- function(data, list, index) {
|
||||
## This will overwrite and not warn
|
||||
## Not very safe, but convenient to append code to list
|
||||
if (index %in% names(list)){
|
||||
if (index %in% names(list)) {
|
||||
list[[index]] <- data
|
||||
out <- list
|
||||
} else {
|
||||
out <- setNames(c(list,list(data)),c(names(list),index))
|
||||
out <- setNames(c(list, list(data)), c(names(list), index))
|
||||
}
|
||||
out
|
||||
}
|
||||
|
|
@ -305,7 +307,33 @@ append_list <- function(data,list,index){
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c(NA,1:10,rep(NA,3)) |> missing_fraction()
|
||||
missing_fraction <- function(data){
|
||||
NROW(data[is.na(data)])/NROW(data)
|
||||
#' c(NA, 1:10, rep(NA, 3)) |> missing_fraction()
|
||||
missing_fraction <- function(data) {
|
||||
NROW(data[is.na(data)]) / NROW(data)
|
||||
}
|
||||
|
||||
|
||||
|
||||
#' Ultra short data dascription
|
||||
#'
|
||||
#' @param data
|
||||
#'
|
||||
#' @returns character vector
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' data.frame(
|
||||
#' sample(1:8, 20, TRUE),
|
||||
#' sample(c(1:8, NA), 20, TRUE)
|
||||
#' ) |> data_description()
|
||||
data_description <- function(data) {
|
||||
data <- if (shiny::is.reactive(data)) data() else data
|
||||
|
||||
sprintf(
|
||||
i18n("Data has %s observations and %s variables, with %s (%s%%) complete cases"),
|
||||
nrow(data),
|
||||
ncol(data),
|
||||
sum(complete.cases(data)),
|
||||
signif(100 * (1 - missing_fraction(data)), 3)
|
||||
)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -43,15 +43,16 @@ plot.tbl_regression <- function(x,
|
|||
|
||||
# Removes redundant label
|
||||
df_coefs$label[df_coefs$row_type == "label"] <- ""
|
||||
|
||||
# browser()
|
||||
# Add estimate value to reference level
|
||||
if (plot_ref == TRUE){
|
||||
df_coefs[df_coefs$var_type == "categorical" & is.na(df_coefs$reference_row),"estimate"] <- if (x$inputs$exponentiate) 1 else 0}
|
||||
if (plot_ref == TRUE) {
|
||||
df_coefs[df_coefs$var_type %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0
|
||||
}
|
||||
|
||||
p <- df_coefs |>
|
||||
ggstats::ggcoef_plot(exponentiate = x$inputs$exponentiate, ...)
|
||||
|
||||
if (x$inputs$exponentiate){
|
||||
if (x$inputs$exponentiate) {
|
||||
p <- symmetrical_scale_x_log10(p)
|
||||
}
|
||||
p
|
||||
|
|
@ -89,7 +90,8 @@ merge_long <- function(list, model.names) {
|
|||
)
|
||||
setNames(d, gsub("_[0-9]{,}$", "", names(d)))
|
||||
}) |>
|
||||
dplyr::bind_rows() |> dplyr::mutate(model=as_factor(model))
|
||||
dplyr::bind_rows() |>
|
||||
dplyr::mutate(model = as_factor(model))
|
||||
|
||||
l_merged$table_body <- df_body_long
|
||||
|
||||
|
|
@ -109,12 +111,25 @@ merge_long <- function(list, model.names) {
|
|||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' limit_log(-.1,floor)
|
||||
#' limit_log(.1,ceiling)
|
||||
#' limit_log(-2.1,ceiling)
|
||||
#' limit_log(2.1,ceiling)
|
||||
limit_log <- function(data,fun,...){
|
||||
fun(10^-floor(data)*10^data)/10^-floor(data)
|
||||
#' limit_log(-.1, floor)
|
||||
#' limit_log(.1, ceiling)
|
||||
#' limit_log(-2.1, ceiling)
|
||||
#' limit_log(2.1, ceiling)
|
||||
limit_log <- function(data, fun, ...) {
|
||||
fun(10^-floor(data) * 10^data) / 10^-floor(data)
|
||||
}
|
||||
|
||||
#' Create summetric log ticks
|
||||
#'
|
||||
#' @param data numeric vector
|
||||
#'
|
||||
#' @returns
|
||||
#' @export
|
||||
#'
|
||||
#' @examples
|
||||
#' c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics()
|
||||
create_log_tics <- function(data) {
|
||||
sort(round(unique(c(1 / data, data, 1)), 2))
|
||||
}
|
||||
|
||||
#' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots
|
||||
|
|
@ -126,18 +141,18 @@ limit_log <- function(data,fun,...){
|
|||
#' @returns ggplot2 object
|
||||
#' @export
|
||||
#'
|
||||
symmetrical_scale_x_log10 <- function(plot,breaks=c(1,2,3,5,10),...){
|
||||
symmetrical_scale_x_log10 <- function(plot, breaks = c(1, 2, 3, 5, 10), ...) {
|
||||
rx <- ggplot2::layer_scales(plot)$x$get_limits()
|
||||
|
||||
x_min <- floor(10*rx[1])/10
|
||||
x_max <- ceiling(10*rx[2])/10
|
||||
x_min <- floor(10 * rx[1]) / 10
|
||||
x_max <- ceiling(10 * rx[2]) / 10
|
||||
|
||||
rx_min <- limit_log(rx[1],floor)
|
||||
rx_max <- limit_log(rx[2],ceiling)
|
||||
rx_min <- limit_log(rx[1], floor)
|
||||
rx_max <- limit_log(rx[2], ceiling)
|
||||
|
||||
max_abs_x <- max(abs(c(x_min,x_max)))
|
||||
max_abs_x <- max(abs(c(x_min, x_max)))
|
||||
|
||||
ticks <- log10(breaks)+(ceiling(max_abs_x)-1)
|
||||
ticks <- log10(breaks) + (ceiling(max_abs_x) - 1)
|
||||
|
||||
plot + ggplot2::scale_x_log10(limits=c(rx_min,rx_max),breaks=create_log_tics(10^ticks[ticks<=max_abs_x]))
|
||||
plot + ggplot2::scale_x_log10(limits = c(rx_min, rx_max), breaks = create_log_tics(10^ticks[ticks <= max_abs_x]))
|
||||
}
|
||||
|
|
|
|||
|
|
@ -119,8 +119,8 @@ regression_table_create <- function(x, ..., args.list = NULL, fun = "gtsummary::
|
|||
}
|
||||
|
||||
out <- do.call(getfun(fun), c(list(x = x), args.list))
|
||||
out |>
|
||||
gtsummary::add_glance_source_note() # |>
|
||||
out #|>
|
||||
# gtsummary::add_glance_source_note() # |>
|
||||
# gtsummary::bold_p()
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue