diff --git a/NAMESPACE b/NAMESPACE index 9480d521..aa34d84c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -9,13 +9,10 @@ export(allign_axes) export(append_list) export(argsstring2list) export(baseline_table) -export(clean_common_axis) export(clean_date) export(clean_sep) export(columnSelectInput) export(contrast_text) -export(create_baseline) -export(create_log_tics) export(create_overview_datagrid) export(create_plot) export(custom_theme) @@ -23,10 +20,8 @@ export(cut_variable_server) export(cut_variable_ui) export(data_correlations_server) export(data_correlations_ui) -export(data_description) export(data_summary_server) export(data_summary_ui) -export(data_type) export(data_visuals_server) export(data_visuals_ui) export(default_format_arguments) @@ -66,9 +61,8 @@ export(missing_fraction) export(modal_cut_variable) export(modal_update_factor) export(modify_qmd) +export(outcome_type) export(overview_vars) -export(plot_box) -export(plot_box_single) export(plot_euler) export(plot_euler_single) export(plot_hbars) diff --git a/R/app_version.R b/R/app_version.R index b5243e9b..ff73a306 100644 --- a/R/app_version.R +++ b/R/app_version.R @@ -1 +1 @@ -app_version <- function()'250324_1432' +app_version <- function()'250320_1310' diff --git a/R/baseline_table.R b/R/baseline_table.R index ad90eef4..05af54b6 100644 --- a/R/baseline_table.R +++ b/R/baseline_table.R @@ -20,55 +20,3 @@ 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 -} diff --git a/R/data_plots.R b/R/data_plots.R index 3f40de8f..e9225dec 100644 --- a/R/data_plots.R +++ b/R/data_plots.R @@ -302,7 +302,6 @@ 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"]], @@ -310,7 +309,6 @@ data_visuals_server <- function(id, y = input$secondary, z = input$tertiary ) - }) }, # warning = function(warn) { # showNotification(paste0(warn), type = "warning") diff --git a/R/helpers.R b/R/helpers.R index 96968230..4e24796a 100644 --- a/R/helpers.R +++ b/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,14 +238,12 @@ 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 @@ -263,10 +261,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] } @@ -282,18 +280,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 } @@ -307,33 +305,7 @@ 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) -} - - - -#' 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) - ) +#' c(NA,1:10,rep(NA,3)) |> missing_fraction() +missing_fraction <- function(data){ + NROW(data[is.na(data)])/NROW(data) } diff --git a/R/plot_box.R b/R/plot_box.R index 09ab6c80..97f88f73 100644 --- a/R/plot_box.R +++ b/R/plot_box.R @@ -36,7 +36,7 @@ plot_box <- function(data, x, y, z = NULL) { #' #' @name data-plots #' -#' @returns ggplot object +#' @returns #' @export #' #' @examples diff --git a/R/regression_plot.R b/R/regression_plot.R index a21a4bf8..adb0a471 100644 --- a/R/regression_plot.R +++ b/R/regression_plot.R @@ -43,16 +43,15 @@ 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 %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0 - } + 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} 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 @@ -90,8 +89,7 @@ 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 @@ -111,25 +109,12 @@ 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) -} - -#' Create summetric log ticks -#' -#' @param data numeric vector -#' -#' @returns numeric vector -#' @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)) +#' 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) } #' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots @@ -141,18 +126,18 @@ create_log_tics <- function(data) { #' @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])) } diff --git a/R/regression_table.R b/R/regression_table.R index 5e90a27f..c9fa5138 100644 --- a/R/regression_table.R +++ b/R/regression_table.R @@ -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() } diff --git a/inst/apps/FreesearchR/app.R b/inst/apps/FreesearchR/app.R index 1dbfff57..683b6f23 100644 --- a/inst/apps/FreesearchR/app.R +++ b/inst/apps/FreesearchR/app.R @@ -10,7 +10,7 @@ #### Current file: R//app_version.R ######## -app_version <- function()'250324_1432' +app_version <- function()'250320_1310' ######## @@ -41,58 +41,6 @@ baseline_table <- function(data, fun.args = NULL, fun = gtsummary::tbl_summary, -#' 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 -} - - ######## #### Current file: R//contrast_text.R ######## @@ -408,6 +356,76 @@ columnSelectInput <- function(inputId, label, data, selected = "", ..., ) } +columnSelectInputStat <- function(inputId, label, data, selected = "", ..., + col_subset = NULL, placeholder = "", onInitialize, none_label="No variable selected",maxItems=NULL) { + data <- if (is.reactive(data)) data() else data + col_subsetr <- if (is.reactive(col_subset)) col_subset else reactive(col_subset) + + labels <- Map(function(col) { + json <- sprintf( + IDEAFilter:::strip_leading_ws(' + { + "name": "%s", + "label": "%s", + "dataclass": "%s", + "datatype": "%s" + }'), + col, + attr(data[[col]], "label") %||% "", + IDEAFilter:::get_dataFilter_class(data[[col]]), + data_type(data[[col]]) + ) + }, col = names(data)) + + if (!"none" %in% names(data)){ + labels <- c("none"=list(sprintf('\n {\n \"name\": \"none\",\n \"label\": \"%s\",\n \"dataclass\": \"\",\n \"datatype\": \"\"\n }',none_label)),labels) + choices <- setNames(names(labels), labels) + choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) names(data) else col_subsetr(), choices)] + } else { + choices <- setNames(names(data), labels) + choices <- choices[match(if (length(col_subsetr()) == 0 || isTRUE(col_subsetr() == "")) choices else col_subsetr(), choices)] + } + + shiny::selectizeInput( + inputId = inputId, + label = label, + choices = choices, + selected = selected, + ..., + options = c( + list(render = I("{ + // format the way that options are rendered + option: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + '
' + + escape(item.data.name) + ' ' + + '' + + (item.data.dataclass != '' ? + ' ' + + item.data.dataclass + + '' : '' ) + ' ' + + (item.data.datatype != '' ? + ' ' + + item.data.datatype + + '' : '' ) + + '
' + + (item.data.label != '' ? '
' + escape(item.data.label) + '
' : '') + + '
'; + }, + + // avoid data vomit splashing on screen when an option is selected + item: function(item, escape) { + item.data = JSON.parse(item.label); + return '
' + + escape(item.data.name) + + '
'; + } + }")), + if (!is.null(maxItems)) list(maxItems=maxItems) + ) + ) +} #' A selectizeInput customized for named vectors #' @@ -1458,7 +1476,6 @@ 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"]], @@ -1466,7 +1483,6 @@ data_visuals_server <- function(id, y = input$secondary, z = input$tertiary ) - }) }, # warning = function(warn) { # showNotification(paste0(warn), type = "warning") @@ -2517,7 +2533,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 @@ -2538,7 +2554,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 @@ -2698,17 +2714,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 @@ -2726,14 +2742,12 @@ 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 @@ -2751,10 +2765,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] } @@ -2770,18 +2784,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 } @@ -2795,35 +2809,9 @@ 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) -} - - - -#' 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) - ) +#' c(NA,1:10,rep(NA,3)) |> missing_fraction() +missing_fraction <- function(data){ + NROW(data[is.na(data)])/NROW(data) } @@ -5364,16 +5352,15 @@ 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 %in% c("categorical", "dichotomous") & df_coefs$reference_row & !is.na(df_coefs$reference_row), "estimate"] <- if (x$inputs$exponentiate) 1 else 0 - } + 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} 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 @@ -5411,8 +5398,7 @@ 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 @@ -5432,25 +5418,12 @@ 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) -} - -#' 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)) +#' 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) } #' Ensure symmetrical plot around 1 on a logarithmic x scale for ratio plots @@ -5462,20 +5435,20 @@ create_log_tics <- function(data) { #' @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])) } @@ -5604,8 +5577,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() } @@ -7128,7 +7101,6 @@ ui_elements <- list( shinyWidgets::noUiSliderInput( inputId = "complete_cutoff", label = NULL, - update_on = "change", min = 0, max = 100, step = 5, @@ -7139,8 +7111,7 @@ ui_elements <- list( shiny::helpText("Filter variables with completeness above the specified percentage."), shiny::br(), shiny::br(), - shiny::uiOutput(outputId = "import_var"), - shiny::uiOutput(outputId = "data_info_import", inline = TRUE) + shiny::uiOutput(outputId = "import_var") ) ), shiny::br(), @@ -7177,9 +7148,10 @@ ui_elements <- list( fluidRow( shiny::column( width = 9, - shiny::uiOutput(outputId = "data_info", inline = TRUE), shiny::tags$p( - "Below is a short summary table, on the right you can create data filters." + "Below is a short summary table of the provided data. + On the right hand side you have the option to create filters. + At the bottom you'll find a raw overview of the original vs the modified data." ) ) ), @@ -7434,7 +7406,6 @@ ui_elements <- list( # bslib::layout_sidebar( # fillable = TRUE, sidebar = bslib::sidebar( - shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), bslib::accordion( open = "acc_reg", multiple = FALSE, @@ -7496,7 +7467,7 @@ ui_elements <- list( ), shiny::conditionalPanel( condition = "input.all==1", - shiny::uiOutput("regression_vars") + shiny::uiOutput("include_vars") ) ) ), @@ -7852,12 +7823,11 @@ server <- function(input, output, session) { shiny::observeEvent( eventExpr = list( - input$import_var, - input$complete_cutoff + input$import_var ), handlerExpr = { shiny::req(rv$data_temp) -# browser() + rv$data_original <- rv$data_temp |> dplyr::select(input$import_var) |> default_parsing() @@ -7877,11 +7847,6 @@ server <- function(input, output, session) { } ) - output$data_info_import <- shiny::renderUI({ - shiny::req(rv$data_original) - data_description(rv$data_original) - }) - shiny::observeEvent(rv$data_original, { if (is.null(rv$data_original) | NROW(rv$data_original) == 0) { @@ -7946,17 +7911,6 @@ server <- function(input, output, session) { modal_update_variables("modal_variables", title = "Update and select variables") ) - output$data_info <- shiny::renderUI({ - shiny::req(data_filter()) - data_description(data_filter()) - }) - - output$data_info_regression <- shiny::renderUI({ - shiny::req(regression_vars()) - shiny::req(rv$list$data) - data_description(rv$list$data[regression_vars()]) - }) - ######### Create factor @@ -8177,25 +8131,40 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane - - output$regression_vars <- shiny::renderUI({ - columnSelectInput( - inputId = "regression_vars", + output$include_vars <- shiny::renderUI({ + columnSelectInputStat( + inputId = "include_vars", selected = NULL, label = "Covariables to include", data = rv$data_filtered, - multiple = TRUE, + multiple = TRUE ) + + # shiny::selectizeInput( + # inputId = "include_vars", + # selected = NULL, + # label = "Covariables to include", + # choices = colnames(rv$data_filtered), + # multiple = TRUE + # ) }) output$outcome_var <- shiny::renderUI({ - columnSelectInput( + columnSelectInputStat( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", data = rv$data_filtered, multiple = FALSE ) + + # shiny::selectInput( + # inputId = "outcome_var", + # selected = NULL, + # label = "Select outcome variable", + # choices = colnames(rv$data_filtered), + # multiple = FALSE + # ) }) output$regression_type <- shiny::renderUI({ @@ -8229,16 +8198,16 @@ server <- function(input, output, session) { ## Collected regression variables regression_vars <- shiny::reactive({ - if (is.null(input$regression_vars)) { + if (is.null(input$include_vars)) { out <- colnames(rv$data_filtered) } else { - out <- unique(c(input$regression_vars, input$outcome_var)) + out <- unique(c(input$include_vars, input$outcome_var)) } return(out) }) output$strat_var <- shiny::renderUI({ - columnSelectInput( + columnSelectInputStat( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", @@ -8248,6 +8217,27 @@ server <- function(input, output, session) { names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] ) ) + + # shiny::selectInput( + # inputId = "strat_var", + # selected = "none", + # label = "Select variable to stratify baseline", + # choices = c( + # "none", + # names(rv$list$data)[unlist(lapply(rv$list$data,data_type)) %in% c("dichotomous","categorical","ordinal")] + # # rv$data_filtered |> + # # (\(.x){ + # # lapply(.x, \(.c){ + # # if (identical("factor", class(.c))) { + # # .c + # # } + # # }) |> + # # dplyr::bind_cols() + # # })() |> + # # colnames() + # ), + # multiple = FALSE + # ) }) @@ -8277,7 +8267,7 @@ server <- function(input, output, session) { # shiny::reactive(rv$data_original), # data_filter(), # input$strat_var, - # input$regression_vars, + # input$include_vars, # input$complete_cutoff, # input$add_p input$act_eval @@ -8286,16 +8276,48 @@ server <- function(input, output, session) { shiny::req(input$strat_var) shiny::req(rv$list$data) - # data_tbl1 <- rv$list$data + data_tbl1 <- rv$list$data - shiny::withProgress(message = "Creating the table. Hold on for a moment..", { - rv$list$table1 <- create_baseline( - rv$list$data, - by.var = input$strat_var, - add.p = input$add_p == "yes", - add.overall = TRUE - ) - }) + if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) { + by.var <- NULL + } else { + by.var <- input$strat_var + } + + ## These steps are to handle logicals/booleans, that messes up the order of columns + ## Has been reported + + if (!is.null(by.var) & identical("logical",class(data_tbl1[[by.var]]))) { + data_tbl1[by.var] <- as.character(data_tbl1[[by.var]]) + } + + rv$list$table1 <- + data_tbl1 |> + baseline_table( + fun.args = + list( + by = by.var + ) + ) |> + (\(.x){ + if (!is.null(by.var)) { + .x |> gtsummary::add_overall() + } else { + .x + } + })() |> + (\(.x){ + if (input$add_p == "yes" & !is.null(by.var)) { + .x |> + gtsummary::add_p() |> + gtsummary::bold_p() + } else { + .x + } + })() + + # gtsummary::as_kable(rv$list$table1) |> + # readr::write_lines(file="./www/_table1.md") } ) @@ -8394,9 +8416,9 @@ server <- function(input, output, session) { # .x$model # }) }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err") } @@ -8419,9 +8441,9 @@ server <- function(input, output, session) { purrr::pluck("Multivariable") |> performance::check_model() }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err") } diff --git a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf index ce7c605e..8d5d512d 100644 --- a/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf +++ b/inst/apps/FreesearchR/rsconnect/shinyapps.io/agdamsbo/freesearcheR.dcf @@ -5,6 +5,6 @@ account: agdamsbo server: shinyapps.io hostUrl: https://api.shinyapps.io/v1 appId: 13611288 -bundleId: 9994253 +bundleId: 9974967 url: https://agdamsbo.shinyapps.io/freesearcheR/ version: 1 diff --git a/inst/apps/FreesearchR/server.R b/inst/apps/FreesearchR/server.R index 790d2ddf..30ee43e0 100644 --- a/inst/apps/FreesearchR/server.R +++ b/inst/apps/FreesearchR/server.R @@ -160,12 +160,11 @@ server <- function(input, output, session) { shiny::observeEvent( eventExpr = list( - input$import_var, - input$complete_cutoff + input$import_var ), handlerExpr = { shiny::req(rv$data_temp) -# browser() + rv$data_original <- rv$data_temp |> dplyr::select(input$import_var) |> default_parsing() @@ -185,11 +184,6 @@ server <- function(input, output, session) { } ) - output$data_info_import <- shiny::renderUI({ - shiny::req(rv$data_original) - data_description(rv$data_original) - }) - shiny::observeEvent(rv$data_original, { if (is.null(rv$data_original) | NROW(rv$data_original) == 0) { @@ -254,17 +248,6 @@ server <- function(input, output, session) { modal_update_variables("modal_variables", title = "Update and select variables") ) - output$data_info <- shiny::renderUI({ - shiny::req(data_filter()) - data_description(data_filter()) - }) - - output$data_info_regression <- shiny::renderUI({ - shiny::req(regression_vars()) - shiny::req(rv$list$data) - data_description(rv$list$data[regression_vars()]) - }) - ######### Create factor @@ -485,25 +468,40 @@ server <- function(input, output, session) { ## Keep these "old" selection options as a simple alternative to the modification pane - - output$regression_vars <- shiny::renderUI({ - columnSelectInput( - inputId = "regression_vars", + output$include_vars <- shiny::renderUI({ + columnSelectInputStat( + inputId = "include_vars", selected = NULL, label = "Covariables to include", data = rv$data_filtered, - multiple = TRUE, + multiple = TRUE ) + + # shiny::selectizeInput( + # inputId = "include_vars", + # selected = NULL, + # label = "Covariables to include", + # choices = colnames(rv$data_filtered), + # multiple = TRUE + # ) }) output$outcome_var <- shiny::renderUI({ - columnSelectInput( + columnSelectInputStat( inputId = "outcome_var", selected = NULL, label = "Select outcome variable", data = rv$data_filtered, multiple = FALSE ) + + # shiny::selectInput( + # inputId = "outcome_var", + # selected = NULL, + # label = "Select outcome variable", + # choices = colnames(rv$data_filtered), + # multiple = FALSE + # ) }) output$regression_type <- shiny::renderUI({ @@ -537,16 +535,16 @@ server <- function(input, output, session) { ## Collected regression variables regression_vars <- shiny::reactive({ - if (is.null(input$regression_vars)) { + if (is.null(input$include_vars)) { out <- colnames(rv$data_filtered) } else { - out <- unique(c(input$regression_vars, input$outcome_var)) + out <- unique(c(input$include_vars, input$outcome_var)) } return(out) }) output$strat_var <- shiny::renderUI({ - columnSelectInput( + columnSelectInputStat( inputId = "strat_var", selected = "none", label = "Select variable to stratify baseline", @@ -556,6 +554,27 @@ server <- function(input, output, session) { names(rv$data_filtered)[unlist(lapply(rv$data_filtered, data_type)) %in% c("dichotomous", "categorical", "ordinal")] ) ) + + # shiny::selectInput( + # inputId = "strat_var", + # selected = "none", + # label = "Select variable to stratify baseline", + # choices = c( + # "none", + # names(rv$list$data)[unlist(lapply(rv$list$data,data_type)) %in% c("dichotomous","categorical","ordinal")] + # # rv$data_filtered |> + # # (\(.x){ + # # lapply(.x, \(.c){ + # # if (identical("factor", class(.c))) { + # # .c + # # } + # # }) |> + # # dplyr::bind_cols() + # # })() |> + # # colnames() + # ), + # multiple = FALSE + # ) }) @@ -585,7 +604,7 @@ server <- function(input, output, session) { # shiny::reactive(rv$data_original), # data_filter(), # input$strat_var, - # input$regression_vars, + # input$include_vars, # input$complete_cutoff, # input$add_p input$act_eval @@ -594,16 +613,48 @@ server <- function(input, output, session) { shiny::req(input$strat_var) shiny::req(rv$list$data) - # data_tbl1 <- rv$list$data + data_tbl1 <- rv$list$data - shiny::withProgress(message = "Creating the table. Hold on for a moment..", { - rv$list$table1 <- create_baseline( - rv$list$data, - by.var = input$strat_var, - add.p = input$add_p == "yes", - add.overall = TRUE - ) - }) + if (input$strat_var == "none" | !input$strat_var %in% names(data_tbl1)) { + by.var <- NULL + } else { + by.var <- input$strat_var + } + + ## These steps are to handle logicals/booleans, that messes up the order of columns + ## Has been reported + + if (!is.null(by.var) & identical("logical",class(data_tbl1[[by.var]]))) { + data_tbl1[by.var] <- as.character(data_tbl1[[by.var]]) + } + + rv$list$table1 <- + data_tbl1 |> + baseline_table( + fun.args = + list( + by = by.var + ) + ) |> + (\(.x){ + if (!is.null(by.var)) { + .x |> gtsummary::add_overall() + } else { + .x + } + })() |> + (\(.x){ + if (input$add_p == "yes" & !is.null(by.var)) { + .x |> + gtsummary::add_p() |> + gtsummary::bold_p() + } else { + .x + } + })() + + # gtsummary::as_kable(rv$list$table1) |> + # readr::write_lines(file="./www/_table1.md") } ) @@ -702,9 +753,9 @@ server <- function(input, output, session) { # .x$model # }) }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { showNotification(paste0("Creating regression models failed with the following error: ", err), type = "err") } @@ -727,9 +778,9 @@ server <- function(input, output, session) { purrr::pluck("Multivariable") |> performance::check_model() }, - # warning = function(warn) { - # showNotification(paste0(warn), type = "warning") - # }, + warning = function(warn) { + showNotification(paste0(warn), type = "warning") + }, error = function(err) { showNotification(paste0("Running model assumptions checks failed with the following error: ", err), type = "err") } diff --git a/inst/apps/FreesearchR/ui.R b/inst/apps/FreesearchR/ui.R index 1683c79f..ea40eb8d 100644 --- a/inst/apps/FreesearchR/ui.R +++ b/inst/apps/FreesearchR/ui.R @@ -84,7 +84,6 @@ ui_elements <- list( shinyWidgets::noUiSliderInput( inputId = "complete_cutoff", label = NULL, - update_on = "change", min = 0, max = 100, step = 5, @@ -95,8 +94,7 @@ ui_elements <- list( shiny::helpText("Filter variables with completeness above the specified percentage."), shiny::br(), shiny::br(), - shiny::uiOutput(outputId = "import_var"), - shiny::uiOutput(outputId = "data_info_import", inline = TRUE) + shiny::uiOutput(outputId = "import_var") ) ), shiny::br(), @@ -133,9 +131,10 @@ ui_elements <- list( fluidRow( shiny::column( width = 9, - shiny::uiOutput(outputId = "data_info", inline = TRUE), shiny::tags$p( - "Below is a short summary table, on the right you can create data filters." + "Below is a short summary table of the provided data. + On the right hand side you have the option to create filters. + At the bottom you'll find a raw overview of the original vs the modified data." ) ) ), @@ -390,7 +389,6 @@ ui_elements <- list( # bslib::layout_sidebar( # fillable = TRUE, sidebar = bslib::sidebar( - shiny::uiOutput(outputId = "data_info_regression", inline = TRUE), bslib::accordion( open = "acc_reg", multiple = FALSE, @@ -452,7 +450,7 @@ ui_elements <- list( ), shiny::conditionalPanel( condition = "input.all==1", - shiny::uiOutput("regression_vars") + shiny::uiOutput("include_vars") ) ) ), diff --git a/man/append_list.Rd b/man/append_list.Rd index 880daa0e..990f3a60 100644 --- a/man/append_list.Rd +++ b/man/append_list.Rd @@ -20,8 +20,8 @@ list Append list with named index } \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") +data.frame(letters[1:20],1:20) |> append_list(ls_d,"letters") +letters[1:20]|> append_list(ls_d,"letters") } diff --git a/man/clean_common_axis.Rd b/man/clean_common_axis.Rd deleted file mode 100644 index 175053c9..00000000 --- a/man/clean_common_axis.Rd +++ /dev/null @@ -1,19 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R -\name{clean_common_axis} -\alias{clean_common_axis} -\title{Extract and clean axis ranges} -\usage{ -clean_common_axis(p, axis) -} -\arguments{ -\item{p}{plot} - -\item{axis}{axis. x or y.} -} -\value{ -vector -} -\description{ -Extract and clean axis ranges -} diff --git a/man/create_baseline.Rd b/man/create_baseline.Rd deleted file mode 100644 index 82e6fe1b..00000000 --- a/man/create_baseline.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/baseline_table.R -\name{create_baseline} -\alias{create_baseline} -\title{Create a baseline table} -\usage{ -create_baseline(data, ..., by.var, add.p = FALSE, add.overall = FALSE) -} -\arguments{ -\item{data}{data} - -\item{...}{passed as fun.arg to baseline_table()} - -\item{add.p}{add comparison/p-value} - -\item{add.overall}{add overall column} - -\item{strat.var}{grouping/strat variable} -} -\value{ -gtsummary table list object -} -\description{ -Create a baseline table -} -\examples{ -mtcars |> create_baseline(by.var = "gear", add.p="yes"=="yes") -} diff --git a/man/create_log_tics.Rd b/man/create_log_tics.Rd deleted file mode 100644 index 9baf3940..00000000 --- a/man/create_log_tics.Rd +++ /dev/null @@ -1,20 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/regression_plot.R -\name{create_log_tics} -\alias{create_log_tics} -\title{Create summetric log ticks} -\usage{ -create_log_tics(data) -} -\arguments{ -\item{data}{numeric vector} -} -\value{ -numeric vector -} -\description{ -Create summetric log ticks -} -\examples{ -c(sample(seq(.1, 1, .1), 3), sample(1:10, 3)) |> create_log_tics() -} diff --git a/man/data-plots.Rd b/man/data-plots.Rd index f580b0e0..539381fc 100644 --- a/man/data-plots.Rd +++ b/man/data-plots.Rd @@ -1,13 +1,11 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/data_plots.R, R/plot_box.R, R/plot_hbar.R, -% R/plot_ridge.R, R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R +% Please edit documentation in R/data_plots.R, R/plot_hbar.R, R/plot_ridge.R, +% R/plot_sankey.R, R/plot_scatter.R, R/plot_violin.R \name{data-plots} \alias{data-plots} \alias{data_visuals_ui} \alias{data_visuals_server} \alias{create_plot} -\alias{plot_box} -\alias{plot_box_single} \alias{plot_hbars} \alias{plot_ridge} \alias{sankey_ready} @@ -22,10 +20,6 @@ data_visuals_server(id, data, ...) create_plot(data, type, x, y, z = NULL, ...) -plot_box(data, x, y, z = NULL) - -plot_box_single(data, x, y = NULL, seed = 2103) - plot_hbars(data, x, y, z = NULL) plot_ridge(data, x, y, z = NULL, ...) @@ -62,10 +56,6 @@ ggplot2 object ggplot2 object -ggplot object - -ggplot2 object - ggplot2 object data.frame @@ -81,10 +71,6 @@ Data correlations evaluation module Wrapper to create plot based on provided type -Beautiful box plot(s) - -Create nice box-plots - Nice horizontal stacked bars (Grotta bars) Plot nice ridge plot @@ -99,11 +85,6 @@ Beatiful violin plot } \examples{ create_plot(mtcars, "plot_violin", "mpg", "cyl") -mtcars |> plot_box(x = "mpg", y = "cyl", z = "gear") -mtcars |> - default_parsing() |> - plot_box(x = "mpg", y = "cyl", z = "gear") -mtcars |> plot_box_single("mpg","cyl") mtcars |> plot_hbars(x = "carb", y = "cyl") mtcars |> plot_hbars(x = "carb", y = NULL) mtcars |> diff --git a/man/data_description.Rd b/man/data_description.Rd deleted file mode 100644 index 97a0b0db..00000000 --- a/man/data_description.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/helpers.R -\name{data_description} -\alias{data_description} -\title{Ultra short data dascription} -\usage{ -data_description(data) -} -\arguments{ -\item{data}{} -} -\value{ -character vector -} -\description{ -Ultra short data dascription -} -\examples{ -data.frame( - sample(1:8, 20, TRUE), - sample(c(1:8, NA), 20, TRUE) -) |> data_description() -} diff --git a/man/data_type.Rd b/man/data_type.Rd deleted file mode 100644 index af3716ad..00000000 --- a/man/data_type.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/regression_model.R -\name{data_type} -\alias{data_type} -\title{Data type assessment} -\usage{ -data_type(data) -} -\arguments{ -\item{data}{data} -} -\value{ -outcome type -} -\description{ -Data type assessment -} -\examples{ -mtcars |> - default_parsing() |> - lapply(data_type) -c(1, 2) |> data_type() -1 |> data_type() -c(rep(NA, 10)) |> data_type() -sample(1:100, 50) |> data_type() -factor(letters[1:20]) |> data_type() -} diff --git a/man/limit_log.Rd b/man/limit_log.Rd index 95040600..55bcf3ce 100644 --- a/man/limit_log.Rd +++ b/man/limit_log.Rd @@ -20,8 +20,8 @@ numeric vector Easily round log scale limits for nice plots } \examples{ -limit_log(-.1, floor) -limit_log(.1, ceiling) -limit_log(-2.1, ceiling) -limit_log(2.1, ceiling) +limit_log(-.1,floor) +limit_log(.1,ceiling) +limit_log(-2.1,ceiling) +limit_log(2.1,ceiling) } diff --git a/man/missing_fraction.Rd b/man/missing_fraction.Rd index b3acab98..6182c2a8 100644 --- a/man/missing_fraction.Rd +++ b/man/missing_fraction.Rd @@ -16,5 +16,5 @@ numeric vector Get missingsness fraction } \examples{ -c(NA, 1:10, rep(NA, 3)) |> missing_fraction() +c(NA,1:10,rep(NA,3)) |> missing_fraction() } diff --git a/man/outcome_type.Rd b/man/outcome_type.Rd new file mode 100644 index 00000000..6a674dae --- /dev/null +++ b/man/outcome_type.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regression_model.R +\name{outcome_type} +\alias{outcome_type} +\title{Outcome data type assessment} +\usage{ +outcome_type(data) +} +\arguments{ +\item{data}{data} +} +\value{ +outcome type +} +\description{ +Outcome data type assessment +} +\examples{ +mtcars |> + default_parsing() |> + lapply(outcome_type) +} diff --git a/man/regression_model.Rd b/man/regression_model.Rd index d86453b1..049e24d1 100644 --- a/man/regression_model.Rd +++ b/man/regression_model.Rd @@ -111,7 +111,7 @@ m <- mtcars |> args.list = NULL, vars = c("mpg", "cyl") ) -broom::tidy(m) + broom::tidy(m) \dontrun{ gtsummary::trial |> regression_model_uv(outcome.str = "age") @@ -126,7 +126,7 @@ m <- gtsummary::trial |> regression_model_uv( fun = "stats::glm", args.list = list(family = stats::binomial(link = "logit")) ) -lapply(m, broom::tidy) |> dplyr::bind_rows() +lapply(m,broom::tidy) |> dplyr::bind_rows() } \dontrun{ gtsummary::trial |> @@ -154,15 +154,12 @@ broom::tidy(ls$model) broom::tidy(m) } \dontrun{ -gtsummary::trial |> - regression_model_uv( - outcome.str = "trt", - fun = "stats::glm", - args.list = list(family = stats::binomial(link = "logit")) - ) |> - lapply(broom::tidy) |> - dplyr::bind_rows() +gtsummary::trial |> regression_model_uv( + outcome.str = "trt", + fun = "stats::glm", + args.list = list(family = stats::binomial(link = "logit")) +) |> lapply(broom::tidy) |> dplyr::bind_rows() ms <- regression_model_uv_list(data = default_parsing(mtcars), outcome.str = "mpg", fun.descr = "Linear regression model") -lapply(ms$model, broom::tidy) |> dplyr::bind_rows() +lapply(ms$model,broom::tidy) |> dplyr::bind_rows() } } diff --git a/man/remove_empty_cols.Rd b/man/remove_empty_cols.Rd index 48f96992..690a7c9d 100644 --- a/man/remove_empty_cols.Rd +++ b/man/remove_empty_cols.Rd @@ -18,5 +18,5 @@ data frame Removes columns with completenes below cutoff } \examples{ -data.frame(a = 1:10, b = NA, c = c(2, NA)) |> remove_empty_cols(cutoff = .5) +data.frame(a=1:10,b=NA, c=c(2,NA)) |> remove_empty_cols(cutoff=.5) } diff --git a/man/remove_na_attr.Rd b/man/remove_na_attr.Rd index 41bb4ee2..e5e01f81 100644 --- a/man/remove_na_attr.Rd +++ b/man/remove_na_attr.Rd @@ -16,8 +16,6 @@ data.frame Remove NA labels } \examples{ -ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x, label = NA, attr = "label")) -ds |> - remove_na_attr() |> - str() +ds <- mtcars |> lapply(\(.x) REDCapCAST::set_attr(.x,label=NA,attr = "label")) +ds |> remove_na_attr() |> str() } diff --git a/man/subset_types.Rd b/man/subset_types.Rd index 7b3f3665..bd01efe8 100644 --- a/man/subset_types.Rd +++ b/man/subset_types.Rd @@ -4,7 +4,7 @@ \alias{subset_types} \title{Easily subset by data type function} \usage{ -subset_types(data, types, type.fun = data_type) +subset_types(data, types, type.fun = outcome_type) } \arguments{ \item{data}{data} @@ -21,6 +21,6 @@ Easily subset by data type function } \examples{ default_parsing(mtcars) |> subset_types("ordinal") -default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal" ,"categorical")) +default_parsing(mtcars) |> subset_types(c("dichotomous", "ordinal")) #' default_parsing(mtcars) |> subset_types("factor",class) }