From 12f095c3a08c3dc17204bf3c38b191089cb74a74 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 5 Nov 2024 08:26:05 +0100 Subject: [PATCH 001/158] WIP --- R/tm_g_scatterplot.R | 51 ++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index d093a4fad..c8be54170 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -343,6 +343,7 @@ ui_g_scatterplot <- function(id, ...) { teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"), teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), + uiOutput(ns("brush_filter")), DT::dataTableOutput(ns("data_table"), width = "100%") ), encoding = tags$div( @@ -997,9 +998,55 @@ srv_g_scatterplot <- function(id, plot_r = plot_r, height = plot_height, width = plot_width, - brushing = TRUE + brushing = TRUE, + click = TRUE ) + output$brush_filter <- renderUI({ + states <- get_filter_state(filter_panel_api) + brushed_states <- Filter( + function(state) state$id == "brush_filter", + states + ) + if (!is.null(pws$brush())) { + actionButton(session$ns("apply_brush_filter"), "Apply filter") + } else if (length(brushed_states)) { + actionButton(session$ns("remove_brush_filter"), "Remove applied filter") + } + }) + + observeEvent(input$remove_brush_filter, { + remove_filter_state( + filter_panel_api, + teal_slices( + teal_slice( + dataname = "ADSL", + varname = "USUBJID", + id = "brush_filter" + ) + ) + ) + }) + + observeEvent(input$apply_brush_filter, { + plot_brush <- pws$brush() + merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) + filter_call <- str2lang(sprintf( + "merged_data <- dplyr::filter(merged_data, %1$s >= %2$s & %1$s <= %3$s & %4$s >= %5$s & %4$s <= %6$s)", + plot_brush$mapping$x, plot_brush$xmin, plot_brush$xmax, + plot_brush$mapping$y, plot_brush$ymin, plot_brush$ymax + )) + eval(filter_call) + + slice <- teal_slices(teal_slice( + dataname = "ADSL", + varname = "USUBJID", + selected = merged_data$USUBJID, + id = "brush_filter" + )) + set_filter_state(filter_panel_api, slice) + }) + output$data_table <- DT::renderDataTable({ plot_brush <- pws$brush() @@ -1008,7 +1055,6 @@ srv_g_scatterplot <- function(id, } merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) - brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) numeric_cols <- names(brushed_df)[ vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) @@ -1028,6 +1074,7 @@ srv_g_scatterplot <- function(id, } }) + teal.widgets::verbatim_popup_srv( id = "rcode", verbatim_content = reactive(teal.code::get_code(output_q())), From d348719310195efeccfc71aed55221a51b54a57e Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 5 Nov 2024 11:10:15 +0100 Subject: [PATCH 002/158] brush_filter to the module --- R/module_brush_filter.R | 99 +++++++++++++++++++++++++++++++++++++++++ R/tm_g_scatterplot.R | 85 +++++------------------------------ 2 files changed, 110 insertions(+), 74 deletions(-) create mode 100644 R/module_brush_filter.R diff --git a/R/module_brush_filter.R b/R/module_brush_filter.R new file mode 100644 index 000000000..61e2259b2 --- /dev/null +++ b/R/module_brush_filter.R @@ -0,0 +1,99 @@ +ui_brush_filter <- function(id) { + ns <- NS(id) + div( + uiOutput(ns("brush_filter")), + DT::dataTableOutput(ns("data_table"), width = "100%") + ) +} + +srv_brush_filter <- function(id, brush, data, filter_panel_api, selectors, table_dec) { + moduleServer(id, function(input, output, session) { + selector_list <- isolate(selectors()) + + output$brush_filter <- renderUI({ + states <- get_filter_state(filter_panel_api) + brushed_states <- Filter( + function(state) state$id == "brush_filter", + states + ) + if (!is.null(brush())) { + actionButton(session$ns("apply_brush_filter"), "Apply filter") + } else if (length(brushed_states)) { + actionButton(session$ns("remove_brush_filter"), "Remove applied filter") + } + }) + + observeEvent(input$remove_brush_filter, { + remove_filter_state( + filter_panel_api, + teal_slices( + teal_slice( + dataname = "ADSL", + varname = "USUBJID", + id = "brush_filter" + ) + ) + ) + }) + + observeEvent(input$apply_brush_filter, { + plot_brush <- brush() + merged_data <- isolate(teal.code::dev_suppress(data()[["ANL"]])) + filter_call <- str2lang(sprintf( + "merged_data <- dplyr::filter(merged_data, %1$s >= %2$s & %1$s <= %3$s & %4$s >= %5$s & %4$s <= %6$s)", + plot_brush$mapping$x, plot_brush$xmin, plot_brush$xmax, + plot_brush$mapping$y, plot_brush$ymin, plot_brush$ymax + )) + eval(filter_call) + + slice <- teal_slices(teal_slice( + dataname = "ADSL", + varname = "USUBJID", + selected = merged_data$USUBJID, + id = "brush_filter" + )) + set_filter_state(filter_panel_api, slice) + }) + + output$data_table <- DT::renderDataTable({ + plot_brush <- brush() + if (is.null(plot_brush)) { + return(NULL) + } + + isolate({ + foo1(brush, selector_list) + }) + + dataset <- isolate(teal.code::dev_suppress(data()[["ANL"]])) + brushed_df <- teal.widgets::clean_brushedPoints(dataset, plot_brush) + numeric_cols <- names(brushed_df)[ + vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) + ] + + if (length(numeric_cols) > 0) { + DT::formatRound( + DT::datatable(brushed_df, + rownames = FALSE, + options = list(scrollX = TRUE, pageLength = input$data_table_rows) + ), + numeric_cols, + table_dec + ) + } else { + DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) + } + }) + }) +} + +#' get axis dataname, varname and ranges +foo1 <- function(brush, selector_list) { + lapply(names(brush()$mapping), function(selector) { + list( + dataname = selector_list[[selector]]()$dataname, + varname = brush()$mapping[[selector]], + values = unlist(brush()[paste0(selector, c("min", "max"))]) + ) + }) +} diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index c8be54170..4834c76c4 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -343,8 +343,7 @@ ui_g_scatterplot <- function(id, ...) { teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"), teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), - uiOutput(ns("brush_filter")), - DT::dataTableOutput(ns("data_table"), width = "100%") + ui_brush_filter(ns("brush_filter")) ), encoding = tags$div( ### Reporter @@ -1002,78 +1001,16 @@ srv_g_scatterplot <- function(id, click = TRUE ) - output$brush_filter <- renderUI({ - states <- get_filter_state(filter_panel_api) - brushed_states <- Filter( - function(state) state$id == "brush_filter", - states - ) - if (!is.null(pws$brush())) { - actionButton(session$ns("apply_brush_filter"), "Apply filter") - } else if (length(brushed_states)) { - actionButton(session$ns("remove_brush_filter"), "Remove applied filter") - } - }) - - observeEvent(input$remove_brush_filter, { - remove_filter_state( - filter_panel_api, - teal_slices( - teal_slice( - dataname = "ADSL", - varname = "USUBJID", - id = "brush_filter" - ) - ) - ) - }) - - observeEvent(input$apply_brush_filter, { - plot_brush <- pws$brush() - merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) - filter_call <- str2lang(sprintf( - "merged_data <- dplyr::filter(merged_data, %1$s >= %2$s & %1$s <= %3$s & %4$s >= %5$s & %4$s <= %6$s)", - plot_brush$mapping$x, plot_brush$xmin, plot_brush$xmax, - plot_brush$mapping$y, plot_brush$ymin, plot_brush$ymax - )) - eval(filter_call) - - slice <- teal_slices(teal_slice( - dataname = "ADSL", - varname = "USUBJID", - selected = merged_data$USUBJID, - id = "brush_filter" - )) - set_filter_state(filter_panel_api, slice) - }) - - output$data_table <- DT::renderDataTable({ - plot_brush <- pws$brush() - - if (!is.null(plot_brush)) { - validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) - } - - merged_data <- isolate(teal.code::dev_suppress(output_q()[["ANL"]])) - brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) - numeric_cols <- names(brushed_df)[ - vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) - ] - - if (length(numeric_cols) > 0) { - DT::formatRound( - DT::datatable(brushed_df, - rownames = FALSE, - options = list(scrollX = TRUE, pageLength = input$data_table_rows) - ), - numeric_cols, - table_dec - ) - } else { - DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) - } - }) - + # todo: + # validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) + srv_brush_filter( + "brush_filter", + brush = pws$brush, + data = output_q, + filter_panel_api = filter_panel_api, + selectors = selector_list, + table_dec = table_dec + ) teal.widgets::verbatim_popup_srv( id = "rcode", From 947f1513f4daf9801ddb61ab36f5638440bd0e78 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 5 Nov 2024 11:45:28 +0100 Subject: [PATCH 003/158] encapsulate brushing functionality --- R/module_brush_filter.R | 38 ++++++++++++++++++++++++++++++-------- R/tm_g_scatterplot.R | 2 -- 2 files changed, 30 insertions(+), 10 deletions(-) diff --git a/R/module_brush_filter.R b/R/module_brush_filter.R index 61e2259b2..5878b000c 100644 --- a/R/module_brush_filter.R +++ b/R/module_brush_filter.R @@ -1,7 +1,12 @@ ui_brush_filter <- function(id) { ns <- NS(id) div( - uiOutput(ns("brush_filter")), + tags$h1(id = ns("title"), tags$strong("Selected points:"), class = "text-center font-150p"), + teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), + div( + actionButton(ns("apply_brush_filter"), "Apply filter"), + actionButton(ns("remove_brush_filter"), "Remove applied filter") + ), DT::dataTableOutput(ns("data_table"), width = "100%") ) } @@ -10,19 +15,36 @@ srv_brush_filter <- function(id, brush, data, filter_panel_api, selectors, table moduleServer(id, function(input, output, session) { selector_list <- isolate(selectors()) - output$brush_filter <- renderUI({ - states <- get_filter_state(filter_panel_api) + observeEvent(brush(), ignoreNULL = FALSE, { + if (is.null(brush())) { + shinyjs::hide("title") + shinyjs::hide("apply_brush_filter") + shinyjs::hide("data_table") + } else { + shinyjs::show("title") + shinyjs::show("apply_brush_filter") + shinyjs::show("data_table") + } + }) + + states_list <- reactive({ + as.list(get_filter_state(filter_panel_api)) + }) + + observeEvent(states_list(), { brushed_states <- Filter( function(state) state$id == "brush_filter", - states + states_list() ) - if (!is.null(brush())) { - actionButton(session$ns("apply_brush_filter"), "Apply filter") - } else if (length(brushed_states)) { - actionButton(session$ns("remove_brush_filter"), "Remove applied filter") + if (length(brushed_states)) { + shinyjs::show("remove_brush_filter") + } else { + shinyjs::hide("remove_brush_filter") } }) + + observeEvent(input$remove_brush_filter, { remove_filter_state( filter_panel_api, diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 4834c76c4..73d0d5122 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -341,8 +341,6 @@ ui_g_scatterplot <- function(id, ...) { teal.widgets::standard_layout( output = teal.widgets::white_small_well( teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), - tags$h1(tags$strong("Selected points:"), class = "text-center font-150p"), - teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), ui_brush_filter(ns("brush_filter")) ), encoding = tags$div( From 842ba1b4b738599830e722021389e3f8138bacd2 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 5 Nov 2024 12:35:49 +0100 Subject: [PATCH 004/158] fix add filter state --- R/module_brush_filter.R | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/R/module_brush_filter.R b/R/module_brush_filter.R index 5878b000c..59af61d1c 100644 --- a/R/module_brush_filter.R +++ b/R/module_brush_filter.R @@ -43,8 +43,6 @@ srv_brush_filter <- function(id, brush, data, filter_panel_api, selectors, table } }) - - observeEvent(input$remove_brush_filter, { remove_filter_state( filter_panel_api, @@ -68,10 +66,11 @@ srv_brush_filter <- function(id, brush, data, filter_panel_api, selectors, table )) eval(filter_call) + # todo: when added another time then it is duplicated slice <- teal_slices(teal_slice( dataname = "ADSL", varname = "USUBJID", - selected = merged_data$USUBJID, + selected = unique(merged_data$USUBJID), id = "brush_filter" )) set_filter_state(filter_panel_api, slice) From a9c9b0681e1205394793d036d858fead0328e430 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 6 Nov 2024 14:11:13 +0100 Subject: [PATCH 005/158] scatterplot + data_table --- R/module_brush_filter.R | 120 ---------------------------------------- R/tm_data_table.R | 69 ++++++++++++++++++++++- R/tm_g_scatterplot.R | 6 +- 3 files changed, 69 insertions(+), 126 deletions(-) delete mode 100644 R/module_brush_filter.R diff --git a/R/module_brush_filter.R b/R/module_brush_filter.R deleted file mode 100644 index 59af61d1c..000000000 --- a/R/module_brush_filter.R +++ /dev/null @@ -1,120 +0,0 @@ -ui_brush_filter <- function(id) { - ns <- NS(id) - div( - tags$h1(id = ns("title"), tags$strong("Selected points:"), class = "text-center font-150p"), - teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), - div( - actionButton(ns("apply_brush_filter"), "Apply filter"), - actionButton(ns("remove_brush_filter"), "Remove applied filter") - ), - DT::dataTableOutput(ns("data_table"), width = "100%") - ) -} - -srv_brush_filter <- function(id, brush, data, filter_panel_api, selectors, table_dec) { - moduleServer(id, function(input, output, session) { - selector_list <- isolate(selectors()) - - observeEvent(brush(), ignoreNULL = FALSE, { - if (is.null(brush())) { - shinyjs::hide("title") - shinyjs::hide("apply_brush_filter") - shinyjs::hide("data_table") - } else { - shinyjs::show("title") - shinyjs::show("apply_brush_filter") - shinyjs::show("data_table") - } - }) - - states_list <- reactive({ - as.list(get_filter_state(filter_panel_api)) - }) - - observeEvent(states_list(), { - brushed_states <- Filter( - function(state) state$id == "brush_filter", - states_list() - ) - if (length(brushed_states)) { - shinyjs::show("remove_brush_filter") - } else { - shinyjs::hide("remove_brush_filter") - } - }) - - observeEvent(input$remove_brush_filter, { - remove_filter_state( - filter_panel_api, - teal_slices( - teal_slice( - dataname = "ADSL", - varname = "USUBJID", - id = "brush_filter" - ) - ) - ) - }) - - observeEvent(input$apply_brush_filter, { - plot_brush <- brush() - merged_data <- isolate(teal.code::dev_suppress(data()[["ANL"]])) - filter_call <- str2lang(sprintf( - "merged_data <- dplyr::filter(merged_data, %1$s >= %2$s & %1$s <= %3$s & %4$s >= %5$s & %4$s <= %6$s)", - plot_brush$mapping$x, plot_brush$xmin, plot_brush$xmax, - plot_brush$mapping$y, plot_brush$ymin, plot_brush$ymax - )) - eval(filter_call) - - # todo: when added another time then it is duplicated - slice <- teal_slices(teal_slice( - dataname = "ADSL", - varname = "USUBJID", - selected = unique(merged_data$USUBJID), - id = "brush_filter" - )) - set_filter_state(filter_panel_api, slice) - }) - - output$data_table <- DT::renderDataTable({ - plot_brush <- brush() - if (is.null(plot_brush)) { - return(NULL) - } - - isolate({ - foo1(brush, selector_list) - }) - - dataset <- isolate(teal.code::dev_suppress(data()[["ANL"]])) - brushed_df <- teal.widgets::clean_brushedPoints(dataset, plot_brush) - numeric_cols <- names(brushed_df)[ - vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) - ] - - if (length(numeric_cols) > 0) { - DT::formatRound( - DT::datatable(brushed_df, - rownames = FALSE, - options = list(scrollX = TRUE, pageLength = input$data_table_rows) - ), - numeric_cols, - table_dec - ) - } else { - DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) - } - }) - }) -} - -#' get axis dataname, varname and ranges -foo1 <- function(brush, selector_list) { - lapply(names(brush()$mapping), function(selector) { - list( - dataname = selector_list[[selector]]()$dataname, - varname = brush()$mapping[[selector]], - values = unlist(brush()[paste0(selector, c("min", "max"))]) - ) - }) -} diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 4a2be49d4..598b531cb 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -187,7 +187,8 @@ srv_page_data_table <- function(id, variables_selected, dt_args, dt_options, - server_rendering) { + server_rendering, + filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -262,7 +263,8 @@ srv_page_data_table <- function(id, if_distinct = if_distinct, dt_args = dt_args, dt_options = dt_options, - server_rendering = server_rendering + server_rendering = server_rendering, + filter_panel_api = filter_panel_api ) } ) @@ -283,6 +285,10 @@ ui_data_table <- function(id, tagList( teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")), + div( + actionButton(ns("apply_brush_filter"), "Apply filter"), + actionButton(ns("remove_brush_filter"), "Remove applied filter") + ), fluidRow( teal.widgets::optionalSelectInput( ns("variables"), @@ -307,7 +313,8 @@ srv_data_table <- function(id, if_distinct, dt_args, dt_options, - server_rendering) { + server_rendering, + filter_panel_api) { moduleServer(id, function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names")) @@ -338,5 +345,61 @@ srv_data_table <- function(id, do.call(DT::datatable, dt_args) }) + + observeEvent(input$data_table_rows_selected, ignoreNULL = FALSE, { + if (is.null(input$data_table_rows_selected)) { + shinyjs::hide("apply_brush_filter") + } else { + shinyjs::show("apply_brush_filter") + } + }) + + observeEvent(input$apply_brush_filter, { + if (is.null(input$data_table_rows_selected)) { + return(NULL) + } + # isolate({ + # foo1(brush, selector_list) + # }) + dataset <- data()[[dataname]][input$data_table_rows_selected, ] + # todo: when added another time then it is duplicated + slice <- teal_slices(teal_slice( + dataname = "ADSL", + varname = "USUBJID", + selected = unique(dataset$USUBJID), # todo: this needs to be parametrised or based on join_keys + id = "brush_filter" + )) + shinyjs::hide("apply_brush_filter") + set_filter_state(filter_panel_api, slice) + }) + + states_list <- reactive({ + as.list(get_filter_state(filter_panel_api)) + }) + + observeEvent(input$remove_brush_filter, { + remove_filter_state( + filter_panel_api, + teal_slices( + teal_slice( + dataname = "ADSL", + varname = "USUBJID", + id = "brush_filter" + ) + ) + ) + }) + + observeEvent(states_list(), { + brushed_states <- Filter( + function(state) state$id == "brush_filter", + states_list() + ) + if (length(brushed_states)) { + shinyjs::show("remove_brush_filter") + } else { + shinyjs::hide("remove_brush_filter") + } + }) }) } diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 73d0d5122..771b47901 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -341,7 +341,7 @@ ui_g_scatterplot <- function(id, ...) { teal.widgets::standard_layout( output = teal.widgets::white_small_well( teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), - ui_brush_filter(ns("brush_filter")) + teal::ui_brush_filter(ns("brush_filter")) ), encoding = tags$div( ### Reporter @@ -1001,10 +1001,10 @@ srv_g_scatterplot <- function(id, # todo: # validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) - srv_brush_filter( + teal::srv_brush_filter( "brush_filter", brush = pws$brush, - data = output_q, + dataset = reactive(teal.code::dev_suppress(output_q()[["ANL"]])), filter_panel_api = filter_panel_api, selectors = selector_list, table_dec = table_dec From 4b987a66139fff1d6da6002c81cbf8d8067e46ef Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 15 Nov 2024 09:37:04 +0100 Subject: [PATCH 006/158] WIP swimlane POC --- R/tm_p_swimlane.R | 57 +++++++++++++++++++++++++++++++++++++++++++++ inst/swimlane_poc.R | 49 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 106 insertions(+) create mode 100644 R/tm_p_swimlane.R create mode 100644 inst/swimlane_poc.R diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R new file mode 100644 index 000000000..d1a668fa2 --- /dev/null +++ b/R/tm_p_swimlane.R @@ -0,0 +1,57 @@ +tm_p_swimlane <- function(label = "Swimlane Plot Module", dataname, id_var, avisit_var, shape_var, color_var) { + module( + label = label, + ui = ui_p_swimlane, + server = srv_p_swimlane, + datanames = "synthetic_data", + server_args = list( + dataname = dataname, + id_var = id_var, + avisit_var = avisit_var, + shape_var = shape_var, + color_var = color_var + ) + ) +} + +ui_p_swimlane <- function(id) { + ns <- NS(id) + shiny::tagList( + teal.widgets::plot_with_settings_ui(ns("myplot")), + teal::ui_brush_filter(ns("brush_filter")) + ) +} + +srv_p_swimlane <- function(id, data, dataname, id_var, avisit_var, shape_var, color_var, filter_panel_api) { + moduleServer(id, function(input, output, session) { + output_q <- reactive({ + within(data(), + { + p <- ggplot(dataname, aes(x = avisit_var, y = subjid)) + + ggtitle("Swimlane Efficacy Table") + + geom_line(linewidth = 0.5) + + geom_point(aes(shape = shape_var), size = 5) + + geom_point(aes(color = color_var), size = 2) + + scale_shape_manual(values = c("Drug A" = 1, "Drug B" = 2)) + + scale_color_manual(values = c("CR" = "#9b59b6", "PR" = "#3498db")) + + labs(x = "Study Day", y = "Subject ID") + }, + dataname = as.name(dataname), + id_var = as.name(id_var), + avisit_var = as.name(avisit_var), + shape_var = as.name(shape_var), + color_var = as.name(color_var) + ) + }) + + plot_r <- reactive(output_q()$p) + pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r) + + teal::srv_brush_filter( + "brush_filter", + brush = pws$brush, + dataset = reactive(teal.code::dev_suppress(output_q()$synthetic_data)), + filter_panel_api = filter_panel_api + ) + }) +} diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R new file mode 100644 index 000000000..7ae420979 --- /dev/null +++ b/inst/swimlane_poc.R @@ -0,0 +1,49 @@ +pkgload::load_all("teal") +pkgload::load_all("teal.widgets") +pkgload::load_all("teal.modules.general") + + +# Example data +data <- within(teal_data(), { + library(dplyr) + library(tidyr) + + set.seed(123) # Setting a seed for reproducibility + # Define possible maximum study days + .possible_end_days <- c(50, 60, 70) + + # Create sample data + synthetic_data <- tibble(subjid = c(1:15)) |> + rowwise() |> + mutate( + max_study_day = sample(.possible_end_days, 1), + study_day = list(seq(10, max_study_day, by = 10)) + ) |> + unnest(study_day) |> + group_by(subjid) |> + mutate( + assigned_drug = sample(c("Drug A", "Drug B"), 1) + ) |> + ungroup() |> + mutate( + response_type = sample(c("CR", "PR"), n(), replace = TRUE), + subjid = reorder(as.character(subjid), max_study_day) + ) |> + select(-max_study_day) +}) + +app <- init( + data = data, + modules = modules( + tm_p_swimlane( + dataname = "synthetic_data", + id_var = "usubjid", + avisit_var = "study_day", + shape_var = "assigned_drug", + color_var = "response_type" + ) + ), + title = "Swimlane Efficacy Plot" +) + +shinyApp(app$ui, app$server) From 089a06ab05d88c5bdd8bcab2781239a6855f078a Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 15 Nov 2024 09:39:12 +0100 Subject: [PATCH 007/158] add data_table module to the app --- inst/swimlane_poc.R | 1 + 1 file changed, 1 insertion(+) diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R index 7ae420979..f08269830 100644 --- a/inst/swimlane_poc.R +++ b/inst/swimlane_poc.R @@ -35,6 +35,7 @@ data <- within(teal_data(), { app <- init( data = data, modules = modules( + tm_data_table(), tm_p_swimlane( dataname = "synthetic_data", id_var = "usubjid", From e0969daf71dff56b536f610bf3993f2555ccd491 Mon Sep 17 00:00:00 2001 From: "27856297+dependabot-preview[bot]@users.noreply.github.com" <27856297+dependabot-preview[bot]@users.noreply.github.com> Date: Fri, 15 Nov 2024 08:54:50 +0000 Subject: [PATCH 008/158] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/tm_a_pca.Rd | 8 ++++---- man/tm_a_regression.Rd | 8 ++++---- man/tm_data_table.Rd | 8 ++++---- man/tm_file_viewer.Rd | 4 ++-- man/tm_front_page.Rd | 4 ++-- man/tm_g_association.Rd | 8 ++++---- man/tm_g_bivariate.Rd | 8 ++++---- man/tm_g_distribution.Rd | 8 ++++---- man/tm_g_response.Rd | 8 ++++---- man/tm_g_scatterplot.Rd | 8 ++++---- man/tm_g_scatterplotmatrix.Rd | 8 ++++---- man/tm_missing_data.Rd | 8 ++++---- man/tm_outliers.Rd | 8 ++++---- man/tm_t_crosstable.Rd | 8 ++++---- man/tm_variable_browser.Rd | 8 ++++---- 15 files changed, 56 insertions(+), 56 deletions(-) diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index ac4f506ba..1de282e2f 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -149,13 +149,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlY4AygCCjNUtonG6fYPDpKJKAL5dSmioYyp57BX+GboAvJtBuBt8QiKju0fCYuvdlbqkMIlQiagEqRs3ugpgAAoAwv2fB2u7xiOz2jzCpGYGkSolQcAIV3ewIy0HgoM+EyGYmmALeSNEcBEGlBBKJpBhcIReKRugI+SItAIYlBWhYtCg9BEiTpDKZokRNKRKVBKWAwAxAyxI0+AF0ZaUqWAALKCRj8GQAj5gfqiURQYSkTUYxj0KAQL5EVBGsBYNBwT5dQU3OSAp2VUnw8j8UGKlVqjV4LU6vUGh2ut0wA20SJ6XYOFzU53hmkmWjUciMUEAOUcABlc4nHc6Nl0urQTLp2CoM+pNDobLZytdRIUIKx+uh2EsACT1Uo9gmMHSdOZKMCzGVAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkoGlUAQsn9kboFGAAApeQYEsFIvGJGGZNLRUjMDRpUSoOAERF4ym5B56YEEqajMm4jmiOAiDQwkVi47M1nsjl4gglJYEMQwrQsWhQegiE5K2gqzZC+V1TLU3LAYB8kYCsAvF5VNkEgBCAFksABpLAARjJ+LAgwA4q48H7nAB5AI+ACaBP6xuRcnJ8bqktZ5H4MMdYFdHu9vr5QdjSeTMCOtDiPPsTlcFI5iaNyJMtGo5EYMIAco5RgLa3U4wm-v1+rQTLp2CpW+pNDobLYakjRGUIKxBuh2GhUAASFpVDebkWMHR9WZKMAzF5AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 85b3c578d..c85255c48 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -195,13 +195,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJUInVEtWiolYQp+fn1FD0cH7rCmBYcHuYieJD+WzObweqBIoj06xSiTCpGYGkSolQcAIrze5xS0HgBz+ozBSxxulhIg0BwpmNIaIxWNJZN0Hy+P10fwAyt9abotCxaJ8RIgSRDmQR8kRaAQxISwIJUEEANZwUXM840jRwfhyhXK1V4JlkmDCTSROG6ABiAEEADKc5zg9WVEy0ULag4OFxG85dMlyJ04u4PUQdA4IpEounozHYsl42AWomDNXMzWkak81Exxlisms75y7mUjP8xiC+h7EWGvM4iVSmX7dZlisiRL16UnFLAYDJsZgAC6A9KjMIJAIYI5YDs1UC8DIfzkAZ9b3THt+Y4sqfVJuoZpEnqcjpX51d7p16xt9tctcqfpx97vSy6XVoJl07BU5Cj2jgNls5RnKIhQQKw1roOwMwACT1KU0GwowOidBMShgOMA5AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkoGkGhIGqJRFYIIjkcjqFB6HBqDCFGAsHBsWI8SQqWCkUScagSKI9MDMmloqRmBo0qJUHACISicjMg8uboqVNRky-hLdJyRBoYarRcdhaLxcq6iSyRTgVSAuStbotCxaKSRIhFSz9QQSksCGJKWAAEIAWSwAGksABGB365GajRwfgen3+oMh0Owo60OIygBig1GAWczITploUUjMIcLiVEv6yrkOYlWJxol6MJ5fIF2pFYtLRKlsBlcpGCrw7bD5vVwPDLd1A6JhvJHrNatIluttrE9v7juVztd7uBVsYNvoIhOLtobqeuWAwB70zALxeVTbYEGAHFXHhZWAswANJlvrCDLwvuRKwnQc50LE0H2feNQxgJMUyLJxs2AuoTHzMDdHTTNXDXZFyzLUtcP6fpaBMXR2BUchm20OAbFsGokVEMoIFYQZ0HYNBUAAEhaKp2I4zlGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index 3d105c6c0..24a713d2b 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -110,13 +110,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQ20onG6vaJKAL5dSmioAyp57BX+GboAvAtBuPN8QiL9K5vCYnPdlbqkMMkZiUH0IofHx1ostFDXYomicCIacPzLunQttzuxyGvwIczAAGU4KhuBgADIUCQFBR4XQoqEwngAdVo-GRqJRAAU4EEeAiIEj8ijSkSSbCcXiqQTIag4ARaGIUV0gbo5Osjnc8YkWBIdn8+qR2AQ0JoSL8UQBJLAKiH2Z4iXQAYRlVggXPmlW5vKUXVoJl07BU5GYlh0Nls5SOokKEFYAEF0OxJgASeqlH3vRg6TqjJRgEYAXSAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYBlcmlwvQRIjkcitCxaFBsWI0qI4CINHB+DC6KJSOwpuNgQRfmAAnZHD4AJp+HwKPC6AWOAKOABCACk+QKqgLRZLpYK5X47M5FbKwIMAOKuJXs5wADQFcjkYKReP4xxYEmhwLpDIIaE0JBhAqZ9mJIm8TqsEGNfzq-UDSn6tBMunYKnIzEsOhsthqSNEZQgrEG6HYaFQABIWlUs9nyYwdH1ZkowDMXkA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index cf3b5cdd3..a1617b9db 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -54,8 +54,8 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXSSfTLCME2Z4dgBGRQgAX1KlNFRslRj2dJyvXQBeJuTGviERUVbdLuExBogMjNIYfxNaEX8tWjhImWHR0ZVUQVJ-VE9YvrpRUmWV0ZMian4ZPtFWA7gYPOm4BrBRWFQZqZ6FPF1tggBrKBSPrfPy8ASDcRSCBqajfOS4RrHX4QCRXG7ke6fJ7fV4wd5wSaPUQAejxBKJIgwqFR3xSf0BwLaoLg3HB3TEkmksnhiJGyN0pAAHqR0bcsY9nuSPsSyW8ZVThaQ6b91Iy9MywGCBj0uTCeWAEUjjoJGNQQWBYqRSKhRIgSSSTB5JEQtI7ZfxGIIJKT1vR9rE4PwSQAFIiMLz+uCGAAiRAIgngZEMADFwzBPIYAMqoOAEWhTAieKwQcSofgmb7GjKlFa13SlUoF3TsFTkZiWHQ2WxpfmieIQVgAQXQ7GqABJBLQUhPRDIdIxSmUlGAygBdIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 35b1c3e9d..7da5acb05 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -85,8 +85,8 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXUY4AEdBWiz2CDFSYmoiRkUIDIBBABEAZQAZH0y6pvTdT1JGdjbGlIUweC8kwdsIulFSdkHqwTjywd0AXl1BgDlnertdLhhBgbAk-1EiQUYCOCXVwdFWMli4TQJdUbBKgF9KgCsiFX8ANZwViiRJhcbGfhwExQYSkfwEfi0UQEfy-f5AkHAaDwUFJOQAXTcZCg9BE-gAjC0khgTMx4OwAJIQExEFa6AgzMDVA5rMAAITGKTscAAHqR2ZzZrzBoL3pUvGS4P4AEzUsK0+lwdgAAwAwkRqIIYFUKTrJVy9TKwLUhbp9YbjVUVebVpyAKwYd0pABsGB9chSDqNJt0AGZXRyuTy8Hy5XIFaTyWH1V5NbBtczWRbBq5Y4MAGJ2kXinNgADi1oAEmNKkpFeSVKh5i1JtMOoM7Em9BTrrtu5TcB2wF2lboVX2G8qVUOqnzRyJw5OB2GlHXoOgWioYjM50l2UlZxk+EIRKJ2SfhGJdxkMqQYP46SR4agoFIb7eMo8oFDGP5yKWbofp+GSDIyMCoOUXhkLoKisowMCeFYEB9mBEoEFAVQSGyjxZBgBwdCBfIAPJxDIsEsuUiGaCQqFgHqmG6Nhui4XA+FgIRt6Bpxd7dueqxTv4TbzEeIE-kiNHQAEXgSPxuhVnYACyjTRvwEnIdw8lKc05S6KI8QQKw-ayUxOEyHo+hMAAfEKPGmEQRCkBAjliGWAAadHIrsjymPkUz2Y5znkNaACasHnmRelwMQED8AFTkubZc6fvpRCRP4ww-mE7IOC4nGVBk3Fzt+v7sjJogACSxBSXL1LAqCLtU6B0BhklJRkrIuYwZVvpVqDRs1tCtch8UyEl660CYujsCo5DMJYOg2LYaRzvpKisE1-VoKgFV5Ck20VaIMg6BUSgfEoYAfASQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index c239f6051..c6a64f695 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -159,13 +159,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz4wlBRJhUjMDSJUSoOAEPn8+kpOZ6AkKMCjdXEumK3SiOAiDTC-WG0jS2Xy8a6yoA+gG4XqgDKBrlpF0e0YXPoIkQWqt1thRBuYmFHq9IkSgeDCxSwGA6s1YB+kN0lrAAAUAWQtbp1XZWLKc3nqoF4NmwC9tdb6SbXXB+A6M1nSH6ddaTLRQvXhYsAIKPR2uNv8t6KuRVxUeikiqBi0ISybmuUK3XK2Cq3Mawat6u1o0EvdmmXL-26232tVgZ2m90scNiX14U+KqMEEMEsNQb1wSP5INvmMMjjBNtyTFM00zKBy1KPMCzgIswDsEtGQoFsK3HZ9+UPbtLyQuBS1Qndq10GBhE0SIN22ZwJ2rDsuwbAk+wHIdq1HEd-VHLouloIUNlUSVNB0GxbHKOlREKCBWF7dB2H2AASeooXQOT9UYHROiUJElDAJEfiAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkoKJREQCLQwlYIIjkciGiYYZk0tFSMwNGlRKg4ARiSTkZkHnpgQowFNRtywUjWbpRHARBoYSKxccGUyWUK6tQoPRRTDuQFRUzSLotCx8fQRIh+X95boCCUlgQxDCdYw9SITubaJbNsaTSCoMBgNzedyXi8BW7kcy1c4ABr83TcrCDLyuPCRsBeADyjgAcg4AJoR71YACy2bAAQcgzsgwAjAWi9HSwAmAt+Ox2ABifPj3IAQrmsABpLB1sD9QNyANuyWauD8VVgaOxo2C+UmWhRCcwpuDUYBVzzkmD1nD111G3Q4GU6m06WM4Pbtm5DlTn14A-Isfi4Evi+yp8kxXK6hT9VStqupKlChqPteJJmhaVrAjadpwA60EuhBrKZJ63ojK2fojoGwaFmGBYznGVTcsmaaZgWgx5pWxalhWbaFrRgz9iRYANs2rasZ2PZ9tyu4mvuKF1O+K5cmA3G9ixX7IjARy0HEnL2E4zg4QuS6iboa4bluAlPvxui7v0-S0OS7AqOQ57aHANi2DUSKiGUECsIM6DsGgqAACQtFU7keSKjA6H0sxKGAMwvEAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index cce2711a0..7d36cffb9 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -228,13 +228,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VuqGnu4lhpMwaiaKocAITxeLxS0Hg7wUYGmUP2zxBojgIg070RyNIfwBQI2IMq1Cg9CRkLAAGUkYDSLotHcCSJELCcbiCPkiLQCGJ3tTGPd6CJEszWezRMUMsBgFCYWAALpSuRw3EvNEUuD8YnECwM+G4ky0UIq94AMQAggAZEmuLWVLoguWM1jvFKfULfdQY-6A4G4sGwPQ7CWDTUKpUonbBt1Yz0K-GEvx+0nklFcnl0wMK3QCtkcnZJ2lwfkszPClJi-0DKEy22WxUJ8iquOCVBBADWcFTCpgwk0kV9umNZuc8rTOr1dd7pvNjKtjMrIMYRGyiRM6jglJ2jq+P3DHsnu3BPdLber6NRNcx26reIJRLjZOPOd5cHpeB3lQzQs5NIf+cFYhFQRL0IBtKsqDkGNb6nGdisACh4gsOEFjv2O7Wi8M4vG0i7LquHwbq6Z7YlW3oQnGkqgUeFInui+GRri0bXroUK3hR94ps+F7pgW77Zp+fJvr+xbioBZbAWhYHoghUJ2NUgTwGQsEvPBo59hOVYoVOzxdF0tAmLo7AqOQm7aI8ci2OUzyiIUECsEa6DsEsAAk9SlA5iKMDonRKLMShgLMUpAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgbpSDA0hI0vRtCxaGE4L8BnVdFEYZk0tFSMwNGlRKg4ARMdjsZkHnpgQowFNRoywVjqaI4CINDDOdzjmSKVTqdjqFB6FyYYyAlyKaRdFpUeKRIhWX8RboCCUlgQxDDFYw0fQRCdtbRdU9csBgIzmYyXi85GyNXU+XK4PwpUyAOKuPDqkUmWhRD0wgBig1GAVc7Ox-WpToDrDxuQJUSJ6gF5MpAbqtNg9N0tpGLP9sddsp5wLdJMFOfLovFkoZYBl-IVSuNcFVZZdmrNFv1nZNWp1Yi24WtxemYAdiYbFf5oZb0YAGmqF7oYEdaHFCxGo85nS6gyHPcCD9Hc7p43Hj3VGEQCmkDrr5cD8YTiVmhdf8-AvTtXsRRrd9dFA0ls2FDUxQlagvTbOUO0NZVuw3PtR3NPVgQNI0RwHcdMinJkS3tR17xAytyHPIsmSwABZdCT2DZddEvGMNVvOp52pboX3UOAwM-dNv0g38G3-Qtp1LCjFyQ6sqLE+s+1g5taMQnlcNQntZOxTDBxw4c4FNMdLUnG0SJnOddLkjRWMZLwAHlHAAOQcABNJiNVPVj2OvLibz+fp+loExdHYFRyG-bQMTkWwaixUQyggVhBnQdg0FQAASFoqkyrLOUYHQ+lmJQwBmF4gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 0b7cae9be..78fb42d9c 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -148,13 +148,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLpSEGrUuvxQpFC6cAAesKgiSlc3BsZc1AD6b1A2r2utyMugA7rRSAALFTsP6REBKXS6HyhD7IxihJQAX0UECUaFQaJUEL8ECRf3KcMRuj4QhEonKdGapKRSNIMG+El+oVIGPogk01mprMuPO+WhYlKB3wevPUpG+olQcAILJFrL+0Hg5X8KNEEWF6tEcBEGnKxtNCqVKvYEoxUHoIm+BEhRFoBDEQz1-jkkX8AAVYtwMAAZCgSKE+w1I3Ei2O6XG42gmXTsFTkZiWHQ2WwIsm6UTQiCsUbodgEgAk3kileNjB0jFxWKUYCxAF0gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLoAwgAiAJLjJ7r8UKRQunAAHrCoIkp3DwbGXNQA+l8oDZPvdHkZdAB3WikAAWKnYQMiICUul0ozO4wAMj9shjsUoAL6KCAAKyIKn+AGs4KxRIiwbYIfw4CYoMJSP8CPxQgR-uTKTS6cBoPB6UC5ABdJRKLQsUQARlxBFhFIIYn+ojgIg0cH4fggaLljFoUHoIi5qto6vFYOAwH8+Kx-klksiBCGoywwyK-hOAHlHAA5BwATV9YHGzgAGv45HJcKjdFqdeR+OUg44sc6ICSlGhULiVDCDWigeUkUm+EIRKJytXhGJS2jdKQYP8JIDQqQTfRBJprEmW7du-9jRWwf8Xj31JzRKg4B6h8PbmDRXpko7Mc68MvhynF6RygeNJqF0vDSvhyq1WJysbTea4Jbb7aHvatwSwK73Z6AOKuHguj+AAQsMWAANJYAqcYJnuK4nmm5SgeBUEwbul5XmiMAcrQ7wbroABioxYlGiaYVhJi0M8erlMRpGuBRw4klecFMcmM4PGOLATlx07MKe86Ls2V5AuuyFgE6ETwWiVHUOQjDlHJClnsJMktsadbJJpCrkVhLY4fJeEiHsqTqSxK5sVeEiMEQgioNxinJECU7PDOgnniJK5ibABGfjuemUbQ8kyEpwUqUJF76Ua8r3vKunqdhuH4aZLjmfBFlohZJIkrQJi6OwKgKbO2iDPGugopeojwhArCjOg7AFgAJN4kTNVqjA6IwJKEkoYCEpKQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 4c34a0f6f..e055c1e4c 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -184,13 +184,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRKUSYVIzA0iXJcHmQtpKWg8AR2zAXyuqyV+KpIg06v1CtIctQCpptPO9MZzI1AGUmSbdFoWLQGSJEDqzlbKgR8kRaAQxOrXYx3fQRIl-YHg6JihkbostQKHqVFUsVngNQdGEc5Cifb7jRo4Px1YsCMtvb7zjBhJpInpEQAxACCABl7c5C7XKiZaKEy+r213XEX8f9aQXdbpQuqJVKZab5YqJ+cVbBmxqUzXi07DYiSyvzWu+3SGUyK2BHQbSC63R64F7Bev8TGgyHEWGI1GP3GEyCJNNUuVM7nTBYwA2PYUBgfNez7Y9hxZKCBQQ2t62oRsRBHTtu3Q30ByHctWzw8daynSclSnLouloExJhUchl20aljjKMZREKCBWDbdB2HBAASepSiEqlGB0TpgSUMAATuIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkGqJUCRRHBEcjkdQoPQ4NQYQowFgxDiIHjdAAFHqkUSUsFIwlY2n04GZNLRUjMDRpbFwAgEwnIzIPPTAylTUZsv6S3R4kQaGFqsXHUXi5Uq3TE0nkuVgAJk7W6LQsWgkkSIJUcg0EEpLAhiGHWxi2+giE6u2jup65YDAeUjRVgF4vKp6sAAIQAslgANJYABMbN0lK8AHlHAA5BwATUpcjk7INyK1Gjg-ApCeTaczeH1KpgR1ocVlugAYoNRgFnJWq6ZaFE6zD+4PXE7Cf0VRW27oojC+QKhTrUGKJSrpbAe+Hpq259WLRrgTWtzvl4SjWSG+b1aQrTa7XAHSfR7oXW6PcCvR9P1f0DBFMlDI9I2jWNfjNZwAA0s0pLBBi8VwwHLEcqyvSdTRQtDHW-DtqE0bspwHIcsINExx1wvsKNnKsF0lZi6mY-p+loExdHYFRyE3bR8XLao-lEMoIFYQZ0HYNBUAAEhaKpZLkvFGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 5c1c306f7..ae01d8861 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -280,13 +280,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLpSEGrUuvxQpFC6cIWwqCJK84sGxlzUAPpbUDabC0tGugDutKQAFirsR5EgSrrZno1w7NOipMStjEUEDeAGEAPIAJh2unBEKUAF8gUo0KhoSobn5gXMztUnq9dHwhCJRNVCcIxJi3m9SDB9hJ9mEFuQOq1SJSqW9qFB6HBZsl-ABlAhMmTrIikGG3IhdMQRfEcwq4s77FYldSkBmoOAEdkct5HaDwar+WFyrF63SiXnaiXJK0iDSa7W6i26Lk8vm6QXWjS6LQsWjckSIM2uqkEKUyknJf2MQP0ET7CPSggUo7AYAmyH+AC6OciOv8xAsZX8glQi16-jkclw8td9ptcH4xuaJbw9YtMGEmnWemSADEAIIAGQFzjr5tdJlohWb1WHY9cU45QIttc7uiG2MWKuKzEdoi1hZXVINsH7XrApo7p7ejd9dp9GqPzs3HPdvNbAuffoDQbgENbzDN5kyjapY3jRMwNTURHjODMszhMA8wLPw23CPAr3LSs4GrDc7ypB9yBbfkwBwqAq2AkDu2oXsRAXUdx0nEDTFnedByY5cwzXPUCItf4iEYfZ6G3I49zVQ9jxdDlzyNMibxYhtfyfB0X2k98qU-T1vTUv84wAoClLDGCxAg-8EzgJNI1gmTXXTTNr2zFD800jlCzAAAFLkyFLMA7FYLU-LsdwFngXysKLEhMMiMsK0ovCwF4njjOUtSON0AA5RwRxHVKux7Wg+0Ypd8r1Gc51I3RF3HTTkqpfi9VEWgAC8rNEpVd1VA91LfQi5MvJDQzSm1qmIp0T1Y7Tv1-SDDOGkybLMmMLOgpa4IcoaXLQqL21i8j4qomsyo5YiMri3CFtdWj6MvGqJzctjKpK2rCPqt5Go5RgiEufYTHUWJOqgCSeomuz9TOQ1Bqc5CTstFT4bUsHHumsifz0ubLKMx7TOjfSoKs3H4MWRCYdzfNdA87yoAi-aAqCyL-NCmkKFIfC4fvZ8Muy3KOYJQris40rHoqjL7rqzdPvDFo-oB20d2B7r1WR-rIYvVtFM04ixufFWpu5L80dm1bAKugT1vMgzLOslM0wQxyb1Qyn0Op2mr3pxK6eZ8K2aSqWLTOqqebyx6bqKhiheYkX2Kq8W3sl+teKBIFaBMXR2BUZl1W0L4a10F4sVEe4IFYId0HYFEABJvEiKurUYHRAQRJQwHhHMgA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLoAwgAiAJIAypO6-FCkULpwhbCoIkorawbGXNQA+vtQNnur60a6AO60pAAWKuznkSBKutmejXDsEDEpGIrUYigg3wAgtN5gAZQ7ZaFwpQAX3BACsiCoTr1WKI3tdbLd+HATFBhKQTgR+KECCdMdjcaJgNB4PjznIALpKJRoVAIlSPPwQ5bXarvL66PhCESiarS4RiYXfb6kGAnCQnMKrcgdVqkZUq77UKD0ODUar+eYEHUyHZEUhTJ5YghiCKSo2FcXXE6bErqSmiVBwAiGo3fc6svTJfxI2HukXh3Sic0hx3JFMiDRa4Ohj1J3Qms0WmNgeapjS6LQsWimkSIBMFlUEZ1dMTVauMWv0ERU1uu9nXYDAWMw+NgTmcyJ5sCQgDirjwun8ACEALJYADSWAAjGVVxvtwAmfxyOS4fNJzNpuD8S2zheNptSim0HbR3QAMUhsPmzgviYFiYtCFLe1Tfr+riAUa4JJuel66EMoprL6xTMNmQYhmG4aRrAH6jsieAId816VhmFaBrm2FJkW5r3uWWaOp23b1k+TYti67bJMxdZwH2nGDmsw4EeOk7Tn4D6LpEB5bru+5gOusknmAZ4Ac+yYUWBpaKdue5EdB4YwK+77gT+f5qc+wGgXeyQQX+xG6LB4bwQZIJEIwJz0Eh5yof6GFUQ5uHwPecZseGpHphpjE5lhDnGqadGlgxaZVjWvENvp6kcW2crcWlPZ8dlA7UQW5zCbOY7+GJcXNhJ85ScuCmHnJS4yce8lYJCkwNf4WDOHOswAPIAHJ6U5TYuepEVabow2OLCsIWU2RnUJoJm2WZ-41VZM12VBE0IZN4W0AAXnxXneihfroZRsUGRG1xRiFlWZQWEXVBFMV5vdKq0SWjXJZWPEFRlS0FkVXGpV2vH8TlBJCSOFWEWJugzvV8k6S1qk1dNNmNejr3LcZIimZBYNJjteN7Q540qkdRqMEQdwnGSrqRT510Bl9JUPWsT2lqFhPhRRH0UdzNV-fRIvA6xQtJhDuVQyxhX9kqZWI4LKMzpjynSWAnXdR1-VDaNp7029ml43NC3k4ZxMfntttGpTpP2T9tPfOb3wgiz6ixJdUC+Td4s-UF+FI+OTtRSl5HRZh33qZLSXS-lstR97quKzLKsCfDUDlZrU6oxJOsdV1PX68bI1jV7wuMTN1uLTVK1rSTG1k9tIG7ZtNOHfmTnguCtAmLo7AqLqAbaP8Z66J8IqiC8ECsJC6DsHyAAk3iRBvKaMDoYKokoYAopyQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index ec2645a59..ecd6434f4 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -188,13 +188,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLpSEGrUuvyBULpwAB6wqCJK+aSFRrpc1AD6VVA2lQUGxgDutKQAFirszeEgSrq6xOakjFGiHXkFGCbM8H4QY2O0-AnjfmAAIq54uv4AYlhhx2AAknYX-s4AyndgAAq3R-4A4ucfYAByABlngAhQ7hfwAxzPACC7zkuFG6wkRB0jAg8DI2xM6lIREYq3W6wI7AATOEyboKQBGcm03Q0+nhBkk+GIwnUKD0ODUWaJYn+ACyJBYBF6rGeWDgqEE9DoBH8qUJrLW6w5EAkgigUga2JgtFiWJxeIJhJ2DIAzOFLbprdbqUyrUzlabdByuTztvywJ8ZDAoMp5b8ABLckQBiVEP0WUJgRXrZ3rVBEaUczQkT3sAAc1oAbAB2cI5gAM4QALAX6SX6QyqRWqQyixgc+EAJwJsYsOCFPnsc0AVgrfb7FqLDL7Rb7rep5oppZH5Kb4Wz7cy-FQGfNGFLC4rJIwNa34Ub1sbFMbFcbk90jYbW5X-Dg9FIGb3zIwdsPlMXX4-25-C7-PdfzjONRG4MQ5maRZljgE0Ni2RIqUQccERVMYJjINgGk2bYwJgcpYLZIldgOZ4zmeG5nkeZ43meb5nkBEEwUuSEYThVCXVEWgAC89ESFCiLGdxynUPikhcIiV1YLtGFwvFSHYPCCNJUci0QEkiw08IUN0YSORCbYHBcOQVx0CBBDEpSRHYL1RD9ahqGeeB+FoQQYGeDlGCkZ4SDobIFW0qs9NEwzkhXAh-RCBy4AQ3QrNg4kjOccITmhAEHhSQLwmCgzEiSlcvH9TRSDiRI0TxGB2B0qkiyrDTwqIURSF5XSIAqqqq0zOqixXVBGCIEwem2crGEqnStMrEClAAX1SAArIgVAaABrOBWFEQYClsWoFqW1b1pNXaIBWtbdgwqYZmec7pjEZ5NgCxEjpOjh-DAkRRGeN7bt+e7Yw43Qnv2s6iEmG6Pt+L7wfCL1fu2fxrtYbD+AVVJUiUNB11qFQehNZptiGRE+CEd7tiJ4QxDguoYAaCQGlECKghkcoiFIP0LuKSmxjdbk4bAB4GfIRhmefNnpmKMJBN0LQWFoTkScSOgms59ZmgaEophxOnUDgfk0JdeZqmgeBeeuy68ElwlRG5HXn0SK2RA0LWdeVl1udyRJ-Aea2NClmW5bERAJb1-Xxl6RaQha6Xpn9hpRXDinmmAYB4ZBzCzYAXXTlcQ-tm2YozfxOygZ4JDXZ4HyfB7g-1mBhE0AjQpcf6Q7GPEH3cWKkublvBuKfPElS9LXGrpULd0bOVYKNXig1x3RG13WW4N-1YDE17wKhsexkG6hBaxfVBadxel9dTkeY9vnvefKPZdlOBA-NkfTSjlqU9BxHfu7kO49oCPtml6gFlY5h1-gnAoSd17vX8JncEhBU5TA-sjP6W91i5w0P3HY-hSK-HIr8SivxqK-For8eivxGK-FBM8VivxYRVxProWuu9aANzyskFBE9LZX1wlfI+LtTRu15l7B218-Z31EA-L++sf5-0SDfGO0iwHVAgWASG0D07Q12IVMgPRxS-GIE1KGlw+oDR6CjSRnEr4YK9Fo4qujYH6Oas8Yxg1SB0JPow+uIhG7JRQa3Rg7cMFd18aYWgfdYqDwyuwsecZR56ymhAVItATC6HYCoQWOJtCwRMroEYKpRD9AgKwaE6B2AYwACTeHCOUq2jBUSpGmkoMA0105AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLoAwgAiAJIAypm6-IFQunAAHrCoIkolpGVGulzUAPr1UDZ1pQbGAO60pAAWKuwd4SBKuroAgtn5ADK9uoxzi1Oz2Vj5y6tb+UoAvqkAVkQqrQDWcKyiY6W2TfxwJlDCpK0E-LSiBK1nF2ut2A0Hgdw6cgAukolGhUMsVIM-BBph0EsVSrgNnwhCJROiccIxMjptNSDBWhJWr9AuRGDUiOTAoxaBUSaTptQoPQ4NR0f58gRaTIGaRdDBmaywhsOVoWLRuXj0XRRKR2RzUaVWpVSMwNNTUHACOqNZqGqC9Il-GsFtKUabSaJeUaxYknSJ9aJDcaZQ7OdzefywPlnRpdHKWYqxIg7X6OQQhucQvjEhGFfQRJ9E7Rk-cGsBgNb5rawJDIXIsfa47p3S64Px0T6wDMAOKuPC6fxYGaZdvhAXOAAa-grvr9MHetBqlqSLkr1emREYz3cDcSDjnY4dJlZ9fRADEZgt8q4qw7Un7R2eOR1tRVdeoPl6jSbTR0LUG5ttY3Gd9Q6eif50gaL5bqaXI8nyVrBqGYoUPwqDnGQogxngYEahGKa6E2AAKMzdgAsjkYSds2ABqBS5HYI7zguCZJmI6JytQghwFmDHgqUBZFt+paQuEuH4TMRHZCR1oUfkVE0dhfhgHhhFieRlHUWAchXguNawXu0G5AAcmRzh2LoxjOLp2S6AA8vuuh6dkjiZHYuQWbpP7VhO-5TiI6Ibqe1bqXGtZhm6sEgT614OhBgbQSGHpimmUYoa5cb0TmjGpvKUbsalnH5oWzb7P4Zb+dWgXkGuMnWm2ikzGRR7VdkACaNHoRy7maNO3nJLR1ZLiu2mzs43W-ru5WHsevlxhe55blN0xTakqS0CYujsCodKPtocA2LYkz2qIIwQKwMzoOwcIACTeOE51OowOiMKkhxKGAhyQkAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index a758b5a85..42a0303c7 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -113,13 +113,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEulIQatS6cKGwqCK6-FCkUEr9gwbGXNQA+iNQNsMDUGO6AO60pAAWKuwz0SBKurme3r6toqTE1ESM9fu6UPz8k9CiS2YWmtahtnsQBwehwFE3RE7FEnkm3BIEnYX2iJkuV3YIlKGxhtgAVLlzLQTOwAIzRDAABgArIS8QB2OTUgC6SwAcgBBW7-W4AXyUtx8tBeRl03NEtxg5xYvOMwoIos5v35QVEwDpfOK6ES7AF0Xuj2e9QOEtFCqWyp6HD1jFEGoeTygoh1ulN8uA-gIrGo-hpiuM1owJnUpER9uAjsILrdNNtAaDUhYoaWXp9Gn9IrNgf8UcYofqbJu0HQSxUaz8MpmNR2QoEwjENT4QhEokLf10pBgkxgPNEKgk0wWcxl9XqON0atUzEsOhs31uok2EFYjPQ7DQqAAJN4Negl2DGDprkoORAwGyaUA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEugDCACIAkgDKzbpwobCoIrr8UKRQSiNjBsZc1AD6k1A2E6NQ07oA7rSkABYq7IvRIEq6uZ7evhBipMTURIz1pwCCrZ0AMuuML+8nui9YnU+-06SgAvvUAFZEFRzADWcFYogOq1sRmGcBMUGEpDmBH4tFEBDmUJh8MRwGg8CRizkAF0lEo0Kh1iptn4IKdFjVDr8+EIRKIanzhGJ2adTqQYHMYATRCoJAtVssObp6vVaCZdOwVORmJYdDZbMcVaI9hBWE90OwmQASbzRW2iGQ6B5gpRgUG0oA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index ff738de8d..194a8f14f 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -151,13 +151,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ugDCAPIATHHV9RVNdcDACmCojLQwLKyJANZwrJ0AumONonAAjokiEOwQjETZ7LV1cooQAL7bAFZEKkMjosUZtlmHx8OsZ9cQJxydG52lL814up3dvf1PnS2bggWhYokaBHyRwIYkS0xEGjg-HYoJ6UHoIkSkOhYnOQXaHzq4zGpQI7E6AAVqFAyG9vmA7KxUHA6Z07Iw4IF4LSwFttko0KhGio8uSIJUUroALz+DK4Fp8IQicEyxXCXEtSqkGCJIiCUh0GRnTWVXR6g20GSJVHS3R0USkMWm52yoKJMKkZgaOHMskml2ummwPQywlvf0u+FwDS2qPe0S+p0Bl3U+hwPyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruJSBLArzAE1J5MIJAIrLAglQQWGgLk8vLFcqcfI-FtnRHY5ZeAjAZgwk0kRDugAYgBBAAyWecU5nppMtFCSNth5Prmnye2FZfLsnEYIgTgEiIPS-SQ2jK9qOuugbuqEnrqKQPrRkmFYpNA8CLp2nznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbYZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4mc7YdKhRLdiSbGcQJvEXpUm5YbQO62g4LhgZUb4Brppr6W+2zbLQJi6OwKjYdB2hwDYtjlOWoiFBArAHug7CChxgi0KUnnTIwOiMNsOxKGAOxjEAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdRkaWpQBfRQgAKyIVNIBrOFZRCtzbfP44EyhhUjSCflpRAjTB4bGJ4Gh4Scy5AF03CAWNNK0WUTSoflFqNoOxdgAxWmpyRnZ1hxcVVEaDiHEywGACjAnWaUJOJyq6wwl1IREYcgxShujFEbQIJSGBDEaVEcBEGjg-HY2NoUHoIhWBNoRKOuQhUJhcIRpnUy2xdweT0xECUILaKmK7FqIVyugAvDLwrhpXwhCJcQrVcI3tK6qQYGkiIJSHQZJNdXVdEaTbQZNcWPLdHRRKQpRBLR7FVA0tFSMwrqJUHACG7PZ7Mq9HRymrC8Baw6TyaRHYng8tA8HQ2HPdQ6WSo2AAmS07oaXSRIgocr3dmPfjCWJHWX6XBGQ3WeF2dCY1yqiGOQBxVx4XRQgBCAFksABpLAARihGOrtY9qYp-AL9SHVfj2ZgS1ocT0Cve9WaAWcy5XdRMtCilMdp-Prhrtb6b93civdbCcAkaOZbh7UYR1nVdXc6kyH0oj9XkSSDftX2zCNYGPUduy6OMkLDW9vhkR1cJ+eDMwgz1+SbW5vxXetmUbBUbmoQRWxolkpk7SEMNjeEqn5AASNdyH4L9SNXYt1woxjmKZVjwQ4zkwG40tbn4sTBOE7C9wPI9HQBF9r3fbMDI9IzdAMvo+loExdD+VR-U0HQbFsGoa1EMoIFYep0HYEFeMEWgqh80lGB0dEeiUMBuhOIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index a9a1354cd..0d1175647 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -159,13 +159,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6UhBq1Lr8UEG6cAAesKgiSgVFRrpc1AD61VA2VYVQBsYA7rSkABYq7M0RIEq6ujCkBCyinRNTM2OmRIy67Fq6KroEfoSs1OG6-lpheEcoMIf+Uiz+crajEOPjk9OMosDAWgC633NQ4hM6lIK3Yrxmnx+3zS4wAvktwe9Pv5UIxaDAWKwGgBrOCsfy-OaiTwNEQQdgQRhELpghbve5KWFpABWRBUOLxoiG7VstVZ7NxrC5-IgHI4-kRpwiErpUvOqPRmLFdzSSjQqDmKl6fie+XaiT1QVwCIEwjEBr4QlCOuedRgDVIDQIVNEoiCITgNttumowTgeSS-gAwi7ZnZgpU8EtbSUDc0GqVSMwNA1RKg4Dto97mtB4AaZW8pVnbcSRBoDaWM460xmvd7nr76P782AAMr+qu6LQsWgRuCIcLF70EPpsgjmpLdtF9p2j2jjrnNZFgSUE74RTN7A5nY5y-ywK5gG6MFXG3X18aVjRwfgGzcEfaH493M8X54wYSaCp6JIOFyvt9dBWfgZBvA0-2cAC3xMWgSjApIADEAEEABlW1cc9vRhLCoOeeIknjRNk2rdNM0w20c1gH9zlXKNyOeK9SArDsUxrMjAJ9P0A3OdsyyYqdew9Ac6I4kcxwnLsexnMT5zEbkgmXWjfg3XYH23aUwBOQ8Dx3I84FuMB7lw+tGPg84tJEwCP2oL8RANZC0MgodbRguDb0Q1D0Oc3RsNtXyfKWNI0loEw1hUchiO0T17l0R5LwGCBWCQ9B2HVAASbwInS4lGB0Rg0nhCAwFhb4gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6AMIAIgCSAMpZuvxQQbpwAB6wqCJKpeVGulzUAPoNUDb1ZVAGxgDutKQAFirsHREgSrq6AII5BQAyfbqM80tKAL5pAFZEKq0A1nCsouM9tk38cCZQwqStBPy0ogStewfHp8DQ8GcdcgAukolGhUCsVEM-BAZh1EiUerhpro+EJQvDUcIxNCZjNSDBWg8CIwiKJREEQnAcbiZtRgnBqPD-FkSWT7ME6nhkTTKvCOq0qqRmBpWqJUHACNSabCer89El-OtFuFudLRAyJaR4eqRCKxRKpdLafTGQqwAUNRpdFoWLQOXBECqYUbcQRhvsCGJ4TbGHbKY93bRPf8esBgIqFsqwIDARFRIJ6OqtUkzBZNNYAbops6XbjaPxeU0AIQ29Bxc5BCIqYYyIaiCLUIgSIPcdgARjkEUl-hyZTg4V0-gACgB5Ap5AAaGgHw7Hk+opH8cjSuZp7lIgkYEHYcpDQTkwHzlUBK9X2yROZdOs1cH4TLAWRHjgAcg4AJpO1co+60Wry5IuBeX5EIw1zuHeSQOIBqpGiYtCVLe8IAGKzIsBSuJeNKnlhQHSvEST8oKwoPPq3aYbiHRyveSqflelrJro156uKZFfnS9AMveFq6lqPp+iIjpcuRNJuh6XpJHx9oBmJe5QGGEYbNGsaMQmSbwqmlgZhcWYwS6R4rKWtQcBMugvBgtwaCBDZNi21DtsuulGuum7bruFZQAeR4no5uLnj5MxMeQEGDuazgTrRuYwD+f7Iah6G4bmcEIcFKFoRhubYbimWnmkaS0CYujsCo5DEdoVLLjpzqiKMECsLM6DsGCAAk3gRM16qMDojBpJsShgJsgJAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index b36911ed4..752c4c83d 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -104,13 +104,13 @@ if (interactive()) { \describe{ \item{example-1}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEulLhsrr8UKRQunAAHrCoIkoLSwbGXNQA+jtQNtuLy0a65aQFKuwnUSBKuro+tKJ7b4wfL7owpAILE+VwBQMYNQgr1KRHgUKuMLhfxMUFotzM1C+KLRBQxfwAwgB5ABMXyJxKUAF9FBAlGhUF8VGi-FD5hcmo8-nwhCJPilucIxCzXq9ioctCxaFB6CJDkwiKVRDJhSLXtRpXBMSl-AA1SXSkS6eWKmT+P6vGkWpQ02gmXTsFTkZiWHQ2WzPVmiO4QVgAQXQ7HpABJvFFg0rGDpGDTKUowJSALpAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEugDCACIAkgDK07pwAB6wqCK6-FCkUEp0TCwcgSFhcIoQu-sGxlzUAPo3UDZKL3e65aQFKuwvURASl0ugAgrNFgAZT6McFQ4Fg2Z2OzOGHg5GuCAAXyuXSIKkewTgrFE-z2UFsRh2cBMUGEpEeBH4tFEBEeeIJRJJwGg8FJLzkAF0lEo0KhPipaKQ-BAQR8UgCEXwhCJRE1lcIxDKQSDio8tCxaFB6CJHkwiKVRDJtTqQdRjXBqE1-AA1Q3G7bmy0yfwIkFXf1KK60Ey6dgqcjMSw6Gy2IGy3SiX4QVig9DsMUAEm8USzVsYOkYVyxSjAWMFQA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} + \if{html}{\out{}} + \if{html}{\out{}} } } } From c5c744d677a7c3811a4d912171cbc4187e5fea23 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 15 Nov 2024 11:54:21 +0100 Subject: [PATCH 009/158] remove unneeded --- R/tm_data_table.R | 34 +--------------------------------- inst/swimlane_poc.R | 1 - 2 files changed, 1 insertion(+), 34 deletions(-) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 640e9dd07..583707288 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -283,10 +283,7 @@ ui_data_table <- function(id, tagList( teal.widgets::get_dt_rows(ns("data_table"), ns("dt_rows")), - div( - actionButton(ns("apply_brush_filter"), "Apply filter"), - actionButton(ns("remove_brush_filter"), "Remove applied filter") - ), + div(actionButton(ns("apply_brush_filter"), "Apply filter")), fluidRow( teal.widgets::optionalSelectInput( ns("variables"), @@ -370,34 +367,5 @@ srv_data_table <- function(id, shinyjs::hide("apply_brush_filter") set_filter_state(filter_panel_api, slice) }) - - states_list <- reactive({ - as.list(get_filter_state(filter_panel_api)) - }) - - observeEvent(input$remove_brush_filter, { - remove_filter_state( - filter_panel_api, - teal_slices( - teal_slice( - dataname = "ADSL", - varname = "USUBJID", - id = "brush_filter" - ) - ) - ) - }) - - observeEvent(states_list(), { - brushed_states <- Filter( - function(state) state$id == "brush_filter", - states_list() - ) - if (length(brushed_states)) { - shinyjs::show("remove_brush_filter") - } else { - shinyjs::hide("remove_brush_filter") - } - }) }) } diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R index f08269830..770d495be 100644 --- a/inst/swimlane_poc.R +++ b/inst/swimlane_poc.R @@ -2,7 +2,6 @@ pkgload::load_all("teal") pkgload::load_all("teal.widgets") pkgload::load_all("teal.modules.general") - # Example data data <- within(teal_data(), { library(dplyr) From 67d4a5c309b1d3006d5f45df259bd01062b0b58d Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 19 Nov 2024 11:45:14 +0100 Subject: [PATCH 010/158] wip --- R/tm_p_swimlane.R | 69 ++++++++++++++++++++++++++++----------------- inst/swimlane_poc.R | 32 ++++++++++++++++----- 2 files changed, 68 insertions(+), 33 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index d1a668fa2..249abbdc4 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,15 +1,12 @@ -tm_p_swimlane <- function(label = "Swimlane Plot Module", dataname, id_var, avisit_var, shape_var, color_var) { +tm_p_swimlane <- function(label = "Swimlane Plot Module", geom_specs, title, color_manual, shape_manual, size_manual) { module( label = label, ui = ui_p_swimlane, server = srv_p_swimlane, - datanames = "synthetic_data", + datanames = "all", server_args = list( - dataname = dataname, - id_var = id_var, - avisit_var = avisit_var, - shape_var = shape_var, - color_var = color_var + geom_specs = geom_specs, title = title, + color_manual = color_manual, shape_manual = shape_manual, size_manual = size_manual ) ) } @@ -22,30 +19,44 @@ ui_p_swimlane <- function(id) { ) } -srv_p_swimlane <- function(id, data, dataname, id_var, avisit_var, shape_var, color_var, filter_panel_api) { +srv_p_swimlane <- function(id, + data, + geom_specs, + title = "Swimlane plot", + color_manual, + shape_manual, + size_manual, + filter_panel_api) { moduleServer(id, function(input, output, session) { - output_q <- reactive({ - within(data(), - { - p <- ggplot(dataname, aes(x = avisit_var, y = subjid)) + - ggtitle("Swimlane Efficacy Table") + - geom_line(linewidth = 0.5) + - geom_point(aes(shape = shape_var), size = 5) + - geom_point(aes(color = color_var), size = 2) + - scale_shape_manual(values = c("Drug A" = 1, "Drug B" = 2)) + - scale_color_manual(values = c("CR" = "#9b59b6", "PR" = "#3498db")) + - labs(x = "Study Day", y = "Subject ID") - }, - dataname = as.name(dataname), - id_var = as.name(id_var), - avisit_var = as.name(avisit_var), - shape_var = as.name(shape_var), - color_var = as.name(color_var) + ggplot_call <- reactive({ + plot_call <- bquote(ggplot2::ggplot()) + points_calls <- lapply(geom_specs, function(x) { + # todo: convert $geom, $data, and $mapping elements from character to language + # others can be kept as character + basic_call <- as.call( + c( + list( + x$geom, + mapping = as.call(c(as.name("aes"), x$mapping)) + ), + x[!names(x) %in% c("geom", "mapping")] + ) + ) + }) + + title_call <- substitute(ggtitle(title), list(title = title)) + + rhs <- Reduce( + x = c(plot_call, points_calls, title_call), + f = function(x, y) call("+", x, y) ) + substitute(p <- rhs, list(rhs = rhs)) }) + output_q <- reactive(eval_code(data(), ggplot_call())) + plot_r <- reactive(output_q()$p) - pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r) + pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r, gg2plotly = FALSE) teal::srv_brush_filter( "brush_filter", @@ -55,3 +66,9 @@ srv_p_swimlane <- function(id, data, dataname, id_var, avisit_var, shape_var, co ) }) } + + + +merge_selectors2 <- function() { + lappl +} diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R index 770d495be..34e6e4562 100644 --- a/inst/swimlane_poc.R +++ b/inst/swimlane_poc.R @@ -36,14 +36,32 @@ app <- init( modules = modules( tm_data_table(), tm_p_swimlane( - dataname = "synthetic_data", - id_var = "usubjid", - avisit_var = "study_day", - shape_var = "assigned_drug", - color_var = "response_type" + label = "Swimlane", + geom_specs = list( + list( + geom = str2lang("ggplot2::geom_col"), + data = quote(synthetic_data), + mapping = list(y = quote(subjid), x = quote(max(study_day))), + width = 0.2 + ), # geom_col(data = synthetic_data, mapping = aes(x = subjid, x = max(study_day), width = 0.2) + list( + geom = quote(geom_point), + data = quote(synthetic_data), + mapping = list( + y = quote(subjid), x = quote(study_day), color = quote(assigned_drug), shape = quote(assigned_drug) + ) + ), + list( + geom = quote(geom_point), + data = quote(synthetic_data), + mapping = list( + y = quote(subjid), x = quote(study_day), color = quote(response_type), shape = quote(response_type) + ) + ) + ), + title = "Swimlane Efficacy Plot" ) - ), - title = "Swimlane Efficacy Plot" + ) ) shinyApp(app$ui, app$server) From 70d077244dd159dc1d55ae877d9a8eff17e91b7b Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 19 Nov 2024 11:55:00 +0100 Subject: [PATCH 011/158] quick fix --- R/tm_p_swimlane.R | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 249abbdc4..2ca46af7e 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,4 +1,9 @@ -tm_p_swimlane <- function(label = "Swimlane Plot Module", geom_specs, title, color_manual, shape_manual, size_manual) { +tm_p_swimlane <- function(label = "Swimlane Plot Module", + geom_specs, + title, + color_manual = NULL, + shape_manual = NULL, + size_manual = NULL) { module( label = label, ui = ui_p_swimlane, @@ -56,7 +61,7 @@ srv_p_swimlane <- function(id, output_q <- reactive(eval_code(data(), ggplot_call())) plot_r <- reactive(output_q()$p) - pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r, gg2plotly = FALSE) + pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r) teal::srv_brush_filter( "brush_filter", From 2e49a7a843a05b0ca2e68472743e6a4052222aaf Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 19 Nov 2024 12:28:11 +0100 Subject: [PATCH 012/158] generalise to enable faceting --- R/tm_p_swimlane.R | 10 +++++----- inst/swimlane_poc.R | 6 +++++- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 2ca46af7e..97ce99822 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -38,13 +38,13 @@ srv_p_swimlane <- function(id, points_calls <- lapply(geom_specs, function(x) { # todo: convert $geom, $data, and $mapping elements from character to language # others can be kept as character + if (!is.null(x$mapping)) { + x$mapping <- as.call(c(as.name("aes"), x$mapping)) + } basic_call <- as.call( c( - list( - x$geom, - mapping = as.call(c(as.name("aes"), x$mapping)) - ), - x[!names(x) %in% c("geom", "mapping")] + list(x$geom), + x[!names(x) %in% "geom"] ) ) }) diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R index 34e6e4562..d06007e7e 100644 --- a/inst/swimlane_poc.R +++ b/inst/swimlane_poc.R @@ -12,7 +12,7 @@ data <- within(teal_data(), { .possible_end_days <- c(50, 60, 70) # Create sample data - synthetic_data <- tibble(subjid = c(1:15)) |> + synthetic_data <- tibble(subjid = c(1:15), strata = rep(c("category 1", "category 2"), length.out = 15)) |> rowwise() |> mutate( max_study_day = sample(.possible_end_days, 1), @@ -57,6 +57,10 @@ app <- init( mapping = list( y = quote(subjid), x = quote(study_day), color = quote(response_type), shape = quote(response_type) ) + ), + list( + geom = quote(facet_wrap), + facets = quote(vars(strata)) ) ), title = "Swimlane Efficacy Plot" From 4038ba8d48d6b4547858c4b17c21fe3866b97b20 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 19 Nov 2024 13:09:58 +0100 Subject: [PATCH 013/158] dummy adam example --- inst/poc_adam.r | 69 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 69 insertions(+) create mode 100644 inst/poc_adam.r diff --git a/inst/poc_adam.r b/inst/poc_adam.r new file mode 100644 index 000000000..c0ca7ae3b --- /dev/null +++ b/inst/poc_adam.r @@ -0,0 +1,69 @@ +pkgload::load_all("teal") +pkgload::load_all("teal.widgets") +pkgload::load_all("teal.modules.general") + +# Example data +data <- within(teal_data(), { + library(dplyr) + library(tidyr) + ADSL <- teal.data::rADSL |> mutate( + EOTSTT2 = case_when( + !is.na(DCSREAS) ~ DCSREAS, + TRUE ~ EOTSTT + ) + ) + + ADAE <- teal.data::rADAE + ADRS <- teal.data::rADRS +}) + +join_keys(data) <- default_cdisc_join_keys + +app <- init( + data = data, + modules = modules( + tm_data_table(), + tm_p_swimlane( + label = "Swimlane", + geom_specs = list( + list( + geom = quote(geom_col), + data = quote(ADSL), + mapping = list(y = quote(USUBJID), x = quote(EOSDY)), + width = 0.2 + ), # geom_col(data = synthetic_data, mapping = aes(x = subjid, x = max(study_day), width = 0.2) + list( + geom = quote(geom_point), + data = quote(ADSL), + mapping = list( + y = quote(USUBJID), x = quote(EOSDY), color = quote(EOTSTT2), shape = quote(EOTSTT2) + ) + ), + list( + geom = quote(geom_point), + data = quote(ADRS), + mapping = list( + y = quote(USUBJID), x = quote(ADY), color = quote(PARAMCD), shape = quote(PARAMCD) + ) + ), + list( + geom = quote(geom_point), + data = quote(ADAE), + mapping = list( + y = quote(USUBJID), x = quote(ASTDY), color = quote(AETERM), shape = quote(AETERM) + ) + ), + list( + geom = quote(geom_point), + data = quote(ADAE), + mapping = list( + y = quote(USUBJID), x = quote(AENDY), color = quote(AEOUT), shape = quote(AEOUT) + ) + ) + ), + title = "Swimlane Efficacy Plot" + ) + ) +) + +shinyApp(app$ui, app$server) From 06bf0a4bcbe3cef27f2991d26fa8ce0bf6448c7a Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 19 Nov 2024 20:13:40 +0530 Subject: [PATCH 014/158] feat: add example using the poc data --- R/tm_p_swimlane.R | 16 ++----- inst/poc_crf.R | 112 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 115 insertions(+), 13 deletions(-) create mode 100644 inst/poc_crf.R diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 97ce99822..e0c9481a8 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,17 +1,12 @@ -tm_p_swimlane <- function(label = "Swimlane Plot Module", - geom_specs, - title, - color_manual = NULL, - shape_manual = NULL, - size_manual = NULL) { +tm_p_swimlane <- function(label = "Swimlane Plot Module", geom_specs, title) { module( label = label, ui = ui_p_swimlane, server = srv_p_swimlane, datanames = "all", server_args = list( - geom_specs = geom_specs, title = title, - color_manual = color_manual, shape_manual = shape_manual, size_manual = size_manual + geom_specs = geom_specs, + title = title ) ) } @@ -28,9 +23,6 @@ srv_p_swimlane <- function(id, data, geom_specs, title = "Swimlane plot", - color_manual, - shape_manual, - size_manual, filter_panel_api) { moduleServer(id, function(input, output, session) { ggplot_call <- reactive({ @@ -72,8 +64,6 @@ srv_p_swimlane <- function(id, }) } - - merge_selectors2 <- function() { lappl } diff --git a/inst/poc_crf.R b/inst/poc_crf.R new file mode 100644 index 000000000..5836f3087 --- /dev/null +++ b/inst/poc_crf.R @@ -0,0 +1,112 @@ +pkgload::load_all("teal") +pkgload::load_all("teal.widgets") +pkgload::load_all("teal.modules.general") + +# Example data +data <- within(teal_data(), { + library(dplyr) + library(arrow) + library(forcats) + data_path <- "PATH_TO_DATA" + + swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> + filter(!is.na(event_result), !is.na(event_study_day)) |> + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) + disposition <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "disposition") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) + + response_assessment <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "response_assessment") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) + + study_drug_administration <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "study_drug_administration") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) + + max_subject_day <- swimlane_ds |> + group_by(subject) |> + summarise(max_study_day = max(event_study_day)) +}) + +color_manual <- c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue" +) +shape_manual <- c( + "DEATH" = 4, + "WITHDRAWAL BY SUBJECT" = 5, + "PD (Progressive Disease)" = 8, + "SD (Stable Disease)" = 5, + "MR (Minimal/Minor Response)" = 5, + "PR (Partial Response)" = 5, + "VGPR (Very Good Partial Response)" = 5, + "CR (Complete Response)" = 5, + "SCR (Stringent Complete Response)" = 5 +) + +app <- init( + data = data, + modules = modules( + tm_data_table(), + tm_p_swimlane( + label = "Swimlane", + geom_specs = list( + list( + geom = str2lang("ggplot2::geom_bar"), + data = quote(max_subject_day), + mapping = list(y = quote(subject), x = quote(max_study_day)), + stat = "identity", + width = 0.1 + ), + list( + geom = quote(geom_point), + data = quote(study_drug_administration), + mapping = list( + y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) + ) + ), + list( + geom = quote(geom_point), + data = quote(disposition), + mapping = list( + y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) + ) + ), + list( + geom = quote(geom_point), + data = quote(response_assessment), + mapping = list( + y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) + ) + ), + list( + geom = quote(scale_color_manual), + values = color_manual, + breaks = names(color_manual) + ), + list( + geom = quote(scale_shape_manual), + values = shape_manual, + breaks = names(shape_manual) + ), + list( + geom = quote(theme_minimal) + ) + ), + title = "Swimlane Efficacy Plot" + ) + ) +) + +shinyApp(app$ui, app$server) From b9e03c25946229348fc4517e63e715724193a734 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 21 Nov 2024 09:42:08 +0100 Subject: [PATCH 015/158] WIP plotly --- R/tm_p_swimlane2.r | 45 ++++++++++++++++++++++++++++++++++++++++++ inst/poc_adam_plotly.r | 41 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 86 insertions(+) create mode 100644 R/tm_p_swimlane2.r create mode 100644 inst/poc_adam_plotly.r diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r new file mode 100644 index 000000000..e426114c5 --- /dev/null +++ b/R/tm_p_swimlane2.r @@ -0,0 +1,45 @@ +tm_p_swimlane2 <- function(label = "Swimlane Plot Module", plotly_specs, title) { + module( + label = label, + ui = ui_p_swimlane2, + server = srv_p_swimlane2, + datanames = "all", + server_args = list( + plotly_specs = plotly_specs, + title = title + ) + ) +} + + +ui_p_swimlane2 <- function(id) { + ns <- NS(id) + shiny::tagList( + plotly::plotlyOutput(ns("plot")), + verbatimTextOutput(ns("selecting")), + shinyjs::hidden(tableOutput(ns("table"))) + ) +} + +srv_p_swimlane2 <- function(id, + data, + plotly_specs, + title = "Swimlane plot", + filter_panel_api) { + moduleServer(id, function(input, output, session) { + plotly_q <- reactive({ + code <- substitute( + p <- plotly_specs |> plotly::event_register("plotly_selecting"), + list(plotly_specs = plotly_specs) + ) + eval_code(data(), code = code) + }) + + output$plot <- plotly::renderPlotly(plotly_q()$p) + + output$selecting <- renderPrint({ + d <- plotly::event_data("plotly_selecting") + if (is.null(d)) "Brush points appear here (double-click to clear)" else d + }) + }) +} diff --git a/inst/poc_adam_plotly.r b/inst/poc_adam_plotly.r new file mode 100644 index 000000000..15889f5af --- /dev/null +++ b/inst/poc_adam_plotly.r @@ -0,0 +1,41 @@ +pkgload::load_all("teal") +pkgload::load_all("teal.widgets") +pkgload::load_all("teal.modules.general") + +# Example data +data <- within(teal_data(), { + library(dplyr) + library(tidyr) + ADSL <- teal.data::rADSL |> mutate( + EOTSTT2 = case_when( + !is.na(DCSREAS) ~ DCSREAS, + TRUE ~ EOTSTT + ) + ) + + ADAE <- teal.data::rADAE + ADRS <- teal.data::rADRS +}) + +join_keys(data) <- default_cdisc_join_keys + +plotly_specs <- quote( + plotly::plot_ly() |> + plotly::add_bars(x = ~EOSDY, y = ~USUBJID, data = ADSL) |> + plotly::add_markers(x = ~EOSDY, y = ~USUBJID, data = ADSL) |> + plotly::add_markers(x = ~ADY, y = ~USUBJID, data = ADRS) +) + +app <- init( + data = data, + modules = modules( + tm_data_table(), + tm_p_swimlane2( + label = "Swimlane", + plotly_specs = plotly_specs, + title = "Swimlane Efficacy Plot" + ) + ) +) + +shinyApp(app$ui, app$server) From 32ee42fa1a5e4ac9db277a69d4afbfaff2c0bb9c Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 21 Nov 2024 10:05:17 +0100 Subject: [PATCH 016/158] plotly_specs as simple list --- R/tm_p_swimlane2.r | 27 +++++++++++++++++++++++++-- inst/poc_adam_plotly.r | 11 ++++++----- 2 files changed, 31 insertions(+), 7 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index e426114c5..8757ad4a0 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -28,9 +28,10 @@ srv_p_swimlane2 <- function(id, filter_panel_api) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ + plotly_call <- .make_plotly_call(specs = plotly_specs) code <- substitute( - p <- plotly_specs |> plotly::event_register("plotly_selecting"), - list(plotly_specs = plotly_specs) + p <- plotly_call %>% plotly::event_register("plotly_selecting"), + list(plotly_call = plotly_call) ) eval_code(data(), code = code) }) @@ -43,3 +44,25 @@ srv_p_swimlane2 <- function(id, }) }) } + + + +.make_plotly_call <- function(init_call = quote(plotly::plot_ly()), specs) { + points_calls <- lapply(specs, function(x) { + which_fun <- c(which(names(x) == "fun"), 1)[1] + if (is.character(x[[which_fun]])) { + x[[which_fun]] <- str2lang(x[[which_fun]]) + } + basic_call <- as.call( + c( + list(x[[which_fun]]), + x[-which_fun] + ) + ) + }) + + rhs <- Reduce( + x = c(init_call, points_calls), + f = function(x, y) call("%>%", x, y) + ) +} diff --git a/inst/poc_adam_plotly.r b/inst/poc_adam_plotly.r index 15889f5af..6b5ef312d 100644 --- a/inst/poc_adam_plotly.r +++ b/inst/poc_adam_plotly.r @@ -19,13 +19,14 @@ data <- within(teal_data(), { join_keys(data) <- default_cdisc_join_keys -plotly_specs <- quote( - plotly::plot_ly() |> - plotly::add_bars(x = ~EOSDY, y = ~USUBJID, data = ADSL) |> - plotly::add_markers(x = ~EOSDY, y = ~USUBJID, data = ADSL) |> - plotly::add_markers(x = ~ADY, y = ~USUBJID, data = ADRS) + +plotly_specs <- list( + list("plotly::add_bars", x = ~EOSDY, y = ~USUBJID, data = quote(ADSL)), + list("plotly::add_markers", x = ~EOSDY, y = ~USUBJID, color = ~EOTSTT2, data = quote(ADSL)), + list("plotly::add_markers", x = ~ADY, y = ~USUBJID, data = quote(ADRS)) ) + app <- init( data = data, modules = modules( From 4321350415bdb96db064f144344db7a096f2814d Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 21 Nov 2024 11:55:25 +0100 Subject: [PATCH 017/158] data_table as a brushing table --- R/tm_data_table.R | 15 ++++++++++----- R/tm_p_swimlane2.r | 40 +++++++++++++++++++++++++++++++++------- 2 files changed, 43 insertions(+), 12 deletions(-) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 583707288..96b0345ca 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -181,11 +181,16 @@ ui_page_data_table <- function(id, # Server page module srv_page_data_table <- function(id, data, - datasets_selected, - variables_selected, - dt_args, - dt_options, - server_rendering, + variables_selected = list(), + datasets_selected = character(0), + dt_args = list(), + dt_options = list( + searching = FALSE, + pageLength = 30, + lengthMenu = c(5, 15, 30, 100), + scrollX = TRUE + ), + server_rendering = FALSE, filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 8757ad4a0..1b5f08944 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -16,8 +16,7 @@ ui_p_swimlane2 <- function(id) { ns <- NS(id) shiny::tagList( plotly::plotlyOutput(ns("plot")), - verbatimTextOutput(ns("selecting")), - shinyjs::hidden(tableOutput(ns("table"))) + ui_page_data_table(ns("brush_tables")) ) } @@ -30,17 +29,44 @@ srv_p_swimlane2 <- function(id, plotly_q <- reactive({ plotly_call <- .make_plotly_call(specs = plotly_specs) code <- substitute( - p <- plotly_call %>% plotly::event_register("plotly_selecting"), + p <- plotly_call, list(plotly_call = plotly_call) ) eval_code(data(), code = code) }) - output$plot <- plotly::renderPlotly(plotly_q()$p) + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - output$selecting <- renderPrint({ - d <- plotly::event_data("plotly_selecting") - if (is.null(d)) "Brush points appear here (double-click to clear)" else d + + brush_filter_call <- reactive({ + d <- plotly::event_data("plotly_selected") + req(d) + calls <- lapply(plotly_specs, function(spec) { + substitute( + dataname <- dplyr::filter(dataname, var_x %in% levels_x, var_y %in% levels_y), + list( + dataname = spec$data, + var_x = str2lang(all.vars(spec$x)), + var_y = str2lang(all.vars(spec$y)), + levels_x = d$x, + levels_y = d$y + ) + ) + }) + unique(calls) + }) + + brush_filtered_data <- reactive({ + if (is.null(brush_filter_call())) { + shinyjs::hide("brush_tables") + } else { + shinyjs::hide("show_tables") + eval_code(plotly_q(), as.expression(brush_filter_call())) + } + }) + + observeEvent(brush_filtered_data(), once = TRUE, { + srv_page_data_table("brush_tables", data = brush_filtered_data, filter_panel_api = filter_panel_api) }) }) } From 4137aa1f687e8c98877fd2ecc8b6f9f2da8bc9bd Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 21 Nov 2024 16:33:08 +0100 Subject: [PATCH 018/158] hide table when not brushed --- R/tm_p_swimlane2.r | 9 ++++++--- inst/poc_adam_plotly.r | 17 +++++++++-------- 2 files changed, 15 insertions(+), 11 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 1b5f08944..bb1580697 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -16,7 +16,10 @@ ui_p_swimlane2 <- function(id) { ns <- NS(id) shiny::tagList( plotly::plotlyOutput(ns("plot")), - ui_page_data_table(ns("brush_tables")) + shinyjs::hidden(div( + id = ns("brushing_wrapper"), + ui_page_data_table(ns("brush_tables")) + )) ) } @@ -58,9 +61,9 @@ srv_p_swimlane2 <- function(id, brush_filtered_data <- reactive({ if (is.null(brush_filter_call())) { - shinyjs::hide("brush_tables") + shinyjs::hide("brushing_wrapper") } else { - shinyjs::hide("show_tables") + shinyjs::show("brushing_wrapper") eval_code(plotly_q(), as.expression(brush_filter_call())) } }) diff --git a/inst/poc_adam_plotly.r b/inst/poc_adam_plotly.r index 6b5ef312d..673595d01 100644 --- a/inst/poc_adam_plotly.r +++ b/inst/poc_adam_plotly.r @@ -1,5 +1,4 @@ -pkgload::load_all("teal") -pkgload::load_all("teal.widgets") +library(plotly) pkgload::load_all("teal.modules.general") # Example data @@ -10,7 +9,8 @@ data <- within(teal_data(), { EOTSTT2 = case_when( !is.na(DCSREAS) ~ DCSREAS, TRUE ~ EOTSTT - ) + ), + TRTLEN = as.integer(TRTEDTM - TRTSDTM) ) ADAE <- teal.data::rADAE @@ -21,21 +21,22 @@ join_keys(data) <- default_cdisc_join_keys plotly_specs <- list( - list("plotly::add_bars", x = ~EOSDY, y = ~USUBJID, data = quote(ADSL)), - list("plotly::add_markers", x = ~EOSDY, y = ~USUBJID, color = ~EOTSTT2, data = quote(ADSL)), - list("plotly::add_markers", x = ~ADY, y = ~USUBJID, data = quote(ADRS)) + list("plotly::add_bars", x = ~TRTLEN, y = ~USUBJID, color = ~ARM, data = quote(ADSL)), + list("plotly::add_markers", x = ~ADY, y = ~USUBJID, color = ~AVALC, symbol = ~AVALC, data = quote(ADRS)) ) - app <- init( data = data, modules = modules( tm_data_table(), - tm_p_swimlane2( + tm_p_plotly( label = "Swimlane", plotly_specs = plotly_specs, title = "Swimlane Efficacy Plot" ) + ), + filter = teal_slices( + teal_slice("ADSL", "AGE", selected = c(20, 25)) ) ) From f1b5d51dc596f8b1335eb659ae0c8654dc350f20 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 21 Nov 2024 22:06:35 +0530 Subject: [PATCH 019/158] feat: allow the user to pass custom colors and symbols --- R/tm_p_swimlane2.r | 16 ++++--- inst/poc_crf.R | 103 ++++++++++++++++----------------------------- 2 files changed, 47 insertions(+), 72 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index bb1580697..32d66a121 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -1,4 +1,4 @@ -tm_p_swimlane2 <- function(label = "Swimlane Plot Module", plotly_specs, title) { +tm_p_swimlane2 <- function(label = "Swimlane Plot Module", plotly_specs, title, colors = c(), symbols = c()) { module( label = label, ui = ui_p_swimlane2, @@ -6,7 +6,9 @@ tm_p_swimlane2 <- function(label = "Swimlane Plot Module", plotly_specs, title) datanames = "all", server_args = list( plotly_specs = plotly_specs, - title = title + title = title, + colors = colors, + symbols = symbols ) ) } @@ -27,10 +29,12 @@ srv_p_swimlane2 <- function(id, data, plotly_specs, title = "Swimlane plot", + colors, + symbols, filter_panel_api) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ - plotly_call <- .make_plotly_call(specs = plotly_specs) + plotly_call <- .make_plotly_call(specs = plotly_specs, colors = colors, symbols = symbols) code <- substitute( p <- plotly_call, list(plotly_call = plotly_call) @@ -76,20 +80,20 @@ srv_p_swimlane2 <- function(id, -.make_plotly_call <- function(init_call = quote(plotly::plot_ly()), specs) { +.make_plotly_call <- function(specs, colors = c(), symbols = c()) { + init_call <- substitute(plotly::plot_ly(colors = colors, symbols = symbols), list(colors = colors, symbols = symbols)) points_calls <- lapply(specs, function(x) { which_fun <- c(which(names(x) == "fun"), 1)[1] if (is.character(x[[which_fun]])) { x[[which_fun]] <- str2lang(x[[which_fun]]) } - basic_call <- as.call( + as.call( c( list(x[[which_fun]]), x[-which_fun] ) ) }) - rhs <- Reduce( x = c(init_call, points_calls), f = function(x, y) call("%>%", x, y) diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 5836f3087..ecfe2c59b 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -2,7 +2,8 @@ pkgload::load_all("teal") pkgload::load_all("teal.widgets") pkgload::load_all("teal.modules.general") -# Example data +# Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data + data <- within(teal_data(), { library(dplyr) library(arrow) @@ -32,79 +33,49 @@ data <- within(teal_data(), { summarise(max_study_day = max(event_study_day)) }) -color_manual <- c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue" -) -shape_manual <- c( - "DEATH" = 4, - "WITHDRAWAL BY SUBJECT" = 5, - "PD (Progressive Disease)" = 8, - "SD (Stable Disease)" = 5, - "MR (Minimal/Minor Response)" = 5, - "PR (Partial Response)" = 5, - "VGPR (Very Good Partial Response)" = 5, - "CR (Complete Response)" = 5, - "SCR (Stringent Complete Response)" = 5 +plotly_specs <- list( + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), + list("plotly::add_bars", x = ~max_study_day, y = ~subject, data = quote(max_subject_day), width = 0.1, marker = list(color = "grey"), showlegend = FALSE) ) app <- init( data = data, modules = modules( tm_data_table(), - tm_p_swimlane( + tm_p_swimlane2( label = "Swimlane", - geom_specs = list( - list( - geom = str2lang("ggplot2::geom_bar"), - data = quote(max_subject_day), - mapping = list(y = quote(subject), x = quote(max_study_day)), - stat = "identity", - width = 0.1 - ), - list( - geom = quote(geom_point), - data = quote(study_drug_administration), - mapping = list( - y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) - ) - ), - list( - geom = quote(geom_point), - data = quote(disposition), - mapping = list( - y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) - ) - ), - list( - geom = quote(geom_point), - data = quote(response_assessment), - mapping = list( - y = quote(subject), x = quote(study_day), color = quote(catagory), shape = quote(catagory) - ) - ), - list( - geom = quote(scale_color_manual), - values = color_manual, - breaks = names(color_manual) - ), - list( - geom = quote(scale_shape_manual), - values = shape_manual, - breaks = names(shape_manual) - ), - list( - geom = quote(theme_minimal) - ) + plotly_specs = plotly_specs, + title = "Swimlane Efficacy Plot", + colors = c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue", + "X Administration Injection" = "goldenrod", + "Y Administration Infusion" = "deepskyblue3", + "Z Administration Infusion" = "darkorchid" ), - title = "Swimlane Efficacy Plot" + symbols = c( + "DEATH" = "circle", + "WITHDRAWAL BY SUBJECT" = "square", + "PD (Progressive Disease)" = "circle", + "SD (Stable Disease)" = "square-open", + "MR (Minimal/Minor Response)" = "star-open", + "PR (Partial Response)" = "star-open", + "VGPR (Very Good Partial Response)" = "star-open", + "CR (Complete Response)" = "star-open", + "SCR (Stringent Complete Response)" = "star-open", + "X Administration Injection" = "line-ns-open", + "Y Administration Infusion" = "line-ns-open", + "Z Administration Infusion" = "line-ns-open" + ) ) ) ) From 780924c78509a09a1505817518b36c218482b99b Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 22 Nov 2024 16:01:33 +0530 Subject: [PATCH 020/158] feat: reproduce the osprey example --- inst/poc_osprey.R | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 inst/poc_osprey.R diff --git a/inst/poc_osprey.R b/inst/poc_osprey.R new file mode 100644 index 000000000..02630dd6c --- /dev/null +++ b/inst/poc_osprey.R @@ -0,0 +1,44 @@ +pkgload::load_all("teal") +pkgload::load_all("teal.widgets") +pkgload::load_all("teal.modules.general") + +data <- within(teal_data(), { + library(dplyr) + library(osprey) + + ADSL <- osprey::rADSL[1:20, ] + ADRS <- filter(rADRS, PARAMCD == "OVRINV") +}) + +plotly_specs <- list( + list( + "plotly::add_bars", + data = quote(ADSL), + x = ~ as.integer(TRTEDTM - TRTSDTM), y = ~USUBJID, color = ~ARM, + colors = c("A: Drug X" = "#343CFF", "B: Placebo" = "#FF484B", "C: Combination" = "#222222") + ), + list( + "plotly::add_markers", + data = quote(left_join(ADSL, ADRS)), + x = ~ADY, y = ~USUBJID, symbol = ~AVALC, + marker = list( + size = 10, + color = "#329133" + ) + ) +) + +app <- init( + data = data, + modules = modules( + tm_data_table(), + tm_p_swimlane2( + label = "Swimlane", + plotly_specs = plotly_specs, + title = "Swimlane Efficacy Plot", + symbols = c("CR" = "circle", "PR" = "triangle-up", "SD" = "diamond-wide", "PD" = "square", "NE" = "x-thin-open") + ) + ) +) + +shinyApp(app$ui, app$server) From ea559d3a47c546f80243e8bb69727fd9b9769062 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 22 Nov 2024 16:22:05 +0530 Subject: [PATCH 021/158] fix: filter using teal.slice and not during data creation --- inst/poc_osprey.R | 23 +++++++++++++++++++---- 1 file changed, 19 insertions(+), 4 deletions(-) diff --git a/inst/poc_osprey.R b/inst/poc_osprey.R index 02630dd6c..255969014 100644 --- a/inst/poc_osprey.R +++ b/inst/poc_osprey.R @@ -6,20 +6,23 @@ data <- within(teal_data(), { library(dplyr) library(osprey) - ADSL <- osprey::rADSL[1:20, ] - ADRS <- filter(rADRS, PARAMCD == "OVRINV") + ADSL <- osprey::rADSL |> + mutate(x_val = as.integer(TRTEDTM - TRTSDTM)) + ADRS <- osprey::rADRS }) +join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADRS")] + plotly_specs <- list( list( "plotly::add_bars", data = quote(ADSL), - x = ~ as.integer(TRTEDTM - TRTSDTM), y = ~USUBJID, color = ~ARM, + x = ~x_val, y = ~USUBJID, color = ~ARM, colors = c("A: Drug X" = "#343CFF", "B: Placebo" = "#FF484B", "C: Combination" = "#222222") ), list( "plotly::add_markers", - data = quote(left_join(ADSL, ADRS)), + data = quote(ADRS), x = ~ADY, y = ~USUBJID, symbol = ~AVALC, marker = list( size = 10, @@ -30,6 +33,18 @@ plotly_specs <- list( app <- init( data = data, + filter = teal_slices( + teal_slice( + "ADSL", + "AGE", + selected = c(20, 23) + ), + teal_slice( + "ADRS", + "PARAMCD", + selected = "OVRINV" + ) + ), modules = modules( tm_data_table(), tm_p_swimlane2( From 21eff43e9117daea4859d4cc83139cb475be3715 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 22 Nov 2024 11:26:05 +0000 Subject: [PATCH 022/158] rename srv_page_data_table to srv_data_table --- R/tm_data_table.R | 99 +++++++++++++++++++++++++++------------------- R/tm_p_swimlane2.r | 4 +- 2 files changed, 60 insertions(+), 43 deletions(-) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 96b0345ca..dd8897ed7 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -125,8 +125,8 @@ tm_data_table <- function(label = "Data Table", ans <- module( label, - server = srv_page_data_table, - ui = ui_page_data_table, + server = srv_data_table, + ui = ui_data_table, datanames = if (length(datasets_selected) == 0) "all" else datasets_selected, server_args = list( variables_selected = variables_selected, @@ -145,7 +145,7 @@ tm_data_table <- function(label = "Data Table", } # UI page module -ui_page_data_table <- function(id, +ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { ns <- NS(id) @@ -168,7 +168,7 @@ ui_page_data_table <- function(id, class = "mb-8", column( width = 12, - uiOutput(ns("dataset_table")) + uiOutput(ns("data_tables")) ) ) ), @@ -179,7 +179,7 @@ ui_page_data_table <- function(id, } # Server page module -srv_page_data_table <- function(id, +srv_data_table <- function(id, data, variables_selected = list(), datasets_selected = character(0), @@ -199,24 +199,38 @@ srv_page_data_table <- function(id, if_filtered <- reactive(as.logical(input$if_filtered)) if_distinct <- reactive(as.logical(input$if_distinct)) - - datanames <- isolate(names(data())) - datanames <- Filter(function(name) { - is.data.frame(isolate(data())[[name]]) - }, datanames) - - if (!identical(datasets_selected, character(0))) { - checkmate::assert_subset(datasets_selected, datanames) - datanames <- datasets_selected - } - - output$dataset_table <- renderUI({ + + datanames <- reactive({ + df_datanames <- Filter( + function(name) is.data.frame(isolate(data())[[name]]), + names(data()) + ) + if (!identical(datasets_selected, character(0))) { + missing_datanames <- setdiff(datasets_selected, df_datanames) + if (length(missing_datanames)) { + shiny::showNotification( + sprintf( + "Some datasets specified `datasets_selected` are missing or are not inheriting from data.frame, those are: %s", + toString(missing_datanames) + ) + ) + } + df_datanames <- intersect(datasets_selected, df_datanames) + } + + df_datanames + }) + + + + output$data_tables <- renderUI({ + req(datanames()) do.call( tabsetPanel, c( list(id = session$ns("dataname_tab")), lapply( - datanames, + datanames(), function(x) { dataset <- isolate(data()[[x]]) choices <- names(dataset) @@ -241,7 +255,7 @@ srv_page_data_table <- function(id, width = 12, div( class = "mt-4", - ui_data_table( + ui_dataset_table( id = session$ns(x), choices = choices, selected = variables_selected @@ -254,28 +268,34 @@ srv_page_data_table <- function(id, ) ) }) - - lapply( - datanames, - function(x) { - srv_data_table( - id = x, - data = data, - dataname = x, - if_filtered = if_filtered, - if_distinct = if_distinct, - dt_args = dt_args, - dt_options = dt_options, - server_rendering = server_rendering, - filter_panel_api = filter_panel_api - ) - } - ) + + # server should be run only once + modules_run <- reactiveVal() + modules_to_run <- reactive(setdiff(datanames(), modules_run())) + observeEvent(modules_to_run(), { + lapply( + modules_to_run(), + function(dataname) { + srv_dataset_table( + id = dataname, + data = data, + dataname = dataname, + if_filtered = if_filtered, + if_distinct = if_distinct, + dt_args = dt_args, + dt_options = dt_options, + server_rendering = server_rendering, + filter_panel_api = filter_panel_api + ) + } + ) + modules_run(union(modules_run(), modules_to_run())) + }) }) } # UI function for the data_table module -ui_data_table <- function(id, +ui_dataset_table <- function(id, choices, selected) { ns <- NS(id) @@ -306,7 +326,7 @@ ui_data_table <- function(id, } # Server function for the data_table module -srv_data_table <- function(id, +srv_dataset_table <- function(id, data, dataname, if_filtered, @@ -358,9 +378,6 @@ srv_data_table <- function(id, if (is.null(input$data_table_rows_selected)) { return(NULL) } - # isolate({ - # foo1(brush, selector_list) - # }) dataset <- data()[[dataname]][input$data_table_rows_selected, ] # todo: when added another time then it is duplicated slice <- teal_slices(teal_slice( diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 32d66a121..7bf5ac2b8 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -20,7 +20,7 @@ ui_p_swimlane2 <- function(id) { plotly::plotlyOutput(ns("plot")), shinyjs::hidden(div( id = ns("brushing_wrapper"), - ui_page_data_table(ns("brush_tables")) + ui_data_table(ns("brush_tables")) )) ) } @@ -73,7 +73,7 @@ srv_p_swimlane2 <- function(id, }) observeEvent(brush_filtered_data(), once = TRUE, { - srv_page_data_table("brush_tables", data = brush_filtered_data, filter_panel_api = filter_panel_api) + srv_data_table("brush_tables", data = brush_filtered_data, filter_panel_api = filter_panel_api) }) }) } From ea67bd0d6faf2898f1466f07731cbb96e9fa7d9d Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 22 Nov 2024 17:16:24 +0530 Subject: [PATCH 023/158] feat: add refrence lines + filter unwanted data --- inst/poc_osprey.R | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/inst/poc_osprey.R b/inst/poc_osprey.R index 255969014..078b03cdc 100644 --- a/inst/poc_osprey.R +++ b/inst/poc_osprey.R @@ -7,8 +7,12 @@ data <- within(teal_data(), { library(osprey) ADSL <- osprey::rADSL |> - mutate(x_val = as.integer(TRTEDTM - TRTSDTM)) - ADRS <- osprey::rADRS + mutate(x_val = as.integer(TRTEDTM - TRTSDTM)) |> + arrange(x_val) |> + filter(!is.na(x_val)) + ADRS <- osprey::rADRS |> + filter(ADY >= 0, USUBJID %in% ADSL$USUBJID) + reference_lines <- data.frame(x = c(50, 250), xend = c(50, 250), y = min(ADSL$USUBJID), yend = max(ADSL$USUBJID)) }) join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADRS")] @@ -28,6 +32,20 @@ plotly_specs <- list( size = 10, color = "#329133" ) + ), + list( + "plotly::add_segments", + data = quote(reference_lines), + x = ~x, + xend = ~xend, + y = ~y, + yend = ~yend, + line = list( + color = "#CA0E40", + width = 2, + dash = "dash" + ), + showlegend = FALSE ) ) @@ -37,7 +55,7 @@ app <- init( teal_slice( "ADSL", "AGE", - selected = c(20, 23) + selected = c(24, 25) ), teal_slice( "ADRS", From f913acbf02ef242044d1a1a0d0f3fbd4594c50cf Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Fri, 22 Nov 2024 13:18:38 +0100 Subject: [PATCH 024/158] display brushed only --- R/tm_p_swimlane2.r | 6 +++++- inst/poc_osprey.R | 2 -- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 7bf5ac2b8..67a93d793 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -68,7 +68,11 @@ srv_p_swimlane2 <- function(id, shinyjs::hide("brushing_wrapper") } else { shinyjs::show("brushing_wrapper") - eval_code(plotly_q(), as.expression(brush_filter_call())) + q <- eval_code(plotly_q(), as.expression(brush_filter_call())) + module_datanames <- unique(lapply(plotly_specs, function(x) deparse(x$data))) + is_brushed <- sapply(module_datanames, function(x) is.data.frame(q[[x]]) && nrow(q[[x]])) + brushed_datanames <- unique(unlist(module_datanames[is_brushed])) + q[brushed_datanames] # we want to show brushed datanames only } }) diff --git a/inst/poc_osprey.R b/inst/poc_osprey.R index 078b03cdc..b254c43de 100644 --- a/inst/poc_osprey.R +++ b/inst/poc_osprey.R @@ -1,5 +1,3 @@ -pkgload::load_all("teal") -pkgload::load_all("teal.widgets") pkgload::load_all("teal.modules.general") data <- within(teal_data(), { From 7d5bc89ad5933ffda44580eeac5a936cbf77a274 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Nov 2024 07:48:02 +0530 Subject: [PATCH 025/158] push local changes --- R/tm_p_swimlane2.r | 65 ++++++--------- inst/poc_crf.R | 194 ++++++++++++++++++++++++++++++++++++++------- 2 files changed, 189 insertions(+), 70 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 67a93d793..f6403d797 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -1,27 +1,32 @@ -tm_p_swimlane2 <- function(label = "Swimlane Plot Module", plotly_specs, title, colors = c(), symbols = c()) { +tm_p_swimlane2 <- function( + label = "Swimlane Plot Module", plotly_specs, title, + colors = c(), symbols = c(), transformers = list(), + ui_mod = ui_data_table, + srv_mod = srv_data_table) { module( label = label, ui = ui_p_swimlane2, server = srv_p_swimlane2, datanames = "all", + ui_args = list(ui_mod = ui_mod), server_args = list( plotly_specs = plotly_specs, title = title, colors = colors, - symbols = symbols - ) + symbols = symbols, + srv_mod = srv_mod + ), + transformers = transformers ) } -ui_p_swimlane2 <- function(id) { +ui_p_swimlane2 <- function(id, ui_mod) { ns <- NS(id) shiny::tagList( - plotly::plotlyOutput(ns("plot")), - shinyjs::hidden(div( - id = ns("brushing_wrapper"), - ui_data_table(ns("brush_tables")) - )) + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, 800), + plotly::plotlyOutput(ns("plot"), height = "100%"), + ui_mod(ns("brush_tables")) ) } @@ -31,6 +36,7 @@ srv_p_swimlane2 <- function(id, title = "Swimlane plot", colors, symbols, + srv_mod, filter_panel_api) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ @@ -42,42 +48,17 @@ srv_p_swimlane2 <- function(id, eval_code(data(), code = code) }) - output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - - - brush_filter_call <- reactive({ - d <- plotly::event_data("plotly_selected") - req(d) - calls <- lapply(plotly_specs, function(spec) { - substitute( - dataname <- dplyr::filter(dataname, var_x %in% levels_x, var_y %in% levels_y), - list( - dataname = spec$data, - var_x = str2lang(all.vars(spec$x)), - var_y = str2lang(all.vars(spec$y)), - levels_x = d$x, - levels_y = d$y - ) - ) - }) - unique(calls) + output$plot <- plotly::renderPlotly({ + plotly::event_register( + plotly_q()$p |> layout(height = input$plot_height), + "plotly_selected" + ) }) - brush_filtered_data <- reactive({ - if (is.null(brush_filter_call())) { - shinyjs::hide("brushing_wrapper") - } else { - shinyjs::show("brushing_wrapper") - q <- eval_code(plotly_q(), as.expression(brush_filter_call())) - module_datanames <- unique(lapply(plotly_specs, function(x) deparse(x$data))) - is_brushed <- sapply(module_datanames, function(x) is.data.frame(q[[x]]) && nrow(q[[x]])) - brushed_datanames <- unique(unlist(module_datanames[is_brushed])) - q[brushed_datanames] # we want to show brushed datanames only - } - }) + plotly_selected <- reactive(plotly::event_data("plotly_selected")) - observeEvent(brush_filtered_data(), once = TRUE, { - srv_data_table("brush_tables", data = brush_filtered_data, filter_panel_api = filter_panel_api) + observeEvent(plotly_selected(), once = TRUE, { + srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api, plotly_selected = plotly_selected) }) }) } diff --git a/inst/poc_crf.R b/inst/poc_crf.R index ecfe2c59b..5e96c9209 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -1,6 +1,8 @@ pkgload::load_all("teal") pkgload::load_all("teal.widgets") pkgload::load_all("teal.modules.general") +library(DT) +library(labelled) # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data @@ -12,42 +14,155 @@ data <- within(teal_data(), { swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> filter(!is.na(event_result), !is.na(event_study_day)) |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) - disposition <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "disposition") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - response_assessment <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "response_assessment") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - study_drug_administration <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "study_drug_administration") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - max_subject_day <- swimlane_ds |> - group_by(subject) |> - summarise(max_study_day = max(event_study_day)) + mutate(subject = as.character(subject)) |> + mutate( + plot_subject = case_when( + event_type == "disposition" ~ paste0(subject, " - Disposition"), + event_type == "response_assessment" ~ paste0(subject, " - Response Assessment"), + event_type == "study_drug_administration" ~ paste0(subject, " - Drug Administration"), + TRUE ~ as.character(subject) + ) + ) |> + group_by(subject_group = sub(" - .*", "", plot_subject)) |> + mutate(max_event_day = max(event_study_day)) |> + ungroup() |> + mutate( + plot_subject = forcats::fct_reorder(plot_subject, max_event_day, .fun = max) + ) |> + select(-subject_group, -max_event_day) + + spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> + mutate(subject = as.character(subject)) }) -plotly_specs <- list( - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), - list("plotly::add_bars", x = ~max_study_day, y = ~subject, data = quote(max_subject_day), width = 0.1, marker = list(color = "grey"), showlegend = FALSE) + +swim_plotly_specs <- list( + list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), + list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), + list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), + list("plotly::add_lines", x = ~study_day, y = ~plot_subject, data = quote(max_subject_day), color = ~plot_subject, line = list(width = 1, color = "grey"), showlegend = FALSE), + list("plotly::layout", xaxis = list(title = "Study Day"), yaxis = list(title = "Subject")) +) + +tm <- teal_transform_module( + server = function(id, data) { + reactive({ + data() |> + within({ + disposition <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "disposition") |> + transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + + response_assessment <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "response_assessment") |> + transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + + study_drug_administration <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "study_drug_administration") |> + transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + + max_subject_day <- swimlane_ds |> + group_by(plot_subject) |> + summarise(study_day = max(event_study_day)) |> + bind_rows(tibble(plot_subject = unique(swimlane_ds$plot_subject), study_day = 0)) + }) + }) + } +) + +ui_mod <- function(id) { + ns <- NS(id) + fluidRow( + column(6, DTOutput(ns("mm_response"))), + column(6, DTOutput(ns("tx_listing"))) + ) +} + +srv_mod <- function(id, + data, + plotly_selected, + filter_panel_api) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + output$test <- renderText({ + print(plotly_selected) + "It works!" + }) + + output$mm_response <- renderDT({ + select_cols <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" + ) + new_col_names <- setNames( + select_cols, + c( + "Subject", "Visit Name", "Visit Date", "Form Name", "Source System URL Link", + "Assessment Performed", "Response Date", "Response Date Study Day", + "Response", "Best Marrow Aspirate", "Best Marrow Biopsy", "Comments" + ) + ) + swimlane_ds <- data()[["swimlane_ds"]] + mm_response <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> + select(all_of(select_cols)) + datatable(mm_response, colnames = new_col_names) + }) + + output$tx_listing <- renderDT({ + select_cols <- c( + "site_name", "subject", "visit_name", "visit_date", "form_name", + "source_system_url_link", "txnam", "txrec", "txrecrs", "txd_study_day", + "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", "txdlyrs", + "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", + "txrmod", "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", + "txetm", "txetmu", "txtm", "txtmu", "txed_study_day", "infrt", "infrtu", + "tximod", "txirmod", "tximae" + ) + new_col_names <- setNames( + select_cols, + c( + "Site Name", "Subject", "Visit Name", "Visit Date", "Form Name", "Source System URL Link", + "Study Drug Name", "Study Drug Administered", "Reason Study Drug Not Admin", + "Date Administered Study Day", "Date Administered", "Cycle Delay", "Cycle Delay Reason", + "Cycle Delay Adverse Event", "Dose Delay", "Dose Delay Reason", "AE related to Dose Delay", + "Planned Dose per Admin", "Planned Dose per Admin Unit", "Frequency", "Route of Administration", + "Dose Formulation", "Dose Modification", "Dose Modification Reason", + "AE related to Dose Modification", "Total Dose Administered", "Total Dose Administered Unit", + "Date Administered", "Start Time Administered", "Start Time Administered Unknown", + "End Date Administered", "End Time Administered", "End Time Administered Unknown", + "Time Administered", "Time Administered Unknown", "End Study Day", "Infusion Rate", + "Infusion Rate Unit", "Infusion Modified?", "Reason for Infusion modification", + "AE related to Infusion Modification" + ) + ) + swimlane_ds <- data()[["swimlane_ds"]] + tx_listing <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> + select(all_of(select_cols)) + datatable(tx_listing, colnames = new_col_names) + }) + }) +} + +pkgload::load_all("teal.modules.general") + +spider_plotly_specs <- list( + list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, symbol = ~event_type, data = quote(spiderplot_ds)), + list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds), color = ~subject, showlegend = FALSE) ) app <- init( data = data, modules = modules( - tm_data_table(), tm_p_swimlane2( label = "Swimlane", - plotly_specs = plotly_specs, - title = "Swimlane Efficacy Plot", + plotly_specs = swim_plotly_specs, + title = "Swim Lane - Duration of Tx", colors = c( "DEATH" = "black", "WITHDRAWAL BY SUBJECT" = "grey", @@ -75,7 +190,30 @@ app <- init( "X Administration Injection" = "line-ns-open", "Y Administration Infusion" = "line-ns-open", "Z Administration Infusion" = "line-ns-open" - ) + ), + transformers = list(tm), + ui_mod = ui_mod, + srv_mod = srv_mod + ), + tm_p_swimlane2( + label = "Spiderplot", + plotly_specs = spider_plotly_specs, + title = "Swimlane Efficacy Plot" + ), + tm_data_table() + ), + filter = teal_slices( + teal_slice( + dataname = "swimlane_ds", + varname = "subject" + ), + teal_slice( + dataname = "swimlane_ds", + varname = "cohrt" + ), + teal_slice( + dataname = "swimlane_ds", + varname = "txarm" ) ) ) From 179f145c6bc924ac195d89ef0f5da30321f2ce27 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Nov 2024 08:23:23 +0530 Subject: [PATCH 026/158] export the custom module for deployment --- NAMESPACE | 1 + R/tm_p_swimlane2.r | 1 + 2 files changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 86c4c2a5a..206de3d31 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) +export(tm_p_swimlane2) export(tm_t_crosstable) export(tm_variable_browser) import(ggmosaic) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index f6403d797..c9ae373b6 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -1,3 +1,4 @@ +#' @export tm_p_swimlane2 <- function( label = "Swimlane Plot Module", plotly_specs, title, colors = c(), symbols = c(), transformers = list(), From e18dfc318bfedba8c1c3001eb36d71457f6b1b32 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Nov 2024 08:31:49 +0530 Subject: [PATCH 027/158] pass plotly_selected only when it is supported --- R/tm_p_swimlane2.r | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index c9ae373b6..bae58df8f 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -59,7 +59,11 @@ srv_p_swimlane2 <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected")) observeEvent(plotly_selected(), once = TRUE, { - srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api, plotly_selected = plotly_selected) + if ("plotly_selected" %in% names(formals(srv_mod))) { + srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api, plotly_selected = plotly_selected) + } else { + srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api) + } }) }) } From b5884a2cda8153f9048a8bba28139a3a9c9bf1a8 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 2 Dec 2024 20:59:47 +0530 Subject: [PATCH 028/158] feat: use reactable --- inst/poc_crf.R | 161 +++++++++++++++++++++++++++++++------------------ 1 file changed, 103 insertions(+), 58 deletions(-) diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 5e96c9209..80fe23ab1 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -3,6 +3,7 @@ pkgload::load_all("teal.widgets") pkgload::load_all("teal.modules.general") library(DT) library(labelled) +library(reactable) # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data @@ -35,7 +36,6 @@ data <- within(teal_data(), { mutate(subject = as.character(subject)) }) - swim_plotly_specs <- list( list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), @@ -52,17 +52,17 @@ tm <- teal_transform_module( disposition <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "disposition") |> - transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) response_assessment <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "response_assessment") |> - transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) study_drug_administration <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "study_drug_administration") |> - transmute(plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) max_subject_day <- swimlane_ds |> group_by(plot_subject) |> @@ -76,8 +76,8 @@ tm <- teal_transform_module( ui_mod <- function(id) { ns <- NS(id) fluidRow( - column(6, DTOutput(ns("mm_response"))), - column(6, DTOutput(ns("tx_listing"))) + column(6, "MM Response", reactableOutput(ns("mm_response"))), + column(6, "", reactableOutput(ns("tx_listing"))) ) } @@ -88,69 +88,112 @@ srv_mod <- function(id, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { - output$test <- renderText({ - print(plotly_selected) - "It works!" - }) - - output$mm_response <- renderDT({ - select_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" - ) - new_col_names <- setNames( - select_cols, - c( - "Subject", "Visit Name", "Visit Date", "Form Name", "Source System URL Link", - "Assessment Performed", "Response Date", "Response Date Study Day", - "Response", "Best Marrow Aspirate", "Best Marrow Biopsy", "Comments" - ) - ) + output$mm_response <- renderReactable({ swimlane_ds <- data()[["swimlane_ds"]] + col_defs <- list( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") + ) mm_response <- swimlane_ds |> filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> - select(all_of(select_cols)) - datatable(mm_response, colnames = new_col_names) + select(all_of(names(col_defs))) + reactable( + mm_response, + columns = col_defs, + defaultPageSize = 10, + searchable = TRUE, + sortable = TRUE + ) }) - output$tx_listing <- renderDT({ - select_cols <- c( - "site_name", "subject", "visit_name", "visit_date", "form_name", - "source_system_url_link", "txnam", "txrec", "txrecrs", "txd_study_day", - "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", "txdlyrs", - "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", - "txrmod", "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", - "txetm", "txetmu", "txtm", "txtmu", "txed_study_day", "infrt", "infrtu", - "tximod", "txirmod", "tximae" - ) - new_col_names <- setNames( - select_cols, - c( - "Site Name", "Subject", "Visit Name", "Visit Date", "Form Name", "Source System URL Link", - "Study Drug Name", "Study Drug Administered", "Reason Study Drug Not Admin", - "Date Administered Study Day", "Date Administered", "Cycle Delay", "Cycle Delay Reason", - "Cycle Delay Adverse Event", "Dose Delay", "Dose Delay Reason", "AE related to Dose Delay", - "Planned Dose per Admin", "Planned Dose per Admin Unit", "Frequency", "Route of Administration", - "Dose Formulation", "Dose Modification", "Dose Modification Reason", - "AE related to Dose Modification", "Total Dose Administered", "Total Dose Administered Unit", - "Date Administered", "Start Time Administered", "Start Time Administered Unknown", - "End Date Administered", "End Time Administered", "End Time Administered Unknown", - "Time Administered", "Time Administered Unknown", "End Study Day", "Infusion Rate", - "Infusion Rate Unit", "Infusion Modified?", "Reason for Infusion modification", - "AE related to Infusion Modification" - ) - ) + output$tx_listing <- renderReactable({ swimlane_ds <- data()[["swimlane_ds"]] + + col_defs <- list( + site_name = colDef(name = "Site Name"), + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + txnam = colDef(name = "Study Drug Name"), + txrec = colDef(name = "Study Drug Administered"), + txrecrs = colDef(name = "Reason Study Drug Not Admin"), + txd_study_day = colDef(name = "Date Administered Study Day"), + date_administered = colDef(name = "Date Administered"), + cydly = colDef(name = "Cycle Delay"), + cydlyrs = colDef(name = "Cycle Delay Reason"), + cydlyae = colDef(name = "Cycle Delay Adverse Event"), + txdly = colDef(name = "Dose Delay"), + txdlyrs = colDef(name = "Dose Delay Reason"), + txdlyae = colDef(name = "AE related to Dose Delay"), + txpdos = colDef(name = "Planned Dose per Admin"), + txpdosu = colDef(name = "Planned Dose per Admin Unit"), + frqdv = colDef(name = "Frequency"), + txrte = colDef(name = "Route of Administration"), + txform = colDef(name = "Dose Formulation"), + txdmod = colDef(name = "Dose Modification"), + txrmod = colDef(name = "Dose Modification Reason"), + txdmae = colDef(name = "AE related to Dose Modification"), + txad = colDef(name = "Total Dose Administered"), + txadu = colDef(name = "Total Dose Administered Unit"), + txd = colDef(name = "Date Administered"), + txstm = colDef(name = "Start Time Administered"), + txstmu = colDef(name = "Start Time Administered Unknown"), + txed = colDef(name = "End Date Administered"), + txetm = colDef(name = "End Time Administered"), + txetmu = colDef(name = "End Time Administered Unknown"), + txtm = colDef(name = "Time Administered"), + txtmu = colDef(name = "Time Administered Unknown"), + txed_study_day = colDef(name = "End Study Day"), + infrt = colDef(name = "Infusion Rate"), + infrtu = colDef(name = "Infusion Rate Unit"), + tximod = colDef(name = "Infusion Modified?"), + txirmod = colDef(name = "Reason for Infusion modification"), + tximae = colDef(name = "AE related to Infusion Modification") + ) tx_listing <- swimlane_ds |> filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> - select(all_of(select_cols)) - datatable(tx_listing, colnames = new_col_names) + select(all_of(names(col_defs))) + reactable( + tx_listing, + columns = col_defs, + defaultPageSize = 5, + searchable = TRUE, + sortable = TRUE + ) }) }) } -pkgload::load_all("teal.modules.general") - spider_plotly_specs <- list( list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, symbol = ~event_type, data = quote(spiderplot_ds)), list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds), color = ~subject, showlegend = FALSE) @@ -198,7 +241,9 @@ app <- init( tm_p_swimlane2( label = "Spiderplot", plotly_specs = spider_plotly_specs, - title = "Swimlane Efficacy Plot" + title = "Swimlane Efficacy Plot", + ui_mod = ui_mod, + srv_mod = srv_mod ), tm_data_table() ), From ef85449acce3713ac1863b08c90e06a1e81df9a2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 2 Dec 2024 21:01:07 +0530 Subject: [PATCH 029/158] fix: avoid ns clash of layout --- R/tm_p_swimlane2.r | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index bae58df8f..39c20ecd1 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -51,7 +51,7 @@ srv_p_swimlane2 <- function(id, output$plot <- plotly::renderPlotly({ plotly::event_register( - plotly_q()$p |> layout(height = input$plot_height), + plotly_q()$p |> plotly::layout(height = input$plot_height), "plotly_selected" ) }) From ef8a5abdff2bba5f966db86d74cb60822eeebbfa Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 2 Dec 2024 21:13:14 +0530 Subject: [PATCH 030/158] chore: remove local change --- inst/poc_crf.R | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 80fe23ab1..24dae4ab7 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -76,8 +76,8 @@ tm <- teal_transform_module( ui_mod <- function(id) { ns <- NS(id) fluidRow( - column(6, "MM Response", reactableOutput(ns("mm_response"))), - column(6, "", reactableOutput(ns("tx_listing"))) + column(6, reactableOutput(ns("mm_response"))), + column(6, reactableOutput(ns("tx_listing"))) ) } @@ -119,7 +119,7 @@ srv_mod <- function(id, reactable( mm_response, columns = col_defs, - defaultPageSize = 10, + defaultPageSize = 5, searchable = TRUE, sortable = TRUE ) From 0fff2a7d39ee707cb05039ae513eee7554fbc5e1 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 3 Dec 2024 22:25:08 +0530 Subject: [PATCH 031/158] feat: use main version of teal and update spiderplot module --- R/tm_p_swimlane2.r | 33 ++++--- inst/poc_crf.R | 236 +++++++++++++++++++++++++++++++++++---------- 2 files changed, 209 insertions(+), 60 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index 39c20ecd1..a7fb8fa3e 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -1,31 +1,33 @@ #' @export tm_p_swimlane2 <- function( label = "Swimlane Plot Module", plotly_specs, title, - colors = c(), symbols = c(), transformers = list(), + colors = c(), symbols = c(), transformators = list(), ui_mod = ui_data_table, - srv_mod = srv_data_table) { + srv_mod = srv_data_table, + plot_height = 800) { module( label = label, ui = ui_p_swimlane2, server = srv_p_swimlane2, datanames = "all", - ui_args = list(ui_mod = ui_mod), + ui_args = list(ui_mod = ui_mod, height = plot_height), server_args = list( plotly_specs = plotly_specs, title = title, colors = colors, symbols = symbols, - srv_mod = srv_mod + srv_mod = srv_mod, + height = plot_height ), - transformers = transformers + transformators = transformators ) } -ui_p_swimlane2 <- function(id, ui_mod) { +ui_p_swimlane2 <- function(id, ui_mod, height) { ns <- NS(id) shiny::tagList( - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, 800), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height), plotly::plotlyOutput(ns("plot"), height = "100%"), ui_mod(ns("brush_tables")) ) @@ -37,11 +39,17 @@ srv_p_swimlane2 <- function(id, title = "Swimlane plot", colors, symbols, + height, srv_mod, filter_panel_api) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ - plotly_call <- .make_plotly_call(specs = plotly_specs, colors = colors, symbols = symbols) + plotly_call <- .make_plotly_call( + specs = plotly_specs, + colors = colors, + symbols = symbols, + height = input$plot_height + ) code <- substitute( p <- plotly_call, list(plotly_call = plotly_call) @@ -51,7 +59,7 @@ srv_p_swimlane2 <- function(id, output$plot <- plotly::renderPlotly({ plotly::event_register( - plotly_q()$p |> plotly::layout(height = input$plot_height), + plotly_q()$p, "plotly_selected" ) }) @@ -70,8 +78,11 @@ srv_p_swimlane2 <- function(id, -.make_plotly_call <- function(specs, colors = c(), symbols = c()) { - init_call <- substitute(plotly::plot_ly(colors = colors, symbols = symbols), list(colors = colors, symbols = symbols)) +.make_plotly_call <- function(specs, colors = c(), symbols = c(), height = 800) { + init_call <- substitute( + plotly::plot_ly(colors = colors, symbols = symbols, height = height), + list(colors = colors, symbols = symbols, height = height) + ) points_calls <- lapply(specs, function(x) { which_fun <- c(which(names(x) == "fun"), 1)[1] if (is.character(x[[which_fun]])) { diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 24dae4ab7..5803a4484 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -1,9 +1,8 @@ -pkgload::load_all("teal") -pkgload::load_all("teal.widgets") -pkgload::load_all("teal.modules.general") +library(teal) library(DT) library(labelled) library(reactable) +pkgload::load_all("teal.modules.general") # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data @@ -15,36 +14,21 @@ data <- within(teal_data(), { swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> filter(!is.na(event_result), !is.na(event_study_day)) |> - mutate(subject = as.character(subject)) |> - mutate( - plot_subject = case_when( - event_type == "disposition" ~ paste0(subject, " - Disposition"), - event_type == "response_assessment" ~ paste0(subject, " - Response Assessment"), - event_type == "study_drug_administration" ~ paste0(subject, " - Drug Administration"), - TRUE ~ as.character(subject) - ) - ) |> - group_by(subject_group = sub(" - .*", "", plot_subject)) |> - mutate(max_event_day = max(event_study_day)) |> - ungroup() |> - mutate( - plot_subject = forcats::fct_reorder(plot_subject, max_event_day, .fun = max) - ) |> - select(-subject_group, -max_event_day) + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> mutate(subject = as.character(subject)) }) swim_plotly_specs <- list( - list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), - list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), - list("plotly::add_markers", x = ~study_day, y = ~plot_subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), - list("plotly::add_lines", x = ~study_day, y = ~plot_subject, data = quote(max_subject_day), color = ~plot_subject, line = list(width = 1, color = "grey"), showlegend = FALSE), + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), + list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), + list("plotly::add_segments", x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, data = quote(max_subject_day), line = list(width = 1, color = "grey"), showlegend = FALSE), list("plotly::layout", xaxis = list(title = "Study Day"), yaxis = list(title = "Subject")) ) -tm <- teal_transform_module( +swimlane_tm <- teal_transform_module( server = function(id, data) { reactive({ data() |> @@ -52,28 +36,28 @@ tm <- teal_transform_module( disposition <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "disposition") |> - transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) response_assessment <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "response_assessment") |> - transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) study_drug_administration <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "study_drug_administration") |> - transmute(subject, plot_subject, event_type, catagory = event_result, study_day = event_study_day) + transmute(subject, event_type, catagory = event_result, study_day = event_study_day) max_subject_day <- swimlane_ds |> - group_by(plot_subject) |> + group_by(subject) |> summarise(study_day = max(event_study_day)) |> - bind_rows(tibble(plot_subject = unique(swimlane_ds$plot_subject), study_day = 0)) + bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) }) }) } ) -ui_mod <- function(id) { +swimlane_ui_mod <- function(id) { ns <- NS(id) fluidRow( column(6, reactableOutput(ns("mm_response"))), @@ -81,10 +65,10 @@ ui_mod <- function(id) { ) } -srv_mod <- function(id, - data, - plotly_selected, - filter_panel_api) { +swimlane_srv_mod <- function(id, + data, + plotly_selected, + filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -114,7 +98,7 @@ srv_mod <- function(id, comnts = colDef(name = "Comments") ) mm_response <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> select(all_of(names(col_defs))) reactable( mm_response, @@ -181,7 +165,7 @@ srv_mod <- function(id, tximae = colDef(name = "AE related to Infusion Modification") ) tx_listing <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, plot_subject %in% plotly_selected()$y) |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> select(all_of(names(col_defs))) reactable( tx_listing, @@ -195,13 +179,161 @@ srv_mod <- function(id, } spider_plotly_specs <- list( - list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, symbol = ~event_type, data = quote(spiderplot_ds)), - list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds), color = ~subject, showlegend = FALSE) + list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, data = quote(spiderplot_ds_filtered)), + list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE) +) + +spiderplot_tm <- teal_transform_module( + ui = function(id) { + selectInput(NS(id, "event_type"), "Select Event type", NULL) + }, + server = function(id, data) { + moduleServer(id, function(input, output, session) { + spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) + observeEvent(spiderplot_ds(), { + event_types <- unique(spiderplot_ds()$event_type) + updateSelectInput( + inputId = "event_type", + choices = event_types[event_types != "response_assessment"] + ) + }) + reactive({ + data() |> + within( + { + spiderplot_ds_filtered <- spiderplot_ds |> + filter(event_type == selected_event) + }, + selected_event = input$event_type + ) + }) + }) + } ) +spider_ui_mod <- function(id) { + ns <- NS(id) + fluidRow( + column(6, reactableOutput(ns("recent_resp"))), + column(6, reactableOutput(ns("all_resp"))) + ) +} + +spider_srv_mod <- function(id, + data, + plotly_selected, + filter_panel_api) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + all_resp_cols <- list( + txarm = colDef(name = "Study Arm"), + cohrt = colDef(name = "Study Cohort"), + subject = colDef(name = "Subject"), + event_result = colDef(name = "Response"), + event_study_day = colDef(name = "Study Day"), + visit_name = colDef(name = "Visit Name") + ) + + selected_recent_subject <- reactiveVal(NULL) + + all_resp <- reactive({ + if (!is.null(selected_recent_subject())) { + data()[["spiderplot_ds"]] |> + filter(event_type == "response_assessment") |> + select(all_of(names(all_resp_cols))) |> + filter(subject == selected_recent_subject()) + } else { + selected_subjects <- data()[["spiderplot_ds"]] |> + filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> + pull(subject) + data()[["spiderplot_ds"]] |> + filter(event_type == "response_assessment") |> + select(all_of(names(all_resp_cols))) |> + filter(subject %in% selected_subjects) + } + }) + + rank_response <- function(responses) { + responses <- responses[!is.na(responses)] + if (length(responses) == 0) { + return(NA_character_) + } + response_hierarchy <- c( + "SCR (Stringent Complete Response)", + "CR (Complete Response)", + "VGPR (Very Good Partial Response)", + "PR (Partial Response)", + "MR (Minimal/Minor Response)", + "SD (Stable Disease)", + "PD (Progressive Disease)" + ) + responses[which.max(match(responses, response_hierarchy))] + } + + recent_resp_cols <- list( + txarm = colDef(name = "Study Arm"), + cohrt = colDef(name = "Study Cohort"), + subject = colDef(name = "Subject"), + event_result = colDef(name = "Response"), + event_study_day = colDef(name = "Study Day"), + most_recent_response = colDef(name = "Most Recent Response"), + best_response = colDef(name = "Best Response") + ) + + output$recent_resp <- renderReactable({ + best_resp <- all_resp() %>% + group_by(subject) %>% + filter(!is.na(subject)) %>% + arrange(desc(event_study_day)) %>% + slice(1) %>% + mutate( + most_recent_response = event_result, + best_response = rank_response(all_resp()$event_result[all_resp()$subject == cur_group()]) + ) %>% + ungroup() + + reactable( + best_resp, + columns = recent_resp_cols, + selection = "single", + onClick = "select" + ) + }) + + observeEvent(input$recent_resp_selected, { + req(input$recent_resp_selected) + selected_subjects <- reactableProxy("recent_resp") %>% + getReactableState("selected") + + if (length(selected_subjects) > 0) { + selected_subject <- output$recent_resp()$subject[selected_subjects] + selected_recent_subject(selected_subject) + } + }) + + output$all_resp <- renderReactable({ + reactable( + all_resp(), + columns = all_resp_cols + ) + }) + }) +} + + app <- init( data = data, modules = modules( + tm_p_swimlane2( + label = "Spiderplot", + plotly_specs = spider_plotly_specs, + title = "Swimlane Efficacy Plot", + transformators = list(spiderplot_tm), + ui_mod = spider_ui_mod, + srv_mod = spider_srv_mod, + plot_height = 600 + ), tm_p_swimlane2( label = "Swimlane", plotly_specs = swim_plotly_specs, @@ -234,16 +366,9 @@ app <- init( "Y Administration Infusion" = "line-ns-open", "Z Administration Infusion" = "line-ns-open" ), - transformers = list(tm), - ui_mod = ui_mod, - srv_mod = srv_mod - ), - tm_p_swimlane2( - label = "Spiderplot", - plotly_specs = spider_plotly_specs, - title = "Swimlane Efficacy Plot", - ui_mod = ui_mod, - srv_mod = srv_mod + transformators = list(swimlane_tm), + ui_mod = swimlane_ui_mod, + srv_mod = swimlane_srv_mod ), tm_data_table() ), @@ -259,7 +384,20 @@ app <- init( teal_slice( dataname = "swimlane_ds", varname = "txarm" - ) + ), + teal_slice( + dataname = "spiderplot_ds", + varname = "subject" + ), + teal_slice( + dataname = "spiderplot_ds", + varname = "cohrt" + ), + teal_slice( + dataname = "spiderplot_ds", + varname = "txarm" + ), + count_type = "all" ) ) From b8a60c3c47862a93f7eba600b0960dc40f47132f Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 4 Dec 2024 23:16:15 +0530 Subject: [PATCH 032/158] feat: update the spiderplot tables + UI enhancements + single parent --- R/tm_p_swimlane2.r | 4 +- inst/poc_crf.R | 328 +++++++++++++++++++++++++++++++++------------ 2 files changed, 246 insertions(+), 86 deletions(-) diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index a7fb8fa3e..c610912ec 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -16,8 +16,7 @@ tm_p_swimlane2 <- function( title = title, colors = colors, symbols = symbols, - srv_mod = srv_mod, - height = plot_height + srv_mod = srv_mod ), transformators = transformators ) @@ -39,7 +38,6 @@ srv_p_swimlane2 <- function(id, title = "Swimlane plot", colors, symbols, - height, srv_mod, filter_panel_api) { moduleServer(id, function(input, output, session) { diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 5803a4484..cb68b745e 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -18,8 +18,18 @@ data <- within(teal_data(), { spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> mutate(subject = as.character(subject)) + + parent_ds <- bind_rows( + swimlane_ds |> select(subject, cohrt, txarm), + spiderplot_ds |> select(subject, cohrt, txarm) + ) |> distinct() }) +join_keys(data) <- join_keys( + join_key("parent_ds", "swimlane_ds", c("subject", "cohrt", "txarm")), + join_key("parent_ds", "spiderplot_ds", c("subject", "cohrt", "txarm")) +) + swim_plotly_specs <- list( list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), @@ -33,6 +43,8 @@ swimlane_tm <- teal_transform_module( reactive({ data() |> within({ + swimlane_ds <- swimlane_ds |> + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) disposition <- swimlane_ds |> filter(!is.na(event_study_day)) |> filter(event_type == "disposition") |> @@ -59,9 +71,26 @@ swimlane_tm <- teal_transform_module( swimlane_ui_mod <- function(id) { ns <- NS(id) - fluidRow( - column(6, reactableOutput(ns("mm_response"))), - column(6, reactableOutput(ns("tx_listing"))) + shinyjs::hidden( + fluidRow( + id = ns("reactive_tables"), + column( + 6, + class = "simple-card", + tagList( + h4("Multiple Myeloma Response"), + reactableOutput(ns("mm_response")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Study Tx Listing"), + reactableOutput(ns("tx_listing")) + ) + ) + ) ) } @@ -72,6 +101,10 @@ swimlane_srv_mod <- function(id, checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { + observeEvent(plotly_selected(), once = TRUE, { + shinyjs::show("reactive_tables") + }) + output$mm_response <- renderReactable({ swimlane_ds <- data()[["swimlane_ds"]] col_defs <- list( @@ -180,12 +213,18 @@ swimlane_srv_mod <- function(id, spider_plotly_specs <- list( list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, data = quote(spiderplot_ds_filtered)), - list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE) + list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE), + list( + "plotly::layout", + xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), + yaxis = list(title = ~y_title), + title = ~ paste0(y_title, " Over Time") + ) ) spiderplot_tm <- teal_transform_module( ui = function(id) { - selectInput(NS(id, "event_type"), "Select Event type", NULL) + selectInput(NS(id, "event_type"), "Select Y Axis", NULL) }, server = function(id, data) { moduleServer(id, function(input, output, session) { @@ -194,13 +233,14 @@ spiderplot_tm <- teal_transform_module( event_types <- unique(spiderplot_ds()$event_type) updateSelectInput( inputId = "event_type", - choices = event_types[event_types != "response_assessment"] + choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] ) }) reactive({ data() |> within( { + y_title <- selected_event spiderplot_ds_filtered <- spiderplot_ds |> filter(event_type == selected_event) }, @@ -213,9 +253,46 @@ spiderplot_tm <- teal_transform_module( spider_ui_mod <- function(id) { ns <- NS(id) - fluidRow( - column(6, reactableOutput(ns("recent_resp"))), - column(6, reactableOutput(ns("all_resp"))) + shinyjs::hidden( + fluidRow( + id = ns("reactive_tables"), + fluidRow( + column( + 6, + class = "simple-card", + tagList( + h4("Most Recent Resp and Best Resp"), + reactableOutput(ns("recent_resp")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Multiple Myeloma Response"), + reactableOutput(ns("all_resp")) + ) + ) + ), + fluidRow( + column( + 6, + class = "simple-card", + tagList( + h4("Disease Assessment - SPEP"), + reactableOutput(ns("spep_listing")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Disease Assessment - SFLC"), + reactableOutput(ns("sflc_listing")) + ) + ) + ) + ) ) } @@ -237,98 +314,195 @@ spider_srv_mod <- function(id, selected_recent_subject <- reactiveVal(NULL) + observeEvent(plotly_selected(), once = TRUE, { + shinyjs::show("reactive_tables") + }) + all_resp <- reactive({ - if (!is.null(selected_recent_subject())) { - data()[["spiderplot_ds"]] |> - filter(event_type == "response_assessment") |> - select(all_of(names(all_resp_cols))) |> - filter(subject == selected_recent_subject()) - } else { - selected_subjects <- data()[["spiderplot_ds"]] |> - filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> - pull(subject) - data()[["spiderplot_ds"]] |> - filter(event_type == "response_assessment") |> - select(all_of(names(all_resp_cols))) |> - filter(subject %in% selected_subjects) - } + selected_subjects <- data()[["spiderplot_ds"]] |> + filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> + pull(subject) + data()[["spiderplot_ds"]] |> + filter(event_type == "response_assessment") |> + select(all_of(names(all_resp_cols))) |> + filter(subject %in% selected_subjects) }) - rank_response <- function(responses) { - responses <- responses[!is.na(responses)] - if (length(responses) == 0) { - return(NA_character_) - } - response_hierarchy <- c( - "SCR (Stringent Complete Response)", - "CR (Complete Response)", - "VGPR (Very Good Partial Response)", - "PR (Partial Response)", - "MR (Minimal/Minor Response)", - "SD (Stable Disease)", - "PD (Progressive Disease)" + output$all_resp <- renderReactable({ + reactable( + all_resp(), + columns = all_resp_cols ) - responses[which.max(match(responses, response_hierarchy))] - } + }) recent_resp_cols <- list( - txarm = colDef(name = "Study Arm"), - cohrt = colDef(name = "Study Cohort"), subject = colDef(name = "Subject"), - event_result = colDef(name = "Response"), - event_study_day = colDef(name = "Study Day"), - most_recent_response = colDef(name = "Most Recent Response"), - best_response = colDef(name = "Best Response") + visit_name = colDef(name = "Visit Name"), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") ) - output$recent_resp <- renderReactable({ - best_resp <- all_resp() %>% - group_by(subject) %>% - filter(!is.na(subject)) %>% - arrange(desc(event_study_day)) %>% - slice(1) %>% - mutate( - most_recent_response = event_result, - best_response = rank_response(all_resp()$event_result[all_resp()$subject == cur_group()]) - ) %>% - ungroup() + recent_resp <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "latest_response_assessment") |> + filter(subject %in% all_resp()$subject) |> + select(all_of(names(recent_resp_cols))) + }) + output$recent_resp <- renderReactable({ reactable( - best_resp, + recent_resp(), columns = recent_resp_cols, selection = "single", onClick = "select" ) }) - observeEvent(input$recent_resp_selected, { - req(input$recent_resp_selected) - selected_subjects <- reactableProxy("recent_resp") %>% - getReactableState("selected") + spep_cols <- list( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef(name = "Source System URL Link"), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lrspep1 = colDef(name = "Another Form added?"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) - if (length(selected_subjects) > 0) { - selected_subject <- output$recent_resp()$subject[selected_subjects] - selected_recent_subject(selected_subject) - } + spep <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "Serum M-protein") |> + filter(subject %in% all_resp()$subject) |> + select(all_of(names(spep_cols))) }) - output$all_resp <- renderReactable({ + output$spep_listing <- renderReactable({ reactable( - all_resp(), - columns = all_resp_cols + spep(), + columns = spep_cols ) }) + + + sflc_cols <- list( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef(name = "Source System URL Link"), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lchfrc = colDef(name = "Presence of Serum free light chains"), + lchfr_raw = colDef(name = "Serum free light chain results"), + klchf_raw = colDef(name = "Kappa free light chain results"), + llchf_raw = colDef(name = "Lambda free light chain results"), + klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) + + sflc <- reactive({ + data()[["spiderplot_ds"]] |> + filter( + event_type %in% c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ) + ) |> + filter(subject %in% all_resp()$subject) |> + select(all_of(names(sflc_cols))) + }) + + output$sflc_listing <- renderReactable({ + reactable( + sflc(), + columns = sflc_cols + ) + }) + + observeEvent(input$recent_resp_selected, { + print(input$recent_resp_selected) + req(input$recent_resp_selected) + selected_subjects <- reactableProxy("recent_resp") %>% + getReactableState("selected") + print(selected_subjects) + }) }) } +# Custom placement of the transformer +# custom_tm_p_swimlane2 <- function(plotly_specs, ui_mod, srv_mod, transformators = list()) { +# mod <- tm_p_swimlane2( +# label = "Spiderplot", +# plotly_specs = plotly_specs, +# title = "Swimlane Plot", +# transformators = transformators, +# ui_mod = ui_mod, +# srv_mod = srv_mod, +# plot_height = 600 +# ) +# mod$ui <- function(id, ui_mod, height) { +# ns <- NS(id) +# shiny::tagList( +# sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height), +# teal::ui_transform_teal_data(NS(gsub("-module$", "", id), "data_transform"), transformators), +# plotly::plotlyOutput(ns("plot"), height = "100%"), +# ui_mod(ns("brush_tables")) +# ) +# } +# mod +# } + app <- init( data = data, + header = tags$head(tags$style( + ".simple-card { + padding: 20px; + border-radius: 10px; + border: 1px solid #ddd; + box-shadow: 0 4px 6px rgba(0, 0, 0, 0.1); + background-color: #fff; + } + .simple-card h4 { + text-align: center; + }" + )), modules = modules( tm_p_swimlane2( label = "Spiderplot", plotly_specs = spider_plotly_specs, - title = "Swimlane Efficacy Plot", + title = "Swimlane Plot", transformators = list(spiderplot_tm), ui_mod = spider_ui_mod, srv_mod = spider_srv_mod, @@ -374,27 +548,15 @@ app <- init( ), filter = teal_slices( teal_slice( - dataname = "swimlane_ds", - varname = "subject" - ), - teal_slice( - dataname = "swimlane_ds", - varname = "cohrt" - ), - teal_slice( - dataname = "swimlane_ds", - varname = "txarm" - ), - teal_slice( - dataname = "spiderplot_ds", + dataname = "parent_ds", varname = "subject" ), teal_slice( - dataname = "spiderplot_ds", + dataname = "parent_ds", varname = "cohrt" ), teal_slice( - dataname = "spiderplot_ds", + dataname = "parent_ds", varname = "txarm" ), count_type = "all" From 17e74e3435b9eb420127d3d6582c144059af52f1 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 4 Dec 2024 23:23:33 +0530 Subject: [PATCH 033/158] fix: format the links in two tables --- inst/poc_crf.R | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/inst/poc_crf.R b/inst/poc_crf.R index cb68b745e..54a862c0f 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -368,7 +368,16 @@ spider_srv_mod <- function(id, visit_name = colDef(name = "Visit Name"), visit_date = colDef(name = "Visit Date"), form_name = colDef(name = "Form Name"), - source_system_url_link = colDef(name = "Source System URL Link"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), rspdn = colDef(name = "Assessment Performed"), rspd = colDef(name = "Response Date"), rspd_study_day = colDef(name = "Response Date Study Day"), @@ -407,7 +416,16 @@ spider_srv_mod <- function(id, visit_name = colDef(name = "Visit Name"), visit_date = colDef(name = "Visit Date"), form_name = colDef(name = "Form Name"), - source_system_url_link = colDef(name = "Source System URL Link"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), rspdn = colDef(name = "Assessment Performed"), rspd = colDef(name = "Response Date"), rspd_study_day = colDef(name = "Response Date Study Day"), From d2636fb14caefa713cb9de614fecd22cdf4589a9 Mon Sep 17 00:00:00 2001 From: vedhav Date: Sat, 7 Dec 2024 02:44:33 +0530 Subject: [PATCH 034/158] feat: add a two module POC for easy maintenance --- R/tm_p_swimlane2.r | 10 +- inst/poc_crf.R | 59 +--- inst/poc_crf2.R | 692 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 702 insertions(+), 59 deletions(-) create mode 100644 inst/poc_crf2.R diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r index c610912ec..a1fbef1be 100644 --- a/R/tm_p_swimlane2.r +++ b/R/tm_p_swimlane2.r @@ -38,6 +38,7 @@ srv_p_swimlane2 <- function(id, title = "Swimlane plot", colors, symbols, + plot_source = "A", srv_mod, filter_panel_api) { moduleServer(id, function(input, output, session) { @@ -46,7 +47,8 @@ srv_p_swimlane2 <- function(id, specs = plotly_specs, colors = colors, symbols = symbols, - height = input$plot_height + height = input$plot_height, + source = plot_source ) code <- substitute( p <- plotly_call, @@ -62,7 +64,7 @@ srv_p_swimlane2 <- function(id, ) }) - plotly_selected <- reactive(plotly::event_data("plotly_selected")) + plotly_selected <- reactive(plotly::event_data("plotly_selected"), source = plot_source) observeEvent(plotly_selected(), once = TRUE, { if ("plotly_selected" %in% names(formals(srv_mod))) { @@ -76,9 +78,9 @@ srv_p_swimlane2 <- function(id, -.make_plotly_call <- function(specs, colors = c(), symbols = c(), height = 800) { +.make_plotly_call <- function(specs, colors = c(), symbols = c(), height = 800, source = "A") { init_call <- substitute( - plotly::plot_ly(colors = colors, symbols = symbols, height = height), + plotly::plot_ly(source = source, colors = colors, symbols = symbols, height = height), list(colors = colors, symbols = symbols, height = height) ) points_calls <- lapply(specs, function(x) { diff --git a/inst/poc_crf.R b/inst/poc_crf.R index 54a862c0f..616e496b9 100644 --- a/inst/poc_crf.R +++ b/inst/poc_crf.R @@ -22,7 +22,8 @@ data <- within(teal_data(), { parent_ds <- bind_rows( swimlane_ds |> select(subject, cohrt, txarm), spiderplot_ds |> select(subject, cohrt, txarm) - ) |> distinct() + ) |> + distinct() }) join_keys(data) <- join_keys( @@ -212,8 +213,8 @@ swimlane_srv_mod <- function(id, } spider_plotly_specs <- list( - list("plotly::add_markers", x = ~event_study_day, y = ~event_result, color = ~subject, data = quote(spiderplot_ds_filtered)), - list("plotly::add_lines", x = ~event_study_day, y = ~event_result, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE), + list("plotly::add_markers", x = ~event_study_day, y = ~event_result_num, color = ~subject, data = quote(spiderplot_ds_filtered)), + list("plotly::add_lines", x = ~event_study_day, y = ~event_result_num, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE), list( "plotly::layout", xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), @@ -222,34 +223,6 @@ spider_plotly_specs <- list( ) ) -spiderplot_tm <- teal_transform_module( - ui = function(id) { - selectInput(NS(id, "event_type"), "Select Y Axis", NULL) - }, - server = function(id, data) { - moduleServer(id, function(input, output, session) { - spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) - observeEvent(spiderplot_ds(), { - event_types <- unique(spiderplot_ds()$event_type) - updateSelectInput( - inputId = "event_type", - choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] - ) - }) - reactive({ - data() |> - within( - { - y_title <- selected_event - spiderplot_ds_filtered <- spiderplot_ds |> - filter(event_type == selected_event) - }, - selected_event = input$event_type - ) - }) - }) - } -) spider_ui_mod <- function(id) { ns <- NS(id) @@ -478,30 +451,6 @@ spider_srv_mod <- function(id, }) } - -# Custom placement of the transformer -# custom_tm_p_swimlane2 <- function(plotly_specs, ui_mod, srv_mod, transformators = list()) { -# mod <- tm_p_swimlane2( -# label = "Spiderplot", -# plotly_specs = plotly_specs, -# title = "Swimlane Plot", -# transformators = transformators, -# ui_mod = ui_mod, -# srv_mod = srv_mod, -# plot_height = 600 -# ) -# mod$ui <- function(id, ui_mod, height) { -# ns <- NS(id) -# shiny::tagList( -# sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height), -# teal::ui_transform_teal_data(NS(gsub("-module$", "", id), "data_transform"), transformators), -# plotly::plotlyOutput(ns("plot"), height = "100%"), -# ui_mod(ns("brush_tables")) -# ) -# } -# mod -# } - app <- init( data = data, header = tags$head(tags$style( diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R new file mode 100644 index 000000000..812ea3e46 --- /dev/null +++ b/inst/poc_crf2.R @@ -0,0 +1,692 @@ +library(teal) +library(DT) +library(labelled) +library(reactable) +pkgload::load_all("teal.modules.general") +# Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data + +with_tooltips <- function(...) { + args <- list(...) + lapply(args, function(col) { + col$header <- tags$span(col$name, title = col$name) + return(col) + }) +} + +data <- within(teal_data(), { + library(dplyr) + library(arrow) + library(forcats) + data_path <- "PATH_TO_DATA" + + swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> + filter(!is.na(event_result), !is.na(event_study_day)) |> + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) + + spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> + mutate(subject = as.character(subject)) + + parent_ds <- bind_rows( + swimlane_ds |> select(subject, cohrt, txarm), + spiderplot_ds |> select(subject, cohrt, txarm) + ) |> + distinct() +}) + +join_keys(data) <- join_keys( + join_key("parent_ds", "swimlane_ds", c("subject", "cohrt", "txarm")), + join_key("parent_ds", "spiderplot_ds", c("subject", "cohrt", "txarm")) +) + +tm_swimlane <- function(label = "Swimlane", plot_height = 700) { + ui <- function(id, height) { + ns <- NS(id) + tagList( + fluidRow( + class = "simple-card", + h4("Swim Lane - Duration of Tx"), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), + plotly::plotlyOutput(ns("plot"), height = "100%") + ), + fluidRow( + column( + 6, + class = "simple-card", + tagList( + h4("Multiple Myeloma Response"), + reactableOutput(ns("mm_response")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Study Tx Listing"), + reactableOutput(ns("tx_listing")) + ) + ) + ) + ) + } + server <- function(id, data, filter_panel_api, plot_height = 600) { + moduleServer(id, function(input, output, session) { + plotly_q <- reactive({ + data() |> + within( + { + swimlane_ds <- swimlane_ds |> + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) |> + mutate( + subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max), + tooltip = case_when( + event_type == "study_drug_administration" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Administration:", event_result + ), + event_type == "response_assessment" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Response Assessment:", event_result + ), + event_type == "disposition" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Disposition:", event_result + ), + TRUE ~ NA_character_ + ) + ) + + swimlane_ds <- swimlane_ds |> + group_by(subject, event_study_day) |> + mutate( + tooltip = paste(unique(tooltip), collapse = "
") + ) |> + ungroup() |> + mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) + + disposition <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "disposition") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + response_assessment <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "response_assessment") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + study_drug_administration <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "study_drug_administration") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + max_subject_day <- swimlane_ds |> + group_by(subject) |> + summarise(study_day = max(event_study_day)) |> + bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) + + p <- plotly::plot_ly( + source = "swimlane", + colors = c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue", + "X Administration Injection" = "goldenrod", + "Y Administration Infusion" = "deepskyblue3", + "Z Administration Infusion" = "darkorchid" + ), + symbols = c( + "DEATH" = "circle", + "WITHDRAWAL BY SUBJECT" = "square", + "PD (Progressive Disease)" = "circle", + "SD (Stable Disease)" = "square-open", + "MR (Minimal/Minor Response)" = "star-open", + "PR (Partial Response)" = "star-open", + "VGPR (Very Good Partial Response)" = "star-open", + "CR (Complete Response)" = "star-open", + "SCR (Stringent Complete Response)" = "star-open", + "X Administration Injection" = "line-ns-open", + "Y Administration Infusion" = "line-ns-open", + "Z Administration Infusion" = "line-ns-open" + ), + height = height + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = study_drug_administration + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = response_assessment + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = disposition + ) |> + plotly::add_segments( + x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, + data = max_subject_day, + line = list(width = 1, color = "grey"), + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + }, + height = input$plot_height + ) + }) + + output$plot <- plotly::renderPlotly({ + plotly::event_register( + plotly_q()$p, + "plotly_selected" + ) + }) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) + + output$mm_response <- renderReactable({ + swimlane_ds <- data()[["swimlane_ds"]] + col_defs <- with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name", width = 250), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name", width = 250), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response", width = 250), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") + ) + mm_response <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> + select(all_of(names(col_defs))) + if (nrow(mm_response) == 0) { + return() + } + + reactable( + mm_response, + class = "custom-reactable", + columns = col_defs, + defaultPageSize = 10, + wrap = FALSE, + searchable = TRUE, + sortable = TRUE + ) + }) + + output$tx_listing <- renderReactable({ + swimlane_ds <- data()[["swimlane_ds"]] + + col_defs <- with_tooltips( + site_name = colDef(name = "Site Name"), + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + txnam = colDef(name = "Study Drug Name"), + txrec = colDef(name = "Study Drug Administered"), + txrecrs = colDef(name = "Reason Study Drug Not Admin"), + txd_study_day = colDef(name = "Date Administered Study Day"), + date_administered = colDef(name = "Date Administered"), + cydly = colDef(name = "Cycle Delay"), + cydlyrs = colDef(name = "Cycle Delay Reason"), + cydlyae = colDef(name = "Cycle Delay Adverse Event"), + txdly = colDef(name = "Dose Delay"), + txdlyrs = colDef(name = "Dose Delay Reason"), + txdlyae = colDef(name = "AE related to Dose Delay"), + txpdos = colDef(name = "Planned Dose per Admin"), + txpdosu = colDef(name = "Planned Dose per Admin Unit"), + frqdv = colDef(name = "Frequency"), + txrte = colDef(name = "Route of Administration"), + txform = colDef(name = "Dose Formulation"), + txdmod = colDef(name = "Dose Modification"), + txrmod = colDef(name = "Dose Modification Reason"), + txdmae = colDef(name = "AE related to Dose Modification"), + txad = colDef(name = "Total Dose Administered"), + txadu = colDef(name = "Total Dose Administered Unit"), + txd = colDef(name = "Date Administered"), + txstm = colDef(name = "Start Time Administered"), + txstmu = colDef(name = "Start Time Administered Unknown"), + txed = colDef(name = "End Date Administered"), + txetm = colDef(name = "End Time Administered"), + txetmu = colDef(name = "End Time Administered Unknown"), + txtm = colDef(name = "Time Administered"), + txtmu = colDef(name = "Time Administered Unknown"), + txed_study_day = colDef(name = "End Study Day"), + infrt = colDef(name = "Infusion Rate"), + infrtu = colDef(name = "Infusion Rate Unit"), + tximod = colDef(name = "Infusion Modified?"), + txirmod = colDef(name = "Reason for Infusion modification"), + tximae = colDef(name = "AE related to Infusion Modification") + ) + tx_listing <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> + select(all_of(names(col_defs))) + if (nrow(tx_listing) == 0) { + return() + } + + reactable( + tx_listing, + columns = col_defs, + defaultPageSize = 10, + wrap = FALSE, + searchable = TRUE, + sortable = TRUE + ) + }) + }) + } + module( + label = label, + ui = ui, + server = server, + datanames = "all", + ui_args = list(height = plot_height) + ) +} + +tm_spider <- function(label = "Spiderplot", plot_height = 600) { + ui <- function(id, height) { + ns <- NS(id) + tagList( + div( + style = "display: flex; justify-content: center; align-items: center; gap: 30px;", + div( + selectInput(NS(id, "event_type"), "Select Y Axis", NULL) + ), + div(sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + ), + div( + style = "display: flex", + div( + class = "simple-card", + style = "width: 50%", + tagList( + h4("Most Recent Resp and Best Resp"), + reactableOutput(ns("recent_resp")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ), + div( + style = "display: flex", + div( + style = "width: 50%", + div( + class = "simple-card", + h4("Disease Assessment - SFLC"), + reactableOutput(ns("sflc_listing")) + ), + div( + class = "simple-card", + h4("Disease Assessment - SPEP"), + reactableOutput(ns("spep_listing")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + h4("Multiple Myeloma Response"), + reactableOutput(ns("all_resp")) + ) + ) + ) + } + server <- function(id, data, filter_panel_api, plot_height = 600) { + moduleServer(id, function(input, output, session) { + spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) + observeEvent(spiderplot_ds(), { + event_types <- unique(spiderplot_ds()$event_type) + updateSelectInput( + inputId = "event_type", + choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] + ) + }) + plotly_q <- reactive({ + data() |> + within( + { + y_title <- selected_event + spiderplot_ds_filtered <- spiderplot_ds |> + filter(event_type == selected_event) + + p <- plotly::plot_ly(source = "spiderplot", height = height) |> + plotly::add_markers( + x = ~event_study_day, y = ~event_result_num, color = ~subject, + data = spiderplot_ds_filtered + ) |> + plotly::add_lines( + x = ~event_study_day, y = ~event_result_num, color = ~subject, + data = spiderplot_ds_filtered, + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), + yaxis = list(title = ~y_title), + title = ~ paste0(y_title, " Over Time") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + }, + selected_event = input$event_type, + height = input$plot_height + ) + }) + + output$plot <- plotly::renderPlotly({ + plotly::event_register( + plotly_q()$p, + "plotly_selected" + ) + }) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) + + + resp_cols <- with_tooltips( + subject = colDef(name = "Subject"), + raise_query = colDef( + name = "Raise Query", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + visit_name = colDef(name = "Visit Name"), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") + ) + + selected_recent_subject <- reactiveVal(NULL) + + plotly_selected_subjects <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> + pull(subject) + }) + + recent_resp_ds <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "latest_response_assessment") |> + filter(subject %in% plotly_selected_subjects()) |> + select(all_of(names(resp_cols))) + }) + + output$recent_resp <- renderReactable({ + req(plotly_selected_subjects()) + + reactable( + recent_resp_ds(), + columns = resp_cols, + selection = "single", + onClick = "select", + defaultPageSize = 15, + wrap = FALSE, + rowClass = JS(" + function(rowInfo) { + console.log(rowInfo); + if (rowInfo.selected) { + return 'selected-row'; + } + } + ") + ) + }) + + table_selected_subjects <- reactive({ + selected_row <- getReactableState("recent_resp", "selected") + if (!is.null(selected_row)) { + recent_resp_ds()[selected_row, ]$subject + } else { + unique(recent_resp_ds()$subject) + } + }) + + all_resp <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "response_assessment") |> + select(all_of(names(resp_cols))) |> + filter(subject %in% plotly_selected_subjects()) |> + filter(subject %in% table_selected_subjects()) + }) + + output$all_resp <- renderReactable({ + if (nrow(all_resp()) == 0) { + return() + } + + reactable( + all_resp(), + columns = resp_cols, + defaultPageSize = 15, + wrap = FALSE + ) + }) + + spep_cols <- with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lrspep1 = colDef(name = "Another Form added?"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) + + spep <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "Serum M-protein") |> + filter(subject %in% table_selected_subjects()) |> + select(all_of(names(spep_cols))) + }) + + output$spep_listing <- renderReactable({ + if (nrow(spep()) == 0) { + return() + } + + reactable( + spep(), + columns = spep_cols, + defaultPageSize = 5, + wrap = FALSE + ) + }) + + + sflc_cols <- with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lchfrc = colDef(name = "Presence of Serum free light chains"), + lchfr_raw = colDef(name = "Serum free light chain results"), + klchf_raw = colDef(name = "Kappa free light chain results"), + llchf_raw = colDef(name = "Lambda free light chain results"), + klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) + + sflc <- reactive({ + data()[["spiderplot_ds"]] |> + filter( + event_type %in% c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ) + ) |> + filter(subject %in% table_selected_subjects()) |> + select(all_of(names(sflc_cols))) + }) + + output$sflc_listing <- renderReactable({ + if (nrow(sflc()) == 0) { + return() + } + + reactable( + sflc(), + columns = sflc_cols, + defaultPageSize = 5, + wrap = FALSE + ) + }) + }) + } + module( + label = label, + ui = ui, + server = server, + datanames = "all", + ui_args = list(height = plot_height) + ) +} + +app <- init( + data = data, + header = tags$head(tags$style( + ".simple-card { + padding: 20px; + border-radius: 10px; + border: 1px solid #ddd; + box-shadow: 0 4px 6px rgba(0, 0, 0, 0.1); + background-color: #fff; + } + .simple-card h4 { + text-align: center; + } + .selected-row { + background-color: #d9edf7; + color: #31708f; + } + .custom-reactable.rt-nowrap .rt-th-inner { + white-space: normal !important; /* Allow text wrapping */ + text-overflow: unset !important; /* Disable ellipsis */ + overflow: visible !important; /* Ensure content is visible and wrapped */ + }" + )), + modules = modules( + tm_swimlane(), + tm_spider(), + tm_data_table() + ), + filter = teal_slices( + teal_slice( + dataname = "parent_ds", + varname = "subject" + ), + teal_slice( + dataname = "parent_ds", + varname = "cohrt" + ), + teal_slice( + dataname = "parent_ds", + varname = "txarm" + ), + count_type = "all" + ) +) + +shinyApp(app$ui, app$server) + From 915ffdf8afcfd5831e919546f6c43187937b88a4 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 10:38:46 +0000 Subject: [PATCH 035/158] WIP modules --- R/tm_data_table.R | 33 ++-- R/tm_p_spiderplot.R | 363 ++++++++++++++++++++++++++++++++++++++++++++ R/tm_swimlane.R | 287 ++++++++++++++++++++++++++++++++++ 3 files changed, 666 insertions(+), 17 deletions(-) create mode 100644 R/tm_p_spiderplot.R create mode 100644 R/tm_swimlane.R diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 60363c1e6..692d22df9 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -130,11 +130,10 @@ tm_data_table <- function(label = "Data Table", checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) # End of assertions - ans <- module( label, - server = srv_page_data_table, - ui = ui_page_data_table, + server = srv_data_table, + ui = ui_data_table, datanames = datanames, server_args = list( datanames = if (is.null(datanames)) "all" else datanames, @@ -154,7 +153,7 @@ tm_data_table <- function(label = "Data Table", } # UI page module -ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) { +ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { ns <- NS(id) tagList( @@ -187,18 +186,18 @@ ui_page_data_table <- function(id, pre_output = NULL, post_output = NULL) { # Server page module srv_data_table <- function(id, - data, - datanames, - variables_selected = list(), - dt_args = list(), - dt_options = list( - searching = FALSE, - pageLength = 30, - lengthMenu = c(5, 15, 30, 100), - scrollX = TRUE - ), - server_rendering = FALSE, - filter_panel_api) { + data, + datanames, + variables_selected = list(), + dt_args = list(), + dt_options = list( + searching = FALSE, + pageLength = 30, + lengthMenu = c(5, 15, 30, 100), + scrollX = TRUE + ), + server_rendering = FALSE, + filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -283,7 +282,7 @@ srv_data_table <- function(id, } # UI function for the data_table module -ui_data_table <- function(id, choices, selected) { +ui_dataset_table <- function(id, choices, selected) { ns <- NS(id) if (!is.null(selected)) { diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R new file mode 100644 index 000000000..acefe34f8 --- /dev/null +++ b/R/tm_p_spiderplot.R @@ -0,0 +1,363 @@ + +tm_p_spiderplot <- function(label = "Spiderplot", + time_var, + subject_var, + value_var, + plot_height = 600) { + module( + label = label, + ui = ui_p_spiderplot, + server = srv_p_spiderplot, + ui_args = list(height = plot_height), + server_args = list( + time_var = time_var, + subject_var = subject_var, + value_var = value_var + ), + datanames = "all", + ) +} + + +ui_p_spiderplot <- function(id, height) { + ns <- NS(id) + tagList( + div( + style = "display: flex; justify-content: center; align-items: center; gap: 30px;", + div( + selectInput(NS(id, "event_type"), "Select Y Axis", NULL) + ), + div(sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + ), + div( + style = "display: flex", + div( + class = "simple-card", + style = "width: 50%", + tagList( + h4("Most Recent Resp and Best Resp"), + reactableOutput(ns("recent_resp")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ), + div( + style = "display: flex", + div( + style = "width: 50%", + div( + class = "simple-card", + h4("Disease Assessment - SFLC"), + reactableOutput(ns("sflc_listing")) + ), + div( + class = "simple-card", + h4("Disease Assessment - SPEP"), + reactableOutput(ns("spep_listing")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + h4("Multiple Myeloma Response"), + reactableOutput(ns("all_resp")) + ) + ) + ) +} + +srv_p_spiderplot <- function(id, + data, + time_var, + subject_var, + value_var, + filter_panel_api, + plot_height = 600) { + moduleServer(id, function(input, output, session) { + spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) + observeEvent(spiderplot_ds(), { + event_types <- unique(spiderplot_ds()$event_type) + updateSelectInput( + inputId = "event_type", + choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] + ) + }) + plotly_q <- reactive({ + data() |> + within( + selected_event = input$event_type, + height = input$plot_height, + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + expr = { + y_title <- selected_event + spiderplot_ds_filtered <- spiderplot_ds |> + filter(event_type == selected_event) + + p <- plotly::plot_ly(source = "spiderplot", height = height) |> + plotly::add_markers( + x = ~time_var, y = ~value_var, color = ~subject_var, + data = spiderplot_ds_filtered + ) |> + plotly::add_lines( + x = ~time_var, y = ~value_var, color = ~subject_var, + data = spiderplot_ds_filtered, + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), + yaxis = list(title = ~y_title), + title = ~ paste0(y_title, " Over Time") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + } + ) + }) + + output$plot <- plotly::renderPlotly({ + plotly::event_register( + plotly_q()$p, + "plotly_selected" + ) + }) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) + + + resp_cols <- .with_tooltips( + subject = colDef(name = "Subject"), + raise_query = colDef( + name = "Raise Query", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + visit_name = colDef(name = "Visit Name"), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") + ) + + selected_recent_subject <- reactiveVal(NULL) + + data_w_brushed <- reactive({ + req(plotly_selected()) + within( + data(), + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + expr = { + selected_subjects <- spiderplot_ds |> + filter(time_var %in% plotly_selected()$x, value_var %in% plotly_selected()$y) |> + pull(subject_var) + } + ) + + }) + + plotly_selected_subjects <- reactive({ + req(data_w_brushed()) + within( + data_w_brushed(), { + spiderplot_ds <- spiderplot_ds |> + filter(event_type == "latest_response_assessment") |> + filter(subject %in% selected_subjects) |> + select(all_of(names(resp_cols))) + } + ) + + }) + + output$recent_resp <- renderReactable({ + req(plotly_selected_subjects()) + + reactable( + recent_resp_ds(), + columns = resp_cols, + selection = "single", + onClick = "select", + defaultPageSize = 15, + wrap = FALSE, + rowClass = JS(" + function(rowInfo) { + console.log(rowInfo); + if (rowInfo.selected) { + return 'selected-row'; + } + } + ") + ) + }) + + table_selected_subjects <- reactive({ + selected_row <- getReactableState("recent_resp", "selected") + if (!is.null(selected_row)) { + recent_resp_ds()[selected_row, ][[subject_var]] + } else { + unique(recent_resp_ds()[[subject_var]]) + } + }) + + all_resp <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "response_assessment") |> + select(all_of(names(resp_cols))) |> + filter(subject %in% plotly_selected_subjects()) |> + filter(subject %in% table_selected_subjects()) + }) + + output$all_resp <- renderReactable({ + if (nrow(all_resp()) == 0) { + return() + } + + reactable( + all_resp(), + columns = resp_cols, + defaultPageSize = 15, + wrap = FALSE + ) + }) + + spep_cols <- .with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lrspep1 = colDef(name = "Another Form added?"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) + + spep <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "Serum M-protein") |> + filter(subject %in% table_selected_subjects()) |> + select(all_of(names(spep_cols))) + }) + + output$spep_listing <- renderReactable({ + if (nrow(spep()) == 0) { + return() + } + + reactable( + spep(), + columns = spep_cols, + defaultPageSize = 5, + wrap = FALSE + ) + }) + + + sflc_cols <- .with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response"), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments"), + asmntdn = colDef(name = "Assessment Not Done"), + blq = colDef(name = "Serum M-protein too small to quantify"), + coldr = colDef(name = "Collection Date"), + cold_study_day = colDef(name = "Collection Study Day"), + coltm = colDef(name = "Collection Time"), + coltmu = colDef(name = "Collection Time Unknown"), + lchfrc = colDef(name = "Presence of Serum free light chains"), + lchfr_raw = colDef(name = "Serum free light chain results"), + klchf_raw = colDef(name = "Kappa free light chain results"), + llchf_raw = colDef(name = "Lambda free light chain results"), + klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), + mprte_raw = colDef(name = "Serum M-protein"), + mprtec = colDef(name = "SPEP Serum M-protein detection") + ) + + sflc <- reactive({ + data()[["spiderplot_ds"]] |> + filter( + event_type %in% c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ) + ) |> + filter(subject %in% table_selected_subjects()) |> + select(all_of(names(sflc_cols))) + }) + + output$sflc_listing <- renderReactable({ + if (nrow(sflc()) == 0) { + return() + } + + reactable( + sflc(), + columns = sflc_cols, + defaultPageSize = 5, + wrap = FALSE + ) + }) + }) +} + + +.with_tooltips <- function(...) { + args <- list(...) + lapply(args, function(col) { + col$header <- tags$span(col$name, title = col$name) + return(col) + }) +} diff --git a/R/tm_swimlane.R b/R/tm_swimlane.R new file mode 100644 index 000000000..772f5ca03 --- /dev/null +++ b/R/tm_swimlane.R @@ -0,0 +1,287 @@ +tm_swimlane <- function(label = "Swimlane", plot_height = 700) { + ui <- function(id, height) { + ns <- NS(id) + tagList( + fluidRow( + class = "simple-card", + h4("Swim Lane - Duration of Tx"), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), + plotly::plotlyOutput(ns("plot"), height = "100%") + ), + fluidRow( + column( + 6, + class = "simple-card", + tagList( + h4("Multiple Myeloma Response"), + reactableOutput(ns("mm_response")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Study Tx Listing"), + reactableOutput(ns("tx_listing")) + ) + ) + ) + ) + } + server <- function(id, data, filter_panel_api, plot_height = 600) { + moduleServer(id, function(input, output, session) { + plotly_q <- reactive({ + data() |> + within( + { + swimlane_ds <- swimlane_ds |> + mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) |> + mutate( + subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max), + tooltip = case_when( + event_type == "study_drug_administration" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Administration:", event_result + ), + event_type == "response_assessment" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Response Assessment:", event_result + ), + event_type == "disposition" ~ paste( + "Subject:", subject, + "
Study Day:", event_study_day, + "
Disposition:", event_result + ), + TRUE ~ NA_character_ + ) + ) + + swimlane_ds <- swimlane_ds |> + group_by(subject, event_study_day) |> + mutate( + tooltip = paste(unique(tooltip), collapse = "
") + ) |> + ungroup() |> + mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) + + disposition <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "disposition") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + response_assessment <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "response_assessment") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + study_drug_administration <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "study_drug_administration") |> + transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) + + max_subject_day <- swimlane_ds |> + group_by(subject) |> + summarise(study_day = max(event_study_day)) |> + bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) + + p <- plotly::plot_ly( + source = "swimlane", + colors = c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue", + "X Administration Injection" = "goldenrod", + "Y Administration Infusion" = "deepskyblue3", + "Z Administration Infusion" = "darkorchid" + ), + symbols = c( + "DEATH" = "circle", + "WITHDRAWAL BY SUBJECT" = "square", + "PD (Progressive Disease)" = "circle", + "SD (Stable Disease)" = "square-open", + "MR (Minimal/Minor Response)" = "star-open", + "PR (Partial Response)" = "star-open", + "VGPR (Very Good Partial Response)" = "star-open", + "CR (Complete Response)" = "star-open", + "SCR (Stringent Complete Response)" = "star-open", + "X Administration Injection" = "line-ns-open", + "Y Administration Infusion" = "line-ns-open", + "Z Administration Infusion" = "line-ns-open" + ), + height = height + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = study_drug_administration + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = response_assessment + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = disposition + ) |> + plotly::add_segments( + x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, + data = max_subject_day, + line = list(width = 1, color = "grey"), + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + }, + height = input$plot_height + ) + }) + + output$plot <- plotly::renderPlotly({ + plotly::event_register( + plotly_q()$p, + "plotly_selected" + ) + }) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) + + output$mm_response <- renderReactable({ + swimlane_ds <- data()[["swimlane_ds"]] + col_defs <- .with_tooltips( + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name", width = 250), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name", width = 250), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + rspdn = colDef(name = "Assessment Performed"), + rspd = colDef(name = "Response Date"), + rspd_study_day = colDef(name = "Response Date Study Day"), + orsp = colDef(name = "Response", width = 250), + bma = colDef(name = "Best Marrow Aspirate"), + bmb = colDef(name = "Best Marrow Biopsy"), + comnts = colDef(name = "Comments") + ) + mm_response <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> + select(all_of(names(col_defs))) + if (nrow(mm_response) == 0) { + return() + } + + reactable( + mm_response, + class = "custom-reactable", + columns = col_defs, + defaultPageSize = 10, + wrap = FALSE, + searchable = TRUE, + sortable = TRUE + ) + }) + + output$tx_listing <- renderReactable({ + swimlane_ds <- data()[["swimlane_ds"]] + + col_defs <- .with_tooltips( + site_name = colDef(name = "Site Name"), + subject = colDef(name = "Subject"), + visit_name = colDef(name = "Visit Name"), + visit_date = colDef(name = "Visit Date"), + form_name = colDef(name = "Form Name"), + source_system_url_link = colDef( + name = "Source System URL Link", + cell = function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } + ), + txnam = colDef(name = "Study Drug Name"), + txrec = colDef(name = "Study Drug Administered"), + txrecrs = colDef(name = "Reason Study Drug Not Admin"), + txd_study_day = colDef(name = "Date Administered Study Day"), + date_administered = colDef(name = "Date Administered"), + cydly = colDef(name = "Cycle Delay"), + cydlyrs = colDef(name = "Cycle Delay Reason"), + cydlyae = colDef(name = "Cycle Delay Adverse Event"), + txdly = colDef(name = "Dose Delay"), + txdlyrs = colDef(name = "Dose Delay Reason"), + txdlyae = colDef(name = "AE related to Dose Delay"), + txpdos = colDef(name = "Planned Dose per Admin"), + txpdosu = colDef(name = "Planned Dose per Admin Unit"), + frqdv = colDef(name = "Frequency"), + txrte = colDef(name = "Route of Administration"), + txform = colDef(name = "Dose Formulation"), + txdmod = colDef(name = "Dose Modification"), + txrmod = colDef(name = "Dose Modification Reason"), + txdmae = colDef(name = "AE related to Dose Modification"), + txad = colDef(name = "Total Dose Administered"), + txadu = colDef(name = "Total Dose Administered Unit"), + txd = colDef(name = "Date Administered"), + txstm = colDef(name = "Start Time Administered"), + txstmu = colDef(name = "Start Time Administered Unknown"), + txed = colDef(name = "End Date Administered"), + txetm = colDef(name = "End Time Administered"), + txetmu = colDef(name = "End Time Administered Unknown"), + txtm = colDef(name = "Time Administered"), + txtmu = colDef(name = "Time Administered Unknown"), + txed_study_day = colDef(name = "End Study Day"), + infrt = colDef(name = "Infusion Rate"), + infrtu = colDef(name = "Infusion Rate Unit"), + tximod = colDef(name = "Infusion Modified?"), + txirmod = colDef(name = "Reason for Infusion modification"), + tximae = colDef(name = "AE related to Infusion Modification") + ) + tx_listing <- swimlane_ds |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> + select(all_of(names(col_defs))) + if (nrow(tx_listing) == 0) { + return() + } + + reactable( + tx_listing, + columns = col_defs, + defaultPageSize = 10, + wrap = FALSE, + searchable = TRUE, + sortable = TRUE + ) + }) + }) + } + module( + label = label, + ui = ui, + server = server, + datanames = "all", + ui_args = list(height = plot_height) + ) +} \ No newline at end of file From d028c8e0d66e38c50b309ab3ea19c5918cfff3fd Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 17:51:20 +0100 Subject: [PATCH 036/158] labels to the data --- R/tm_p_spiderplot.R | 200 ++++++++++++-------------------------------- 1 file changed, 52 insertions(+), 148 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index acefe34f8..d5cb40251 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -1,6 +1,5 @@ - -tm_p_spiderplot <- function(label = "Spiderplot", - time_var, +tm_p_spiderplot <- function(label = "Spiderplot", + time_var, subject_var, value_var, plot_height = 600) { @@ -70,12 +69,12 @@ ui_p_spiderplot <- function(id, height) { ) } -srv_p_spiderplot <- function(id, - data, +srv_p_spiderplot <- function(id, + data, time_var, subject_var, value_var, - filter_panel_api, + filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) @@ -98,7 +97,7 @@ srv_p_spiderplot <- function(id, y_title <- selected_event spiderplot_ds_filtered <- spiderplot_ds |> filter(event_type == selected_event) - + p <- plotly::plot_ly(source = "spiderplot", height = height) |> plotly::add_markers( x = ~time_var, y = ~value_var, color = ~subject_var, @@ -119,76 +118,40 @@ srv_p_spiderplot <- function(id, } ) }) - + output$plot <- plotly::renderPlotly({ plotly::event_register( plotly_q()$p, "plotly_selected" ) }) - + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - - - resp_cols <- .with_tooltips( - subject = colDef(name = "Subject"), - raise_query = colDef( - name = "Raise Query", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - visit_name = colDef(name = "Visit Name"), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") + + + resp_cols <- c( + subject, raise_query, visit_name, rspdn, rspd, rspd_study_day, + orsp, bma, bmb, comnts ) - - selected_recent_subject <- reactiveVal(NULL) - - data_w_brushed <- reactive({ - req(plotly_selected()) - within( - data(), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - expr = { - selected_subjects <- spiderplot_ds |> - filter(time_var %in% plotly_selected()$x, value_var %in% plotly_selected()$y) |> - pull(subject_var) - } - ) - }) - plotly_selected_subjects <- reactive({ - req(data_w_brushed()) - within( - data_w_brushed(), { - spiderplot_ds <- spiderplot_ds |> - filter(event_type == "latest_response_assessment") |> - filter(subject %in% selected_subjects) |> - select(all_of(names(resp_cols))) - } - ) + data()[["spiderplot_ds"]] |> + filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> + pull(subject) + }) + recent_resp_ds <- reactive({ + data()[["spiderplot_ds"]] |> + filter(event_type == "latest_response_assessment") |> + filter(subject %in% plotly_selected_subjects()) |> + select(all_of(resp_cols)) }) - + output$recent_resp <- renderReactable({ req(plotly_selected_subjects()) - reactable( recent_resp_ds(), - columns = resp_cols, + # columns = resp_cols, selection = "single", onClick = "select", defaultPageSize = 15, @@ -203,128 +166,69 @@ srv_p_spiderplot <- function(id, ") ) }) - + table_selected_subjects <- reactive({ selected_row <- getReactableState("recent_resp", "selected") if (!is.null(selected_row)) { - recent_resp_ds()[selected_row, ][[subject_var]] + recent_resp_ds()[selected_row, ]$subject } else { - unique(recent_resp_ds()[[subject_var]]) + unique(recent_resp_ds()$subject) } }) - + all_resp <- reactive({ data()[["spiderplot_ds"]] |> filter(event_type == "response_assessment") |> - select(all_of(names(resp_cols))) |> + select(all_of(resp_cols)) |> filter(subject %in% plotly_selected_subjects()) |> filter(subject %in% table_selected_subjects()) }) - + output$all_resp <- renderReactable({ if (nrow(all_resp()) == 0) { return() } - + reactable( all_resp(), - columns = resp_cols, + # columns = resp_cols, defaultPageSize = 15, wrap = FALSE ) }) - - spep_cols <- .with_tooltips( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lrspep1 = colDef(name = "Another Form added?"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") + + spep_cols <- with_tooltips( + subject, visit_name, visit_date, form_name, source_system_url_link, rspdn, rspd, rspd_study_day, orsp, bma, + bmb, comnts, asmntdn, blq, coldr, cold_study_day, coltm, coltmu, lrspep1, mprte_raw, mprtec ) - + spep <- reactive({ data()[["spiderplot_ds"]] |> filter(event_type == "Serum M-protein") |> filter(subject %in% table_selected_subjects()) |> - select(all_of(names(spep_cols))) + select(all_of(spep_cols)) }) - + output$spep_listing <- renderReactable({ if (nrow(spep()) == 0) { return() } - + reactable( spep(), - columns = spep_cols, + # columns = spep_cols, defaultPageSize = 5, wrap = FALSE ) }) - - - sflc_cols <- .with_tooltips( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lchfrc = colDef(name = "Presence of Serum free light chains"), - lchfr_raw = colDef(name = "Serum free light chain results"), - klchf_raw = colDef(name = "Kappa free light chain results"), - llchf_raw = colDef(name = "Lambda free light chain results"), - klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") + + + sflc_cols <- with_tooltips( + subject, visit_name, visit_date, form_name, source_system_url_link, rspdn, rspd, rspd_study_day, orsp, bma, + bmb, comnts, asmntdn, blq, coldr, cold_study_day, coltm, coltmu, lchfrc, lchfr_raw, klchf_raw, llchf_raw, + klchp_raw, mprte_raw, mprtec ) - + sflc <- reactive({ data()[["spiderplot_ds"]] |> filter( @@ -335,17 +239,17 @@ srv_p_spiderplot <- function(id, ) ) |> filter(subject %in% table_selected_subjects()) |> - select(all_of(names(sflc_cols))) + select(all_of(sflc_cols)) }) - + output$sflc_listing <- renderReactable({ if (nrow(sflc()) == 0) { return() } - + reactable( sflc(), - columns = sflc_cols, + # columns = sflc_cols, defaultPageSize = 5, wrap = FALSE ) From 78e1f2a1807c67870ea354f87ca962196f3d6b54 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 16:58:33 +0000 Subject: [PATCH 037/158] fix --- R/tm_p_spiderplot.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index d5cb40251..c9db0d7d4 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -130,8 +130,8 @@ srv_p_spiderplot <- function(id, resp_cols <- c( - subject, raise_query, visit_name, rspdn, rspd, rspd_study_day, - orsp, bma, bmb, comnts + "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", + "orsp", "bma", "bmb", "comnts" ) plotly_selected_subjects <- reactive({ @@ -197,9 +197,11 @@ srv_p_spiderplot <- function(id, ) }) - spep_cols <- with_tooltips( - subject, visit_name, visit_date, form_name, source_system_url_link, rspdn, rspd, rspd_study_day, orsp, bma, - bmb, comnts, asmntdn, blq, coldr, cold_study_day, coltm, coltmu, lrspep1, mprte_raw, mprtec + spep_cols <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", + "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", + "mprte_raw", "mprtec" ) spep <- reactive({ @@ -223,10 +225,11 @@ srv_p_spiderplot <- function(id, }) - sflc_cols <- with_tooltips( - subject, visit_name, visit_date, form_name, source_system_url_link, rspdn, rspd, rspd_study_day, orsp, bma, - bmb, comnts, asmntdn, blq, coldr, cold_study_day, coltm, coltmu, lchfrc, lchfr_raw, klchf_raw, llchf_raw, - klchp_raw, mprte_raw, mprtec + sflc_cols <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", + "klchp_raw", "mprte_raw", "mprtec" ) sflc <- reactive({ From 2c94370d94231b2318eb9ea04e5436b7a4be069e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 18:22:43 +0100 Subject: [PATCH 038/158] add reactable module --- R/tm_p_spiderplot.R | 16 +++++++-------- R/tm_t_reactable.R | 50 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 58 insertions(+), 8 deletions(-) create mode 100644 R/tm_t_reactable.R diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index c9db0d7d4..25cdbb85d 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -51,19 +51,19 @@ ui_p_spiderplot <- function(id, height) { div( class = "simple-card", h4("Disease Assessment - SFLC"), - reactableOutput(ns("sflc_listing")) + ui_t_reactable(ns("sflc_listing")) ), div( class = "simple-card", h4("Disease Assessment - SPEP"), - reactableOutput(ns("spep_listing")) + ui_t_reactable(ns("spep_listing")) ) ), div( class = "simple-card", style = "width: 50%", h4("Multiple Myeloma Response"), - reactableOutput(ns("all_resp")) + ui_t_reactable(ns("all_resp")) ) ) ) @@ -198,9 +198,9 @@ srv_p_spiderplot <- function(id, }) spep_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", - "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", + "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", "mprte_raw", "mprtec" ) @@ -226,8 +226,8 @@ srv_p_spiderplot <- function(id, sflc_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", "klchp_raw", "mprte_raw", "mprtec" ) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R new file mode 100644 index 000000000..e1ebd8c9d --- /dev/null +++ b/R/tm_t_reactable.R @@ -0,0 +1,50 @@ +#' @param ... () additional [reactable()] arguments +#' @export +tm_t_reactables <- function(label = "Table", datanames, transformators = list(), decorators = list(), ...) { + module( + label = label, + ui = ui_t_reactable, + srv = srv_t_reactable, + ui_args = list(decorators = decorators), + srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list(...)) + datanames = datanames, + transformers = transformers + ) +} + +ui_t_reactable <- function(id) { + ns <- NS(id) + div( + class = "simple-card", + reactable::reactableOutput(ns("table")) + ) +} + +srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, ...) { + moduleServer(id, function(input, output, session)) { + output$table <- reactable::renderReactable({ + req(data()) + dataset <- data()[[dataname]] + args <- modifyList( + list( + dataset, + columns = teal.data::col_labels(dataset) + selection = "single", + onClick = "select", + defaultPageSize = 15, + wrap = FALSE, + rowClass = JS(" + function(rowInfo) { + console.log(rowInfo); + if (rowInfo.selected) { + return 'selected-row'; + } + } + ") + ), + list(...) + ) + do.call(reactable::reactable, args = args) + }) + }) +} From 4f62e13addf2a23c990c2e70975a5d2653e9a74c Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 19:30:51 +0000 Subject: [PATCH 039/158] wip modularize --- R/tm_p_spiderplot.R | 254 ++++++++++++++++++++++---------------------- R/tm_t_reactable.R | 65 ++++++++---- 2 files changed, 169 insertions(+), 150 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 25cdbb85d..9bf83ef72 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -35,7 +35,7 @@ ui_p_spiderplot <- function(id, height) { style = "width: 50%", tagList( h4("Most Recent Resp and Best Resp"), - reactableOutput(ns("recent_resp")) + ui_t_reactable(ns("recent_resp")) ) ), div( @@ -51,12 +51,12 @@ ui_p_spiderplot <- function(id, height) { div( class = "simple-card", h4("Disease Assessment - SFLC"), - ui_t_reactable(ns("sflc_listing")) + reactable::reactableOutput(ns("sflc_listing")) ), div( class = "simple-card", h4("Disease Assessment - SPEP"), - ui_t_reactable(ns("spep_listing")) + reactable::reactableOutput(ns("spep_listing")) ) ), div( @@ -77,7 +77,8 @@ srv_p_spiderplot <- function(id, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { - spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) + dataname <- "spiderplot_ds" + spiderplot_ds <- reactive(data()[[dataname]]) observeEvent(spiderplot_ds(), { event_types <- unique(spiderplot_ds()$event_type) updateSelectInput( @@ -88,24 +89,25 @@ srv_p_spiderplot <- function(id, plotly_q <- reactive({ data() |> within( - selected_event = input$event_type, - height = input$plot_height, + dataname = str2lang(dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), time_var = str2lang(time_var), subject_var = str2lang(subject_var), value_var = str2lang(value_var), + selected_event = input$event_type, + height = input$plot_height, expr = { y_title <- selected_event - spiderplot_ds_filtered <- spiderplot_ds |> - filter(event_type == selected_event) + dataname_filtered <- filter(dataname, event_type == selected_event) p <- plotly::plot_ly(source = "spiderplot", height = height) |> plotly::add_markers( x = ~time_var, y = ~value_var, color = ~subject_var, - data = spiderplot_ds_filtered + data = dataname_filtered ) |> plotly::add_lines( x = ~time_var, y = ~value_var, color = ~subject_var, - data = spiderplot_ds_filtered, + data = dataname_filtered, showlegend = FALSE ) |> plotly::layout( @@ -120,10 +122,7 @@ srv_p_spiderplot <- function(id, }) output$plot <- plotly::renderPlotly({ - plotly::event_register( - plotly_q()$p, - "plotly_selected" - ) + plotly::event_register(plotly_q()$p, "plotly_selected") }) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) @@ -134,129 +133,126 @@ srv_p_spiderplot <- function(id, "orsp", "bma", "bmb", "comnts" ) - plotly_selected_subjects <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> - pull(subject) - }) - - recent_resp_ds <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "latest_response_assessment") |> - filter(subject %in% plotly_selected_subjects()) |> - select(all_of(resp_cols)) - }) - - output$recent_resp <- renderReactable({ - req(plotly_selected_subjects()) - reactable( - recent_resp_ds(), - # columns = resp_cols, - selection = "single", - onClick = "select", - defaultPageSize = 15, - wrap = FALSE, - rowClass = JS(" - function(rowInfo) { - console.log(rowInfo); - if (rowInfo.selected) { - return 'selected-row'; - } - } - ") - ) - }) - - table_selected_subjects <- reactive({ - selected_row <- getReactableState("recent_resp", "selected") - if (!is.null(selected_row)) { - recent_resp_ds()[selected_row, ]$subject - } else { - unique(recent_resp_ds()$subject) - } - }) - - all_resp <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "response_assessment") |> - select(all_of(resp_cols)) |> - filter(subject %in% plotly_selected_subjects()) |> - filter(subject %in% table_selected_subjects()) - }) - - output$all_resp <- renderReactable({ - if (nrow(all_resp()) == 0) { - return() - } - - reactable( - all_resp(), - # columns = resp_cols, - defaultPageSize = 15, - wrap = FALSE + plotly_selected_q <- reactive({ + req(plotly_selected()) + within( + plotly_q(), + dataname = str2lang(dataname), # todo: replace with argument + time_var = str2lang(time_var), + subject_var = subject_var, + value_var = str2lang(value_var), + time_vals = plotly_selected()$x, + value_vals = plotly_selected()$y, + expr = { + brushed_subjects <- dplyr::filter( + dataname, time_var %in% time_vals, value_var %in% value_vals + )[[subject_var]] + } ) }) - spep_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", - "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", - "mprte_raw", "mprtec" - ) - - spep <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "Serum M-protein") |> - filter(subject %in% table_selected_subjects()) |> - select(all_of(spep_cols)) - }) - - output$spep_listing <- renderReactable({ - if (nrow(spep()) == 0) { - return() - } - - reactable( - spep(), - # columns = spep_cols, - defaultPageSize = 5, - wrap = FALSE + recent_resp_q <- reactive({ + req(plotly_selected_q()) + within( + plotly_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + resp_cols = resp_cols, + expr = { + recent_resp <- dplyr::filter( + dataname, + event_type == "latest_response_assessment", + subject_var %in% brushed_subjects # todo: figure this out + ) |> + select(all_of(resp_cols)) + } ) }) - - - sflc_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", - "klchp_raw", "mprte_raw", "mprtec" - ) - - sflc <- reactive({ - data()[["spiderplot_ds"]] |> - filter( - event_type %in% c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" + + recent_resp_selected_q <- srv_t_reactable("recent_resp", data = recent_resp_q, dataname = "recent_resp") + # + all_resp_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + subject_var_char = subject_var, + expr = { + all_resp <- filter( + dataname, + event_type == "response_assessment", + subject_var == recent_resp_selected[[subject_var_char]] ) - ) |> - filter(subject %in% table_selected_subjects()) |> - select(all_of(sflc_cols)) - }) - - output$sflc_listing <- renderReactable({ - if (nrow(sflc()) == 0) { - return() - } - - reactable( - sflc(), - # columns = sflc_cols, - defaultPageSize = 5, - wrap = FALSE + } ) }) + + #todo: show all_resp only if recent_resp is selected + srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") + + # + # spep_cols <- c( + # "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + # "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", + # "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", + # "mprte_raw", "mprtec" + # ) + # + # spep <- reactive({ + # req(table_selected_subjects()) + # data()[["spiderplot_ds"]] |> + # filter(event_type == "Serum M-protein") |> + # filter(subject %in% table_selected_subjects()) |> + # select(all_of(spep_cols)) + # }) + # + # output$spep_listing <- renderReactable({ + # if (nrow(spep()) == 0) { + # return() + # } + # + # reactable( + # spep(), + # # columns = spep_cols, + # defaultPageSize = 5, + # wrap = FALSE + # ) + # }) + # + # + # sflc_cols <- c( + # "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + # "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + # "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", + # "klchp_raw", "mprte_raw", "mprtec" + # ) + # + # sflc <- reactive({ + # data()[["spiderplot_ds"]] |> + # filter( + # event_type %in% c( + # "Kappa free light chain quantity", + # "Lambda free light chain quantity", + # "Kappa-Lambda free light chain ratio" + # ) + # ) |> + # filter(subject %in% table_selected_subjects()) |> + # select(all_of(sflc_cols)) + # }) + # + # output$sflc_listing <- renderReactable({ + # if (nrow(sflc()) == 0) { + # return() + # } + # + # reactable( + # sflc(), + # # columns = sflc_cols, + # defaultPageSize = 5, + # wrap = FALSE + # ) + # }) }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index e1ebd8c9d..de72d3ed5 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -6,7 +6,7 @@ tm_t_reactables <- function(label = "Table", datanames, transformators = list(), ui = ui_t_reactable, srv = srv_t_reactable, ui_args = list(decorators = decorators), - srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list(...)) + srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list(...)), datanames = datanames, transformers = transformers ) @@ -21,30 +21,53 @@ ui_t_reactable <- function(id) { } srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, ...) { - moduleServer(id, function(input, output, session)) { - output$table <- reactable::renderReactable({ + moduleServer(id, function(input, output, session) { + dataname_reactable <- sprintf("%s_reactable", dataname) + table_q <- reactive({ req(data()) - dataset <- data()[[dataname]] - args <- modifyList( - list( - dataset, - columns = teal.data::col_labels(dataset) - selection = "single", - onClick = "select", - defaultPageSize = 15, - wrap = FALSE, - rowClass = JS(" + within( + data(), + dataname_reactable = str2lang(dataname_reactable), + dataname = str2lang(dataname), + { + dataname_reactable <- reactable::reactable( + dataname, + #columns = teal.data::col_labels(dataset), # todo: replace with labels + selection = "single", + onClick = "select", + defaultPageSize = 15, + wrap = FALSE, + rowClass = JS(" function(rowInfo) { - console.log(rowInfo); - if (rowInfo.selected) { - return 'selected-row'; + console.log(rowInfo); + if (rowInfo.selected) { + return 'selected-row'; + } } - } - ") - ), - list(...) + ") + ) + dataname_reactable + + } ) - do.call(reactable::reactable, args = args) }) + output$table <- reactable::renderReactable(table_q()[[dataname_reactable]]) + table_selected_q <- reactive({ + selected_row <- reactable::getReactableState("table", "selected") + if (!is.null(selected_row)) { + within( + table_q(), + selected_row = selected_row, + dataname_selected = str2lang(sprintf("%s_selected", dataname)), + dataname = str2lang(dataname), + expr = { + dataname_selected <- dataname[selected_row, ] + } + ) + } else { + table_q() + } + }) + table_selected_q }) } From 2065b713560d4373c644d3de70bb5f50ee0f442d Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Feb 2025 22:17:19 +0000 Subject: [PATCH 040/158] autolabels --- R/tm_p_spiderplot.R | 138 +++++++++++++++++++++----------------------- R/tm_t_reactable.R | 83 +++++++++++++++++--------- 2 files changed, 124 insertions(+), 97 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 9bf83ef72..ff5c984c2 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -51,12 +51,12 @@ ui_p_spiderplot <- function(id, height) { div( class = "simple-card", h4("Disease Assessment - SFLC"), - reactable::reactableOutput(ns("sflc_listing")) + ui_t_reactable(ns("sflc_listing")) ), div( class = "simple-card", h4("Disease Assessment - SPEP"), - reactable::reactableOutput(ns("spep_listing")) + ui_t_reactable(ns("spep_listing")) ) ), div( @@ -132,6 +132,18 @@ srv_p_spiderplot <- function(id, "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" ) + spep_cols <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", + "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", + "mprte_raw", "mprtec" + ) + sflc_cols <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", + "klchp_raw", "mprte_raw", "mprtec" + ) plotly_selected_q <- reactive({ req(plotly_selected()) @@ -169,8 +181,11 @@ srv_p_spiderplot <- function(id, ) }) - recent_resp_selected_q <- srv_t_reactable("recent_resp", data = recent_resp_q, dataname = "recent_resp") - # + recent_resp_selected_q <- srv_t_reactable( + "recent_resp", data = recent_resp_q, dataname = "recent_resp", selection = "single" + ) + + all_resp_q <- reactive({ req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) within( @@ -178,81 +193,62 @@ srv_p_spiderplot <- function(id, dataname = str2lang(dataname), subject_var = str2lang(subject_var), subject_var_char = subject_var, + resp_cols = resp_cols, expr = { - all_resp <- filter( + all_resp <- dplyr::filter( dataname, event_type == "response_assessment", - subject_var == recent_resp_selected[[subject_var_char]] - ) + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(resp_cols)) + } + ) + }) + spep_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + subject_var_char = subject_var, + spep_cols = spep_cols, + expr = { + spep <- dplyr::filter( + dataname, + event_type == "Serum M-protein", + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(spep_cols)) + } + ) + }) + sflc_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + subject_var_char = subject_var, + sflc_cols = sflc_cols, + expr = { + sflc <- dplyr::filter( + dataname, + event_type %in% c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ), + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(sflc_cols)) } ) }) #todo: show all_resp only if recent_resp is selected - srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") - - # - # spep_cols <- c( - # "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - # "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", - # "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", - # "mprte_raw", "mprtec" - # ) - # - # spep <- reactive({ - # req(table_selected_subjects()) - # data()[["spiderplot_ds"]] |> - # filter(event_type == "Serum M-protein") |> - # filter(subject %in% table_selected_subjects()) |> - # select(all_of(spep_cols)) - # }) - # - # output$spep_listing <- renderReactable({ - # if (nrow(spep()) == 0) { - # return() - # } - # - # reactable( - # spep(), - # # columns = spep_cols, - # defaultPageSize = 5, - # wrap = FALSE - # ) - # }) - # - # - # sflc_cols <- c( - # "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - # "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - # "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", - # "klchp_raw", "mprte_raw", "mprtec" - # ) - # - # sflc <- reactive({ - # data()[["spiderplot_ds"]] |> - # filter( - # event_type %in% c( - # "Kappa free light chain quantity", - # "Lambda free light chain quantity", - # "Kappa-Lambda free light chain ratio" - # ) - # ) |> - # filter(subject %in% table_selected_subjects()) |> - # select(all_of(sflc_cols)) - # }) - # - # output$sflc_listing <- renderReactable({ - # if (nrow(sflc()) == 0) { - # return() - # } - # - # reactable( - # sflc(), - # # columns = sflc_cols, - # defaultPageSize = 5, - # wrap = FALSE - # ) - # }) + all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") + spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep") + sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc") }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index de72d3ed5..e6cea5e7c 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -6,7 +6,7 @@ tm_t_reactables <- function(label = "Table", datanames, transformators = list(), ui = ui_t_reactable, srv = srv_t_reactable, ui_args = list(decorators = decorators), - srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list(...)), + srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list2(...)), datanames = datanames, transformers = transformers ) @@ -23,33 +23,34 @@ ui_t_reactable <- function(id) { srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, ...) { moduleServer(id, function(input, output, session) { dataname_reactable <- sprintf("%s_reactable", dataname) - table_q <- reactive({ - req(data()) - within( - data(), - dataname_reactable = str2lang(dataname_reactable), - dataname = str2lang(dataname), - { - dataname_reactable <- reactable::reactable( - dataname, - #columns = teal.data::col_labels(dataset), # todo: replace with labels - selection = "single", - onClick = "select", - defaultPageSize = 15, - wrap = FALSE, - rowClass = JS(" - function(rowInfo) { - console.log(rowInfo); - if (rowInfo.selected) { - return 'selected-row'; - } + + reactable_call <- reactive({ + default_args <- list( + columns = .make_reactable_columns_call(data()[[dataname]]), + onClick = "select", + defaultPageSize = 15, + wrap = FALSE, + rowClass = JS(" + function(rowInfo) { + if (rowInfo.selected) { + return 'selected-row'; } - ") - ) - dataname_reactable - - } + } + ") + ) + args <- modifyList(default_args, rlang::list2(...)) + substitute( + lhs <- rhs, + list( + lhs = dataname_reactable, + rhs = .make_reactable_call(dataname = dataname, args = args) + ) ) + + }) + table_q <- reactive({ + req(data()) + eval_code(data(), reactable_call()) }) output$table <- reactable::renderReactable(table_q()[[dataname_reactable]]) table_selected_q <- reactive({ @@ -71,3 +72,33 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. table_selected_q }) } + +.make_reactable_call <- function(dataname, args) { + args <- c( + list(data = str2lang(dataname)), + args + ) + do.call(call, c(list(name = "reactable"), args), quote = TRUE) + +} + +.make_reactable_columns_call <- function(dataset) { + # todo: what to do with urls? + args <- lapply( + teal.data::col_labels(dataset), + function(label) { + if (!is.null(label) && !is.na(label)) { + substitute( + colDef(name = label), + list(label = label) + ) + } + } + ) + args <- Filter(length, args) + if (length(args)) { + do.call(call, c(list("list"), args), quote = TRUE) + } +} + + From 7b5ed646d15468fd2878e1ac7da308064a4192e7 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Feb 2025 11:18:42 +0000 Subject: [PATCH 041/158] further abstraction --- R/tm_a_spiderplot_mdr.R | 184 +++++++++++++++++++++++++++++++++++++ R/tm_p_spiderplot.R | 199 ++++++++++------------------------------ 2 files changed, 234 insertions(+), 149 deletions(-) create mode 100644 R/tm_a_spiderplot_mdr.R diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R new file mode 100644 index 000000000..05620717a --- /dev/null +++ b/R/tm_a_spiderplot_mdr.R @@ -0,0 +1,184 @@ +tm_a_spiderplot_mdr <- function(label = "Spiderplot", + time_var, + subject_var, + value_var, + event_var, + resp_cols = c( + "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", + "orsp", "bma", "bmb", "comnts" + ), + spep_cols = c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lrspep1", "mprte_raw", "mprtec" + ), + sflc_cols = c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", + "klchp_raw", "mprte_raw", "mprtec" + ), + plot_height = 600) { + module( + label = label, + ui = ui_a_spiderplot_mdr, + server = srv_a_spiderplot_mdr, + ui_args = list(height = plot_height), + server_args = list( + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var, + resp_cols = resp_cols, + spep_cols = spep_cols, + sflc_cols = sflc_cols + ), + datanames = "all", + ) +} + + +ui_a_spiderplot_mdr <- function(id, height) { + ns <- NS(id) + tagList( + ui_p_spiderplot(ns("spiderplot"), height = height), + div( + style = "display: flex", + div( + style = "width: 50%", + div( + class = "simple-card", + h4("Disease Assessment - SFLC"), + ui_t_reactable(ns("sflc_listing")) + ), + div( + class = "simple-card", + h4("Disease Assessment - SPEP"), + ui_t_reactable(ns("spep_listing")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + h4("Multiple Myeloma Response"), + ui_t_reactable(ns("all_resp")) + ) + ) + ) +} + +srv_a_spiderplot_mdr <- function(id, + data, + time_var, + subject_var, + value_var, + event_var, + resp_cols, + spep_cols, + sflc_cols, + filter_panel_api, + plot_height = 600) { + moduleServer(id, function(input, output, session) { + dataname <- "spiderplot_ds" + recent_resp_selected_q <- srv_p_spiderplot( + "spiderplot", + data = data, + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var, + table_cols = resp_cols, + filter_panel_api = filter_panel_api, + plot_height = plot_height + ) + + all_resp_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + subject_var_char = subject_var, + event_var = str2lang(event_var), + resp_cols = resp_cols, + expr = { + all_resp <- dplyr::filter( + dataname, + event_var == "response_assessment", + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(resp_cols)) + } + ) + }) + + spep_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + subject_var_char = subject_var, + event_var = str2lang(event_var), + spep_cols = spep_cols, + expr = { + spep <- dplyr::filter( + dataname, + event_var == "Serum M-protein", + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(spep_cols)) + } + ) + }) + + sflc_q <- reactive({ + req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) + within( + recent_resp_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + event_var = str2lang(event_var), + subject_var_char = subject_var, + sflc_cols = sflc_cols, + expr = { + sflc <- dplyr::filter( + dataname, + event_var %in% c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ), + subject_var %in% unique(recent_resp_selected[[subject_var_char]]) + ) |> + select(all_of(sflc_cols)) + } + ) + }) + + #todo: show all_resp only if recent_resp is selected + all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") + spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep") + sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc") + + all_q <- reactive({ + # all_resp_selected_q could be nothing and `c` won't work because the result is unavailable before clicking subjects in the table + c(recent_resp_selected_q(), all_resp_selected_q()) + }) + + observeEvent(all_q(), { + "do nothing" + }) + + + }) +} + + +.with_tooltips <- function(...) { + args <- list(...) + lapply(args, function(col) { + col$header <- tags$span(col$name, title = col$name) + return(col) + }) +} diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index ff5c984c2..241d859f8 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -2,6 +2,8 @@ tm_p_spiderplot <- function(label = "Spiderplot", time_var, subject_var, value_var, + event_var, + table_cols, plot_height = 600) { module( label = label, @@ -11,7 +13,9 @@ tm_p_spiderplot <- function(label = "Spiderplot", server_args = list( time_var = time_var, subject_var = subject_var, - value_var = value_var + value_var = value_var, + event_var = event_var, + table_cols = table__cols ), datanames = "all", ) @@ -24,7 +28,7 @@ ui_p_spiderplot <- function(id, height) { div( style = "display: flex; justify-content: center; align-items: center; gap: 30px;", div( - selectInput(NS(id, "event_type"), "Select Y Axis", NULL) + selectInput(ns("select_event"), "Select Y Axis", NULL) ), div(sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) ), @@ -43,28 +47,6 @@ ui_p_spiderplot <- function(id, height) { style = "width: 50%", plotly::plotlyOutput(ns("plot"), height = "100%") ) - ), - div( - style = "display: flex", - div( - style = "width: 50%", - div( - class = "simple-card", - h4("Disease Assessment - SFLC"), - ui_t_reactable(ns("sflc_listing")) - ), - div( - class = "simple-card", - h4("Disease Assessment - SPEP"), - ui_t_reactable(ns("spep_listing")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - h4("Multiple Myeloma Response"), - ui_t_reactable(ns("all_resp")) - ) ) ) } @@ -74,77 +56,60 @@ srv_p_spiderplot <- function(id, time_var, subject_var, value_var, + event_var, + table_cols, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { dataname <- "spiderplot_ds" + excl_events <- c("response_assessment", "latest_response_assessment") spiderplot_ds <- reactive(data()[[dataname]]) observeEvent(spiderplot_ds(), { - event_types <- unique(spiderplot_ds()$event_type) - updateSelectInput( - inputId = "event_type", - choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] - ) + event_levels <- setdiff(unique(spiderplot_ds()[[event_var]]), excl_events) + updateSelectInput(inputId = "select_event", choices = event_levels) }) + plotly_q <- reactive({ - data() |> - within( - dataname = str2lang(dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - selected_event = input$event_type, - height = input$plot_height, - expr = { - y_title <- selected_event - dataname_filtered <- filter(dataname, event_type == selected_event) + within( + data(), + dataname = str2lang(dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + selected_event = input$select_event, + height = input$plot_height, + event_var = str2lang(event_var), + expr = { + y_title <- selected_event + dataname_filtered <- filter(dataname, event_var == selected_event) - p <- plotly::plot_ly(source = "spiderplot", height = height) |> - plotly::add_markers( - x = ~time_var, y = ~value_var, color = ~subject_var, - data = dataname_filtered - ) |> - plotly::add_lines( - x = ~time_var, y = ~value_var, color = ~subject_var, - data = dataname_filtered, - showlegend = FALSE - ) |> - plotly::layout( - xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), - yaxis = list(title = ~y_title), - title = ~ paste0(y_title, " Over Time") - ) |> - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) - } - ) + p <- plotly::plot_ly(source = "spiderplot", height = height) |> + plotly::add_markers( + x = ~time_var, y = ~value_var, color = ~subject_var, + data = dataname_filtered + ) |> + plotly::add_lines( + x = ~time_var, y = ~value_var, color = ~subject_var, + data = dataname_filtered, + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), + yaxis = list(title = ~y_title), + title = ~ paste0(y_title, " Over Time") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + } + ) }) - output$plot <- plotly::renderPlotly({ - plotly::event_register(plotly_q()$p, "plotly_selected") - }) + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - resp_cols <- c( - "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", - "orsp", "bma", "bmb", "comnts" - ) - spep_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts", - "asmntdn", "blq", "coldr", "cold_study_day", "coltm", "coltmu", "lrspep1", - "mprte_raw", "mprtec" - ) - sflc_cols <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", - "klchp_raw", "mprte_raw", "mprtec" - ) - plotly_selected_q <- reactive({ req(plotly_selected()) within( @@ -169,86 +134,22 @@ srv_p_spiderplot <- function(id, plotly_selected_q(), dataname = str2lang(dataname), subject_var = str2lang(subject_var), - resp_cols = resp_cols, + table_cols = table_cols, + event_var = str2lang(event_var), expr = { recent_resp <- dplyr::filter( dataname, - event_type == "latest_response_assessment", + event_var == "latest_response_assessment", subject_var %in% brushed_subjects # todo: figure this out ) |> - select(all_of(resp_cols)) + select(all_of(table_cols)) } ) }) - recent_resp_selected_q <- srv_t_reactable( + srv_t_reactable( "recent_resp", data = recent_resp_q, dataname = "recent_resp", selection = "single" ) - - - all_resp_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - resp_cols = resp_cols, - expr = { - all_resp <- dplyr::filter( - dataname, - event_type == "response_assessment", - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(resp_cols)) - } - ) - }) - spep_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - spep_cols = spep_cols, - expr = { - spep <- dplyr::filter( - dataname, - event_type == "Serum M-protein", - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(spep_cols)) - } - ) - }) - sflc_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - sflc_cols = sflc_cols, - expr = { - sflc <- dplyr::filter( - dataname, - event_type %in% c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" - ), - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(sflc_cols)) - } - ) - }) - - #todo: show all_resp only if recent_resp is selected - all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") - spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep") - sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc") }) } From 7426193f61c512dd04a4da498db16f12397ac732 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Feb 2025 12:25:07 +0000 Subject: [PATCH 042/158] fixes --- R/tm_a_spiderplot_mdr.R | 48 ++++++++++++++++++++++------------------- R/tm_data_table.R | 16 ++++++++------ R/tm_p_spiderplot.R | 15 +++++++------ R/tm_p_swimlane.R | 2 -- 4 files changed, 44 insertions(+), 37 deletions(-) diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index 05620717a..569ce07d0 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -1,30 +1,32 @@ tm_a_spiderplot_mdr <- function(label = "Spiderplot", - time_var, - subject_var, - value_var, - event_var, - resp_cols = c( - "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", - "orsp", "bma", "bmb", "comnts" - ), - spep_cols = c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lrspep1", "mprte_raw", "mprtec" - ), - sflc_cols = c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", - "klchp_raw", "mprte_raw", "mprtec" - ), - plot_height = 600) { + dataname, + time_var, + subject_var, + value_var, + event_var, + resp_cols = c( + "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", + "orsp", "bma", "bmb", "comnts" + ), + spep_cols = c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lrspep1", "mprte_raw", "mprtec" + ), + sflc_cols = c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", + "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", + "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", + "klchp_raw", "mprte_raw", "mprtec" + ), + plot_height = 600) { module( label = label, ui = ui_a_spiderplot_mdr, server = srv_a_spiderplot_mdr, ui_args = list(height = plot_height), server_args = list( + dataname = dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, @@ -33,7 +35,7 @@ tm_a_spiderplot_mdr <- function(label = "Spiderplot", spep_cols = spep_cols, sflc_cols = sflc_cols ), - datanames = "all", + datanames = dataname, ) } @@ -69,6 +71,7 @@ ui_a_spiderplot_mdr <- function(id, height) { srv_a_spiderplot_mdr <- function(id, data, + dataname, time_var, subject_var, value_var, @@ -79,10 +82,10 @@ srv_a_spiderplot_mdr <- function(id, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { - dataname <- "spiderplot_ds" recent_resp_selected_q <- srv_p_spiderplot( "spiderplot", data = data, + dataname = dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, @@ -92,6 +95,7 @@ srv_a_spiderplot_mdr <- function(id, plot_height = plot_height ) + # todo: whattodo with three specific reactives? all_resp_q <- reactive({ req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) within( diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 692d22df9..e103aecd8 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -206,10 +206,14 @@ srv_data_table <- function(id, if_filtered <- reactive(as.logical(input$if_filtered)) if_distinct <- reactive(as.logical(input$if_distinct)) - datanames <- Filter(function(name) { - is.data.frame(isolate(data())[[name]]) - }, if (identical(datanames, "all")) names(isolate(data())) else datanames) - + datanames_r <- reactive({ + Filter( + function(name) { + is.data.frame(data()[[name]]) + }, + if (identical(datanames, "all")) names(data()) else datanames + ) + }) output$dataset_table <- renderUI({ do.call( @@ -217,7 +221,7 @@ srv_data_table <- function(id, c( list(id = session$ns("dataname_tab")), lapply( - datanames(), + datanames_r(), function(x) { dataset <- isolate(data()[[x]]) choices <- names(dataset) @@ -258,7 +262,7 @@ srv_data_table <- function(id, # server should be run only once modules_run <- reactiveVal() - modules_to_run <- reactive(setdiff(datanames(), modules_run())) + modules_to_run <- reactive(setdiff(datanames_r(), modules_run())) observeEvent(modules_to_run(), { lapply( modules_to_run(), diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 241d859f8..bad055bab 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -4,7 +4,8 @@ tm_p_spiderplot <- function(label = "Spiderplot", value_var, event_var, table_cols, - plot_height = 600) { + plot_height = 600, + transformator = transformator) { module( label = label, ui = ui_p_spiderplot, @@ -38,7 +39,7 @@ ui_p_spiderplot <- function(id, height) { class = "simple-card", style = "width: 50%", tagList( - h4("Most Recent Resp and Best Resp"), + h4("Most Recent Resp and Best Resp"), # todo: whattodo? ui_t_reactable(ns("recent_resp")) ) ), @@ -53,6 +54,7 @@ ui_p_spiderplot <- function(id, height) { srv_p_spiderplot <- function(id, data, + dataname, time_var, subject_var, value_var, @@ -61,8 +63,7 @@ srv_p_spiderplot <- function(id, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { - dataname <- "spiderplot_ds" - excl_events <- c("response_assessment", "latest_response_assessment") + excl_events <- c("response_assessment", "latest_response_assessment") # todo: whattodo? spiderplot_ds <- reactive(data()[[dataname]]) observeEvent(spiderplot_ds(), { event_levels <- setdiff(unique(spiderplot_ds()[[event_var]]), excl_events) @@ -114,7 +115,7 @@ srv_p_spiderplot <- function(id, req(plotly_selected()) within( plotly_q(), - dataname = str2lang(dataname), # todo: replace with argument + dataname = str2lang(dataname), time_var = str2lang(time_var), subject_var = subject_var, value_var = str2lang(value_var), @@ -139,8 +140,8 @@ srv_p_spiderplot <- function(id, expr = { recent_resp <- dplyr::filter( dataname, - event_var == "latest_response_assessment", - subject_var %in% brushed_subjects # todo: figure this out + event_var == "latest_response_assessment", # todo: whattodo? + subject_var %in% brushed_subjects ) |> select(all_of(table_cols)) } diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index e0c9481a8..9daee6dde 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -28,8 +28,6 @@ srv_p_swimlane <- function(id, ggplot_call <- reactive({ plot_call <- bquote(ggplot2::ggplot()) points_calls <- lapply(geom_specs, function(x) { - # todo: convert $geom, $data, and $mapping elements from character to language - # others can be kept as character if (!is.null(x$mapping)) { x$mapping <- as.call(c(as.name("aes"), x$mapping)) } From c398ee846907412bb2dfb61205df919244d9bd1e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Feb 2025 16:22:22 +0000 Subject: [PATCH 043/158] swimlane module wip --- R/tm_a_spiderplot_mdr.R | 6 +- R/tm_p_spiderplot.R | 2 +- R/tm_p_swimlane.R | 289 +++++++++++++++++++++++++++++++++------- R/tm_p_swimlane2.r | 102 -------------- R/tm_swimlane.R | 287 --------------------------------------- 5 files changed, 245 insertions(+), 441 deletions(-) delete mode 100644 R/tm_p_swimlane2.r delete mode 100644 R/tm_swimlane.R diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index 569ce07d0..3a8f4eea9 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -161,9 +161,9 @@ srv_a_spiderplot_mdr <- function(id, }) #todo: show all_resp only if recent_resp is selected - all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp") - spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep") - sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc") + all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp", selection = NULL) + spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep", selection = NULL) + sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc", selection = NULL) all_q <- reactive({ # all_resp_selected_q could be nothing and `c` won't work because the result is unavailable before clicking subjects in the table diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index bad055bab..629ff8778 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -78,9 +78,9 @@ srv_p_spiderplot <- function(id, time_var = str2lang(time_var), subject_var = str2lang(subject_var), value_var = str2lang(value_var), + event_var = str2lang(event_var), selected_event = input$select_event, height = input$plot_height, - event_var = str2lang(event_var), expr = { y_title <- selected_event dataname_filtered <- filter(dataname, event_var == selected_event) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 9daee6dde..6194abccc 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,67 +1,260 @@ -tm_p_swimlane <- function(label = "Swimlane Plot Module", geom_specs, title) { +tm_p_swimlane <- function(label = "Swimlane", dataname, time_var, subject_var, value_var, event_var, plot_height = 700) { module( label = label, ui = ui_p_swimlane, server = srv_p_swimlane, datanames = "all", + ui_args = list(height = plot_height), server_args = list( - geom_specs = geom_specs, - title = title + dataname = dataname, + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var ) ) } -ui_p_swimlane <- function(id) { +ui_p_swimlane <- function(id, height) { ns <- NS(id) - shiny::tagList( - teal.widgets::plot_with_settings_ui(ns("myplot")), - teal::ui_brush_filter(ns("brush_filter")) + tagList( + fluidRow( + class = "simple-card", + h4("Swim Lane - Duration of Tx"), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), + plotly::plotlyOutput(ns("plot"), height = "100%") + ), + fluidRow( + column( + 6, + class = "simple-card", + tagList( + h4("Multiple Myeloma Response"), + ui_t_reactable(ns("mm_response")) + ) + ), + column( + 6, + class = "simple-card", + tagList( + h4("Study Tx Listing"), + ui_t_reactable(ns("tx_listing")) + ) + ) + ) ) } - -srv_p_swimlane <- function(id, - data, - geom_specs, - title = "Swimlane plot", - filter_panel_api) { +srv_p_swimlane <- function(id, + data, + dataname, + time_var, + subject_var, + value_var, + event_var, + filter_panel_api, + plot_height = 600) { moduleServer(id, function(input, output, session) { - ggplot_call <- reactive({ - plot_call <- bquote(ggplot2::ggplot()) - points_calls <- lapply(geom_specs, function(x) { - if (!is.null(x$mapping)) { - x$mapping <- as.call(c(as.name("aes"), x$mapping)) - } - basic_call <- as.call( - c( - list(x$geom), - x[!names(x) %in% "geom"] - ) + plotly_q <- reactive({ + data() |> + within( + dataname = str2lang(dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + event_var = str2lang(event_var), + subject_var_char = subject_var, + height = input$plot_height, + { + dataname <- dataname |> + mutate( + subject_var_char := forcats::fct_reorder(as.factor(subject_var), time_var, .fun = max), + tooltip = case_when( + event_var == "study_drug_administration" ~ paste( + "Subject:", subject_var, + "
Study Day:", time_var, + "
Administration:", value_var + ), + event_var == "response_assessment" ~ paste( + "Subject:", subject_var, + "
Study Day:", time_var, + "
Response Assessment:", value_var + ), + event_var == "disposition" ~ paste( + "Subject:", subject_var, + "
Study Day:", time_var, + "
Disposition:", value_var + ), + TRUE ~ NA_character_ + ) + ) + + dataname <- dataname |> + group_by(subject_var, time_var) |> + mutate(tooltip = paste(unique(tooltip), collapse = "
")) |> + ungroup() |> + mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) + + + disposition <- dataname |> + filter(!is.na(time_var)) |> + filter(event_var == "disposition") |> + mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") + + response_assessment <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "response_assessment") |> + mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") + + study_drug_administration <- swimlane_ds |> + filter(!is.na(event_study_day)) |> + filter(event_type == "study_drug_administration") |> + mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") + + max_subject_day <- swimlane_ds |> + group_by(subject_var) |> + summarise(study_day = max(time_var)) |> + bind_rows(tibble(subject_var_char := unique(dataname[[subject_var_char]]), study_day = 0)) + + p <- plotly::plot_ly( + source = "swimlane", + colors = c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue", + "X Administration Injection" = "goldenrod", + "Y Administration Infusion" = "deepskyblue3", + "Z Administration Infusion" = "darkorchid" + ), + symbols = c( + "DEATH" = "circle", + "WITHDRAWAL BY SUBJECT" = "square", + "PD (Progressive Disease)" = "circle", + "SD (Stable Disease)" = "square-open", + "MR (Minimal/Minor Response)" = "star-open", + "PR (Partial Response)" = "star-open", + "VGPR (Very Good Partial Response)" = "star-open", + "CR (Complete Response)" = "star-open", + "SCR (Stringent Complete Response)" = "star-open", + "X Administration Injection" = "line-ns-open", + "Y Administration Infusion" = "line-ns-open", + "Z Administration Infusion" = "line-ns-open" + ), + height = height + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = study_drug_administration + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = response_assessment + ) |> + plotly::add_markers( + x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, + text = ~tooltip, + hoverinfo = "text", + data = disposition + ) |> + plotly::add_segments( + x = ~0, xend = ~study_day, y = ~subject_var, yend = ~subject_var, + data = max_subject_day, + line = list(width = 1, color = "grey"), + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + }, + height = input$plot_height ) - }) - - title_call <- substitute(ggtitle(title), list(title = title)) - - rhs <- Reduce( - x = c(plot_call, points_calls, title_call), - f = function(x, y) call("+", x, y) + }) + + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) + + plotly_selected_q <- reactive({ + req(plotly_selected()) + within( + plotly_q(), + dataname = str2lang(dataname), + time_var = str2lang(time_var), + subject_var = subject_var, + value_var = str2lang(value_var), + time_vals = plotly_selected()$x, + value_vals = plotly_selected()$y, + expr = { + brushed_subjects <- dplyr::filter( + dataname, time_var %in% time_vals, value_var %in% value_vals + )[[subject_var]] + } ) - substitute(p <- rhs, list(rhs = rhs)) }) - - output_q <- reactive(eval_code(data(), ggplot_call())) - - plot_r <- reactive(output_q()$p) - pws <- teal.widgets::plot_with_settings_srv(id = "myplot", plot_r = plot_r) - - teal::srv_brush_filter( - "brush_filter", - brush = pws$brush, - dataset = reactive(teal.code::dev_suppress(output_q()$synthetic_data)), - filter_panel_api = filter_panel_api + + mm_response_vars <- c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" ) - }) -} + + tx_listing_vars <- c( + "site_name", "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "txnam", + "txrec", "txrecrs", "txd_study_day", "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", + "txdlyrs", "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", "txrmod", + "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", "txetm", "txetmu", "txtm", "txtmu", + "txed_study_day", "infrt", "infrtu", "tximod", "txirmod", "tximae" + ) + + mm_response_q <- reactive({ + within( + plotly_selected_q(), + dataname = str2lang(dataname), + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + time_vals = plotly_selected()$x, + subject_vals = plotly_selected()$y, + col_defs = mm_response_vars, + expr = { + mm_response <- dataname |> + filter(time_var %in% time_vals, subject_var %in% subject_vals) |> + select(all_of(col_defs)) + } + ) + + }) + + tx_listing_q <- reactive({ + within( + plotly_selected_q(), + dataname = str2lang(dataname), + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + time_vals = plotly_selected()$x, + subject_vals = plotly_selected()$y, + col_defs = tx_listing_vars, + expr = { + tx_listing <- dataname |> + filter(time_var %in% time_vals, subject_var %in% subject_vals) |> + select(all_of(col_defs)) + } + ) + + }) + + mm_reactable_q <- srv_t_reactable("mm_response", data = mm_response_q, dataname = "mm_response", selection = NULL) + tx_reactable_q <- srv_t_reactable("tx_listing", data = tx_listing_q, dataname = "tx_listing", selection = NULL) -merge_selectors2 <- function() { - lappl -} + }) +} \ No newline at end of file diff --git a/R/tm_p_swimlane2.r b/R/tm_p_swimlane2.r deleted file mode 100644 index a1fbef1be..000000000 --- a/R/tm_p_swimlane2.r +++ /dev/null @@ -1,102 +0,0 @@ -#' @export -tm_p_swimlane2 <- function( - label = "Swimlane Plot Module", plotly_specs, title, - colors = c(), symbols = c(), transformators = list(), - ui_mod = ui_data_table, - srv_mod = srv_data_table, - plot_height = 800) { - module( - label = label, - ui = ui_p_swimlane2, - server = srv_p_swimlane2, - datanames = "all", - ui_args = list(ui_mod = ui_mod, height = plot_height), - server_args = list( - plotly_specs = plotly_specs, - title = title, - colors = colors, - symbols = symbols, - srv_mod = srv_mod - ), - transformators = transformators - ) -} - - -ui_p_swimlane2 <- function(id, ui_mod, height) { - ns <- NS(id) - shiny::tagList( - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height), - plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_mod(ns("brush_tables")) - ) -} - -srv_p_swimlane2 <- function(id, - data, - plotly_specs, - title = "Swimlane plot", - colors, - symbols, - plot_source = "A", - srv_mod, - filter_panel_api) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - plotly_call <- .make_plotly_call( - specs = plotly_specs, - colors = colors, - symbols = symbols, - height = input$plot_height, - source = plot_source - ) - code <- substitute( - p <- plotly_call, - list(plotly_call = plotly_call) - ) - eval_code(data(), code = code) - }) - - output$plot <- plotly::renderPlotly({ - plotly::event_register( - plotly_q()$p, - "plotly_selected" - ) - }) - - plotly_selected <- reactive(plotly::event_data("plotly_selected"), source = plot_source) - - observeEvent(plotly_selected(), once = TRUE, { - if ("plotly_selected" %in% names(formals(srv_mod))) { - srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api, plotly_selected = plotly_selected) - } else { - srv_mod("brush_tables", data = data, filter_panel_api = filter_panel_api) - } - }) - }) -} - - - -.make_plotly_call <- function(specs, colors = c(), symbols = c(), height = 800, source = "A") { - init_call <- substitute( - plotly::plot_ly(source = source, colors = colors, symbols = symbols, height = height), - list(colors = colors, symbols = symbols, height = height) - ) - points_calls <- lapply(specs, function(x) { - which_fun <- c(which(names(x) == "fun"), 1)[1] - if (is.character(x[[which_fun]])) { - x[[which_fun]] <- str2lang(x[[which_fun]]) - } - as.call( - c( - list(x[[which_fun]]), - x[-which_fun] - ) - ) - }) - rhs <- Reduce( - x = c(init_call, points_calls), - f = function(x, y) call("%>%", x, y) - ) -} diff --git a/R/tm_swimlane.R b/R/tm_swimlane.R deleted file mode 100644 index 772f5ca03..000000000 --- a/R/tm_swimlane.R +++ /dev/null @@ -1,287 +0,0 @@ -tm_swimlane <- function(label = "Swimlane", plot_height = 700) { - ui <- function(id, height) { - ns <- NS(id) - tagList( - fluidRow( - class = "simple-card", - h4("Swim Lane - Duration of Tx"), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), - plotly::plotlyOutput(ns("plot"), height = "100%") - ), - fluidRow( - column( - 6, - class = "simple-card", - tagList( - h4("Multiple Myeloma Response"), - reactableOutput(ns("mm_response")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Study Tx Listing"), - reactableOutput(ns("tx_listing")) - ) - ) - ) - ) - } - server <- function(id, data, filter_panel_api, plot_height = 600) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - data() |> - within( - { - swimlane_ds <- swimlane_ds |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) |> - mutate( - subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max), - tooltip = case_when( - event_type == "study_drug_administration" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Administration:", event_result - ), - event_type == "response_assessment" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Response Assessment:", event_result - ), - event_type == "disposition" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Disposition:", event_result - ), - TRUE ~ NA_character_ - ) - ) - - swimlane_ds <- swimlane_ds |> - group_by(subject, event_study_day) |> - mutate( - tooltip = paste(unique(tooltip), collapse = "
") - ) |> - ungroup() |> - mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) - - disposition <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "disposition") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - response_assessment <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "response_assessment") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - study_drug_administration <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "study_drug_administration") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - max_subject_day <- swimlane_ds |> - group_by(subject) |> - summarise(study_day = max(event_study_day)) |> - bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) - - p <- plotly::plot_ly( - source = "swimlane", - colors = c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue", - "X Administration Injection" = "goldenrod", - "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid" - ), - symbols = c( - "DEATH" = "circle", - "WITHDRAWAL BY SUBJECT" = "square", - "PD (Progressive Disease)" = "circle", - "SD (Stable Disease)" = "square-open", - "MR (Minimal/Minor Response)" = "star-open", - "PR (Partial Response)" = "star-open", - "VGPR (Very Good Partial Response)" = "star-open", - "CR (Complete Response)" = "star-open", - "SCR (Stringent Complete Response)" = "star-open", - "X Administration Injection" = "line-ns-open", - "Y Administration Infusion" = "line-ns-open", - "Z Administration Infusion" = "line-ns-open" - ), - height = height - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = study_drug_administration - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = response_assessment - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = disposition - ) |> - plotly::add_segments( - x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, - data = max_subject_day, - line = list(width = 1, color = "grey"), - showlegend = FALSE - ) |> - plotly::layout( - xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") - ) |> - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) - }, - height = input$plot_height - ) - }) - - output$plot <- plotly::renderPlotly({ - plotly::event_register( - plotly_q()$p, - "plotly_selected" - ) - }) - - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) - - output$mm_response <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - col_defs <- .with_tooltips( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name", width = 250), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name", width = 250), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response", width = 250), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") - ) - mm_response <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> - select(all_of(names(col_defs))) - if (nrow(mm_response) == 0) { - return() - } - - reactable( - mm_response, - class = "custom-reactable", - columns = col_defs, - defaultPageSize = 10, - wrap = FALSE, - searchable = TRUE, - sortable = TRUE - ) - }) - - output$tx_listing <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - - col_defs <- .with_tooltips( - site_name = colDef(name = "Site Name"), - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - txnam = colDef(name = "Study Drug Name"), - txrec = colDef(name = "Study Drug Administered"), - txrecrs = colDef(name = "Reason Study Drug Not Admin"), - txd_study_day = colDef(name = "Date Administered Study Day"), - date_administered = colDef(name = "Date Administered"), - cydly = colDef(name = "Cycle Delay"), - cydlyrs = colDef(name = "Cycle Delay Reason"), - cydlyae = colDef(name = "Cycle Delay Adverse Event"), - txdly = colDef(name = "Dose Delay"), - txdlyrs = colDef(name = "Dose Delay Reason"), - txdlyae = colDef(name = "AE related to Dose Delay"), - txpdos = colDef(name = "Planned Dose per Admin"), - txpdosu = colDef(name = "Planned Dose per Admin Unit"), - frqdv = colDef(name = "Frequency"), - txrte = colDef(name = "Route of Administration"), - txform = colDef(name = "Dose Formulation"), - txdmod = colDef(name = "Dose Modification"), - txrmod = colDef(name = "Dose Modification Reason"), - txdmae = colDef(name = "AE related to Dose Modification"), - txad = colDef(name = "Total Dose Administered"), - txadu = colDef(name = "Total Dose Administered Unit"), - txd = colDef(name = "Date Administered"), - txstm = colDef(name = "Start Time Administered"), - txstmu = colDef(name = "Start Time Administered Unknown"), - txed = colDef(name = "End Date Administered"), - txetm = colDef(name = "End Time Administered"), - txetmu = colDef(name = "End Time Administered Unknown"), - txtm = colDef(name = "Time Administered"), - txtmu = colDef(name = "Time Administered Unknown"), - txed_study_day = colDef(name = "End Study Day"), - infrt = colDef(name = "Infusion Rate"), - infrtu = colDef(name = "Infusion Rate Unit"), - tximod = colDef(name = "Infusion Modified?"), - txirmod = colDef(name = "Reason for Infusion modification"), - tximae = colDef(name = "AE related to Infusion Modification") - ) - tx_listing <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> - select(all_of(names(col_defs))) - if (nrow(tx_listing) == 0) { - return() - } - - reactable( - tx_listing, - columns = col_defs, - defaultPageSize = 10, - wrap = FALSE, - searchable = TRUE, - sortable = TRUE - ) - }) - }) - } - module( - label = label, - ui = ui, - server = server, - datanames = "all", - ui_args = list(height = plot_height) - ) -} \ No newline at end of file From e68d78fd51bd5192600f9f23672276a9d72b13a9 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 28 Feb 2025 14:07:58 +0000 Subject: [PATCH 044/158] further changes .adjust_colors --- R/tm_a_spiderplot_mdr.R | 92 +- R/{tm_p_spiderplot.R => tm_g_spiderplot.R} | 108 +- R/{tm_p_swimlane.R => tm_g_swimlane.R} | 188 +- R/tm_g_waterfall.R | 113 + R/tm_t_reactable.R | 41 +- inst/poc_crf2.R | 4 +- inst/teal_app.lock | 5853 ++++++++++++++++++++ 7 files changed, 6203 insertions(+), 196 deletions(-) rename R/{tm_p_spiderplot.R => tm_g_spiderplot.R} (50%) rename R/{tm_p_swimlane.R => tm_g_swimlane.R} (50%) create mode 100644 R/tm_g_waterfall.R create mode 100644 inst/teal_app.lock diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index 3a8f4eea9..e7e481c6f 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -43,7 +43,25 @@ tm_a_spiderplot_mdr <- function(label = "Spiderplot", ui_a_spiderplot_mdr <- function(id, height) { ns <- NS(id) tagList( - ui_p_spiderplot(ns("spiderplot"), height = height), + + tagList( + div( + style = "display: flex", + div( + class = "simple-card", + style = "width: 50%", + tagList( + h4("Most Recent Resp and Best Resp"), + ui_t_reactable(ns("recent_resp")) + ) + ), + div( + class = "simple-card", + style = "width: 50%", + ui_g_spiderplot(ns("spiderplot"), height = height) + ) + ) + ), div( style = "display: flex", div( @@ -82,20 +100,60 @@ srv_a_spiderplot_mdr <- function(id, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { - recent_resp_selected_q <- srv_p_spiderplot( + # todo: plotly_excl_events should be a positive selection or tidyselect + # and exposed as arg + plotly_excl_events <- c("response_assessment", "latest_response_assessment") + plotly_data <- reactive({ + req(data()) + within( + data(), + dataname = str2lang(dataname), + event_var = str2lang(event_var), + plotly_excl_events = plotly_excl_events, + expr = spiderplot_data <- dplyr::filter(dataname, !event_var %in% plotly_excl_events) + ) + }) + plotly_selected_q <- srv_g_spiderplot( "spiderplot", - data = data, - dataname = dataname, + data = plotly_data, + dataname = "spiderplot_data", time_var = time_var, subject_var = subject_var, value_var = value_var, event_var = event_var, - table_cols = resp_cols, filter_panel_api = filter_panel_api, plot_height = plot_height ) - # todo: whattodo with three specific reactives? + recent_resp_q <- reactive({ + req(plotly_selected_q()) + within( + plotly_selected_q(), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var), + event_var = str2lang(event_var), + recent_resp_event = "latest_response_assessment", # todo: whattodo? + resp_cols = resp_cols, + expr = { + recent_resp <- dplyr::filter( + dataname, + event_var %in% recent_resp_event, + subject_var %in% brushed_subjects + ) |> + select(all_of(resp_cols)) + } + ) + }) + + recent_resp_selected_q <- srv_t_reactable( + "recent_resp", data = recent_resp_q, dataname = "recent_resp", selection = "single" + ) + + # todo: these tables do have the same filters and select. It is just a matter of parametrising + # to named list: + # - (table) label + # - event_level for filter + # - columns all_resp_q <- reactive({ req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) within( @@ -104,11 +162,12 @@ srv_a_spiderplot_mdr <- function(id, subject_var = str2lang(subject_var), subject_var_char = subject_var, event_var = str2lang(event_var), + all_resp_events = "response_assessment", resp_cols = resp_cols, expr = { all_resp <- dplyr::filter( dataname, - event_var == "response_assessment", + event_var %in% all_resp_events, subject_var %in% unique(recent_resp_selected[[subject_var_char]]) ) |> select(all_of(resp_cols)) @@ -124,11 +183,12 @@ srv_a_spiderplot_mdr <- function(id, subject_var = str2lang(subject_var), subject_var_char = subject_var, event_var = str2lang(event_var), + spep_events = "Serum M-protein", spep_cols = spep_cols, expr = { spep <- dplyr::filter( dataname, - event_var == "Serum M-protein", + event_var %in% spep_events, subject_var %in% unique(recent_resp_selected[[subject_var_char]]) ) |> select(all_of(spep_cols)) @@ -142,17 +202,18 @@ srv_a_spiderplot_mdr <- function(id, recent_resp_selected_q(), dataname = str2lang(dataname), subject_var = str2lang(subject_var), - event_var = str2lang(event_var), subject_var_char = subject_var, + event_var = str2lang(event_var), + sflc_events = c( + "Kappa free light chain quantity", + "Lambda free light chain quantity", + "Kappa-Lambda free light chain ratio" + ), sflc_cols = sflc_cols, expr = { sflc <- dplyr::filter( dataname, - event_var %in% c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" - ), + event_var %in% sflc_events, subject_var %in% unique(recent_resp_selected[[subject_var_char]]) ) |> select(all_of(sflc_cols)) @@ -166,6 +227,7 @@ srv_a_spiderplot_mdr <- function(id, sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc", selection = NULL) all_q <- reactive({ + req(recent_resp_selected_q(), all_resp_selected_q()) # all_resp_selected_q could be nothing and `c` won't work because the result is unavailable before clicking subjects in the table c(recent_resp_selected_q(), all_resp_selected_q()) }) @@ -179,6 +241,8 @@ srv_a_spiderplot_mdr <- function(id, } + + .with_tooltips <- function(...) { args <- list(...) lapply(args, function(col) { diff --git a/R/tm_p_spiderplot.R b/R/tm_g_spiderplot.R similarity index 50% rename from R/tm_p_spiderplot.R rename to R/tm_g_spiderplot.R index 629ff8778..b28595d63 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -1,106 +1,96 @@ -tm_p_spiderplot <- function(label = "Spiderplot", +tm_g_spiderplot <- function(label = "Spiderplot", time_var, subject_var, value_var, event_var, - table_cols, plot_height = 600, transformator = transformator) { module( label = label, - ui = ui_p_spiderplot, - server = srv_p_spiderplot, + ui = ui_g_spiderplot, + server = srv_g_spiderplot, ui_args = list(height = plot_height), server_args = list( time_var = time_var, subject_var = subject_var, value_var = value_var, - event_var = event_var, - table_cols = table__cols + event_var = event_var ), datanames = "all", ) } -ui_p_spiderplot <- function(id, height) { +ui_g_spiderplot <- function(id, height) { ns <- NS(id) - tagList( + div( div( - style = "display: flex; justify-content: center; align-items: center; gap: 30px;", + class = "simple-card", div( - selectInput(ns("select_event"), "Select Y Axis", NULL) + class = "row", + column( + width = 6, + selectInput(ns("select_event"), "Select Y Axis", NULL) + ), + column( + width = 6, + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + ) ), - div(sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) - ), - div( - style = "display: flex", - div( - class = "simple-card", - style = "width: 50%", - tagList( - h4("Most Recent Resp and Best Resp"), # todo: whattodo? - ui_t_reactable(ns("recent_resp")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - plotly::plotlyOutput(ns("plot"), height = "100%") - ) + plotly::plotlyOutput(ns("plot"), height = "100%") ) ) } -srv_p_spiderplot <- function(id, +srv_g_spiderplot <- function(id, data, dataname, time_var, subject_var, value_var, event_var, - table_cols, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { - excl_events <- c("response_assessment", "latest_response_assessment") # todo: whattodo? - spiderplot_ds <- reactive(data()[[dataname]]) - observeEvent(spiderplot_ds(), { - event_levels <- setdiff(unique(spiderplot_ds()[[event_var]]), excl_events) - updateSelectInput(inputId = "select_event", choices = event_levels) + event_levels <- reactive({ + req(data()) + unique(data()[[dataname]][[event_var]]) + }) + observeEvent(event_levels(), { + updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) }) plotly_q <- reactive({ + # todo: tooltip! + req(input$select_event) within( data(), dataname = str2lang(dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), time_var = str2lang(time_var), subject_var = str2lang(subject_var), value_var = str2lang(value_var), event_var = str2lang(event_var), selected_event = input$select_event, height = input$plot_height, + xaxis_label = attr(data()[[dataname]][[time_var]], "label"), + yaxis_label = input$select_event, + title = paste0(input$select_event, " Over Time"), expr = { - y_title <- selected_event - dataname_filtered <- filter(dataname, event_var == selected_event) - - p <- plotly::plot_ly(source = "spiderplot", height = height) |> + p <- dataname |> filter(event_var == selected_event)|> + plotly::plot_ly(source = "spiderplot", height = height) |> plotly::add_markers( - x = ~time_var, y = ~value_var, color = ~subject_var, - data = dataname_filtered + x = ~time_var, y = ~value_var, color = ~subject_var ) |> plotly::add_lines( x = ~time_var, y = ~value_var, color = ~subject_var, - data = dataname_filtered, showlegend = FALSE ) |> plotly::layout( - xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), - yaxis = list(title = ~y_title), - title = ~ paste0(y_title, " Over Time") + xaxis = list(title = xaxis_label, zeroline = FALSE), + yaxis = list(title = yaxis_label), + title = title, + dragmode = "select" ) |> - plotly::layout(dragmode = "select") |> plotly::config(displaylogo = FALSE) } ) @@ -110,8 +100,7 @@ srv_p_spiderplot <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - - plotly_selected_q <- reactive({ + reactive({ req(plotly_selected()) within( plotly_q(), @@ -128,29 +117,6 @@ srv_p_spiderplot <- function(id, } ) }) - - recent_resp_q <- reactive({ - req(plotly_selected_q()) - within( - plotly_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - table_cols = table_cols, - event_var = str2lang(event_var), - expr = { - recent_resp <- dplyr::filter( - dataname, - event_var == "latest_response_assessment", # todo: whattodo? - subject_var %in% brushed_subjects - ) |> - select(all_of(table_cols)) - } - ) - }) - - srv_t_reactable( - "recent_resp", data = recent_resp_q, dataname = "recent_resp", selection = "single" - ) }) } diff --git a/R/tm_p_swimlane.R b/R/tm_g_swimlane.R similarity index 50% rename from R/tm_p_swimlane.R rename to R/tm_g_swimlane.R index 6194abccc..9d41e19f1 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_g_swimlane.R @@ -1,8 +1,16 @@ -tm_p_swimlane <- function(label = "Swimlane", dataname, time_var, subject_var, value_var, event_var, plot_height = 700) { +tm_g_swimlane <- function(label = "Swimlane", + dataname, + time_var, + subject_var, + value_var, + event_var, + value_var_color, + value_var_symbol, + plot_height = 700) { module( label = label, - ui = ui_p_swimlane, - server = srv_p_swimlane, + ui = ui_g_swimlane, + server = srv_g_swimlane, datanames = "all", ui_args = list(height = plot_height), server_args = list( @@ -10,12 +18,14 @@ tm_p_swimlane <- function(label = "Swimlane", dataname, time_var, subject_var, v time_var = time_var, subject_var = subject_var, value_var = value_var, - event_var = event_var + event_var = event_var, + value_var_color = value_var_color, + value_var_symbol = value_var_symbol ) ) } -ui_p_swimlane <- function(id, height) { +ui_g_swimlane <- function(id, height) { ns <- NS(id) tagList( fluidRow( @@ -44,17 +54,24 @@ ui_p_swimlane <- function(id, height) { ) ) } -srv_p_swimlane <- function(id, +srv_g_swimlane <- function(id, data, dataname, time_var, subject_var, value_var, event_var, + value_var_color, + value_var_symbol, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ + req(data()) + adjusted_colors <- .adjust_colors( + x = unique(data()[[dataname]][[value_var]]), + predefined = value_var_color + ) data() |> within( dataname = str2lang(dataname), @@ -63,122 +80,58 @@ srv_p_swimlane <- function(id, subject_var = str2lang(subject_var), value_var = str2lang(value_var), event_var = str2lang(event_var), - subject_var_char = subject_var, + colors = adjusted_colors, + symbols = value_var_symbol, height = input$plot_height, + filtered_events = c("disposition","response_assessment", "study_drug_administration"), + xaxis_label = "Study Day", + yaxis_label = "Subject", { dataname <- dataname |> + mutate(subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), time_var, .fun = max)) |> + group_by(subject_var, time_var) |> mutate( - subject_var_char := forcats::fct_reorder(as.factor(subject_var), time_var, .fun = max), - tooltip = case_when( - event_var == "study_drug_administration" ~ paste( - "Subject:", subject_var, - "
Study Day:", time_var, - "
Administration:", value_var - ), - event_var == "response_assessment" ~ paste( - "Subject:", subject_var, - "
Study Day:", time_var, - "
Response Assessment:", value_var - ), - event_var == "disposition" ~ paste( - "Subject:", subject_var, - "
Study Day:", time_var, - "
Disposition:", value_var - ), - TRUE ~ NA_character_ + tooltip = paste( + "Subject:", subject_var, + "
Study Day:", time_var, + paste( + unique( + sprintf("
%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) + ), + collapse = "" + ) ) ) + - dataname <- dataname |> - group_by(subject_var, time_var) |> - mutate(tooltip = paste(unique(tooltip), collapse = "
")) |> - ungroup() |> - mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) - - - disposition <- dataname |> - filter(!is.na(time_var)) |> - filter(event_var == "disposition") |> - mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") - - response_assessment <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "response_assessment") |> - mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") - - study_drug_administration <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "study_drug_administration") |> - mutate(subject_var, event_var, catagory = value_var, study_day = time_var, tooltip, .keep = "none") - - max_subject_day <- swimlane_ds |> - group_by(subject_var) |> - summarise(study_day = max(time_var)) |> - bind_rows(tibble(subject_var_char := unique(dataname[[subject_var_char]]), study_day = 0)) - - p <- plotly::plot_ly( + p <- dataname |> + dplyr::filter( + event_var %in% filtered_events, + !is.na(time_var) + ) |> + plotly::plot_ly( source = "swimlane", - colors = c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue", - "X Administration Injection" = "goldenrod", - "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid" - ), - symbols = c( - "DEATH" = "circle", - "WITHDRAWAL BY SUBJECT" = "square", - "PD (Progressive Disease)" = "circle", - "SD (Stable Disease)" = "square-open", - "MR (Minimal/Minor Response)" = "star-open", - "PR (Partial Response)" = "star-open", - "VGPR (Very Good Partial Response)" = "star-open", - "CR (Complete Response)" = "star-open", - "SCR (Stringent Complete Response)" = "star-open", - "X Administration Injection" = "line-ns-open", - "Y Administration Infusion" = "line-ns-open", - "Z Administration Infusion" = "line-ns-open" - ), + colors = colors, + symbols = symbols, height = height ) |> plotly::add_markers( - x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, + x = ~time_var, y = ~subject_var_ordered, color = ~value_var, symbol = ~value_var, text = ~tooltip, - hoverinfo = "text", - data = study_drug_administration - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = response_assessment - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject_var, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = disposition + hoverinfo = "text" ) |> plotly::add_segments( - x = ~0, xend = ~study_day, y = ~subject_var, yend = ~subject_var, - data = max_subject_day, + x = ~0, xend = ~study_day, y = ~subject_var_ordered, yend = ~subject_var_ordered, + data = dataname |> group_by(subject_var_ordered) |> summarise(study_day = max(time_var)), line = list(width = 1, color = "grey"), showlegend = FALSE ) |> plotly::layout( - xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") + xaxis = list(title = xaxis_label), yaxis = list(title = yaxis_label) ) |> plotly::layout(dragmode = "select") |> plotly::config(displaylogo = FALSE) - }, - height = input$plot_height + } ) }) @@ -257,4 +210,35 @@ srv_p_swimlane <- function(id, tx_reactable_q <- srv_t_reactable("tx_listing", data = tx_listing_q, dataname = "tx_listing", selection = NULL) }) -} \ No newline at end of file +} + +.adjust_colors <- function(x, predefined) { + p <- predefined[names(predefined) %in% x] + p_rgb_num <- col2rgb(p) + p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) + p <- setNames(p_hex, names(p)) + missing_x <- setdiff(x, names(p)) + N <- length(x) + n <- length(p) + m <- N - n + adjusted_colors <- if (m & n) { + current_space <- rgb2hsv(col2rgb(p)) + optimal_color_space <- colorspace::qualitative_hcl(N) + color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) + optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] + furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) + missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] + missing_colors <- setNames(missing_colors, missing_x) + p <- c(p, missing_colors) + } else if (n) { + # todo: generate color palette + hsv( + h = seq(0, by = 1/N, length.out = N + 1), + s = 1, + v = 1 + ) + } else { + p + } +} + diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R new file mode 100644 index 000000000..cac455bab --- /dev/null +++ b/R/tm_g_waterfall.R @@ -0,0 +1,113 @@ +tm_g_waterfall <- function(label = "Waterfall", time_var, subject_var, value_var, event_var, plot_height = 700) { + time_var$dataname <- "ADRS" + subject_var$dataname <- "ADRS" + value_var$dataname <- "ADRS" + event_var$dataname <- "ADRS" + module( + label = label, + ui = ui_g_waterfall, + server = srv_g_waterfall, + datanames = "all", + ui_args = list(height = plot_height), + server_args = list( + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var + ) + ) +} + +ui_g_waterfall <- function(id, height) { + ns <- NS(id) + tagList( + fluidRow( + class = "simple-card", + div( + class = "row", + column( + width = 4, + selectInput(ns("select_event"), "Select Y Axis (to remove)", NULL) + ), + column( + width = 4, + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + ), + column( + width = 4, + sliderInput(ns("color_by"), "Plot Height (px)", 400, 1200, height) + ) + ), + h4("Waterfall"), + plotly::plotlyOutput(ns("plot"), height = "100%") + ), + fluidRow( + h4("All lesions"), + ui_t_reactable(ns("all_lesions")) + + ) + ) +} +srv_g_waterfall <- function(id, + data, + dataname, + time_var, + subject_var, + value_var, + event_var, + filter_panel_api, + plot_height = 600) { + moduleServer(id, function(input, output, session) { + event_levels <- reactive({ + req(data()) + unique(data()[[event_var$dataname]][[event_var$selected]]) + }) + observeEvent(event_levels(), { + updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) + }) + + plotly_q <- reactive({ + data() |> + within( + dataname = str2lang(time_var$dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", time_var$dataname)), + time_var = str2lang(time_var$selected), + subject_var = str2lang(subject_var$selected), + value_var = str2lang(value_var$selected), + event_var = str2lang(event_var$selected), + selected_event = input$select_event, + height = input$plot_height, + xaxis_label = attr(data()[[subject_var$dataname]][[subject_var$selected]], "label"), + yaxis_label = input$select_event, + title = paste0(input$select_event, " Over Time"), + expr = { + p <- dataname |> + dplyr::filter(event_var %in% selected_event) |> + dplyr::mutate( + subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE) + ) |> + # todo: one value for x, y: distinct or summarize(value = foo(value_var)) [foo: summarize_fun] + plotly::plot_ly( + source = "waterfall", + height = height + ) |> + plotly::add_bars( + x = ~subject_var_ordered, y = ~value_var, + showlegend = FALSE + ) |> + plotly::layout( + xaxis = list(title = xaxis_label), yaxis = list(title = yaxis_label) + ) |> + plotly::layout(dragmode = "select") |> + plotly::config(displaylogo = FALSE) + }, + height = input$plot_height + ) + }) + + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) + + }) +} \ No newline at end of file diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index e6cea5e7c..2b0f941fd 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -82,19 +82,46 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. } +#' Makes `reactable::colDef` call containing: +#' name = +#' cell = +#' Arguments of [reactable::colDef()] are specified only if necessary +#' @param dataset (`data.frame`) +#' @return named list of `colDef` calls +#' @keywords internal .make_reactable_columns_call <- function(dataset) { - # todo: what to do with urls? + checkmate::assert_data_frame(dataset) args <- lapply( - teal.data::col_labels(dataset), - function(label) { - if (!is.null(label) && !is.na(label)) { - substitute( - colDef(name = label), - list(label = label) + seq_along(dataset), + function(i) { + label <- attr(dataset[[i]], "label") + is_labelled <- length(label) == 1 && !is.na(label) && !identical(label, "") + is_url <- is.character(dataset[[i]]) && any( + grepl( + "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", + x = head(dataset[[i]]), + perl = TRUE + ) + ) + + args <- c( + if (is_labelled) list(name = label), + if (is_url) list(cell = quote(function(value) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + }) ) + ) + + if (length(args)) { + do.call(call, c(list(name = "colDef"), args), quote = TRUE) } } ) + names(args) <- names(dataset) args <- Filter(length, args) if (length(args)) { do.call(call, c(list("list"), args), quote = TRUE) diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R index 812ea3e46..412cb07fb 100644 --- a/inst/poc_crf2.R +++ b/inst/poc_crf2.R @@ -2,7 +2,7 @@ library(teal) library(DT) library(labelled) library(reactable) -pkgload::load_all("teal.modules.general") +#pkgload::load_all("teal.modules.general") # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data with_tooltips <- function(...) { @@ -17,7 +17,7 @@ data <- within(teal_data(), { library(dplyr) library(arrow) library(forcats) - data_path <- "PATH_TO_DATA" + data_path <- "/ocean/harbour/CDT70436/GO43979/CSRInterim_roak_upver/dev/data/other/mdr_spotfire/" swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> filter(!is.na(event_result), !is.na(event_study_day)) |> diff --git a/inst/teal_app.lock b/inst/teal_app.lock new file mode 100644 index 000000000..9bbf330de --- /dev/null +++ b/inst/teal_app.lock @@ -0,0 +1,5853 @@ +{ + "R": { + "Version": "4.4.1", + "Repositories": [ + { + "Name": "NON_VALIDATED", + "URL": "https://packages.roche.com/Non-Validated/2024-10-14+2K_YKWmH" + }, + { + "Name": "CRAN", + "URL": "https://packages.roche.com/CRAN/2024-10-14" + } + ] + }, + "Packages": { + "DT": { + "Package": "DT", + "Version": "0.33", + "Source": "Repository", + "Type": "Package", + "Title": "A Wrapper of the JavaScript Library 'DataTables'", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = \"aut\"), person(\"Joe\", \"Cheng\", email = \"joe@posit.co\", role = c(\"aut\", \"cre\")), person(\"Xianying\", \"Tan\", role = \"aut\"), person(\"JJ\", \"Allaire\", role = \"ctb\"), person(\"Maximilian\", \"Girlich\", role = \"ctb\"), person(\"Greg\", \"Freedman Ellis\", role = \"ctb\"), person(\"Johannes\", \"Rauh\", role = \"ctb\"), person(\"SpryMedia Limited\", role = c(\"ctb\", \"cph\"), comment = \"DataTables in htmlwidgets/lib\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js in htmlwidgets/lib\"), person(\"Leon\", \"Gersen\", role = c(\"ctb\", \"cph\"), comment = \"noUiSlider in htmlwidgets/lib\"), person(\"Bartek\", \"Szopka\", role = c(\"ctb\", \"cph\"), comment = \"jquery.highlight.js in htmlwidgets/lib\"), person(\"Alex\", \"Pickering\", role = c(\"ctb\")), person(\"William\", \"Holmes\", role = c(\"ctb\")), person(\"Mikko\", \"Marttila\", role = c(\"ctb\")), person(\"Andres\", \"Quintero\", role = c(\"ctb\")), person(\"Stéphane\", \"Laurent\", role = c(\"ctb\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Data objects in R can be rendered as HTML tables using the JavaScript library 'DataTables' (typically via R Markdown or Shiny). The 'DataTables' library has been included in this R package. The package name 'DT' is an abbreviation of 'DataTables'.", + "URL": "https://github.com/rstudio/DT", + "BugReports": "https://github.com/rstudio/DT/issues", + "License": "GPL-3 | file LICENSE", + "Imports": [ + "htmltools (>= 0.3.6)", + "htmlwidgets (>= 1.3)", + "httpuv", + "jsonlite (>= 0.9.16)", + "magrittr", + "crosstalk", + "jquerylib", + "promises" + ], + "Suggests": [ + "knitr (>= 1.8)", + "rmarkdown", + "shiny (>= 1.6)", + "bslib", + "future", + "testit", + "tibble" + ], + "VignetteBuilder": "knitr", + "RoxygenNote": "7.3.1", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Yihui Xie [aut], Joe Cheng [aut, cre], Xianying Tan [aut], JJ Allaire [ctb], Maximilian Girlich [ctb], Greg Freedman Ellis [ctb], Johannes Rauh [ctb], SpryMedia Limited [ctb, cph] (DataTables in htmlwidgets/lib), Brian Reavis [ctb, cph] (selectize.js in htmlwidgets/lib), Leon Gersen [ctb, cph] (noUiSlider in htmlwidgets/lib), Bartek Szopka [ctb, cph] (jquery.highlight.js in htmlwidgets/lib), Alex Pickering [ctb], William Holmes [ctb], Mikko Marttila [ctb], Andres Quintero [ctb], Stéphane Laurent [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Joe Cheng ", + "Repository": "RSPM" + }, + "DescTools": { + "Package": "DescTools", + "Version": "0.99.59", + "Source": "Repository", + "Type": "Package", + "Title": "Tools for Descriptive Statistics", + "Date": "2025-01-25", + "Authors@R": "c( person(given=\"Andri\", family=\"Signorell\", email = \"andri@signorell.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4311-1969\")), person(\"Ken\" , \"Aho\", role = c(\"ctb\")), person(\"Andreas\" , \"Alfons\", role = c(\"ctb\")), person(\"Nanina\" , \"Anderegg\", role = c(\"ctb\")), person(\"Tomas\" , \"Aragon\", role = c(\"ctb\")), person(\"Chandima\" , \"Arachchige\", role = c(\"ctb\")), person(\"Antti\" , \"Arppe\", role = c(\"ctb\")), person(\"Adrian\" , \"Baddeley\", role = c(\"ctb\")), person(\"Kamil\" , \"Barton\", role = c(\"ctb\")), person(\"Ben\" , \"Bolker\", role = c(\"ctb\")), person(\"Hans W.\" , \"Borchers\", role = c(\"ctb\")), person(\"Frederico\" , \"Caeiro\", role = c(\"ctb\")), person(\"Stephane\" , \"Champely\", role = c(\"ctb\")), person(\"Daniel\" , \"Chessel\", role = c(\"ctb\")), person(\"Leanne\" , \"Chhay\", role = c(\"ctb\")), person(\"Nicholas\" , \"Cooper\", role = c(\"ctb\")), person(\"Clint\" , \"Cummins\", role = c(\"ctb\")), person(\"Michael\" , \"Dewey\", role = c(\"ctb\")), person(\"Harold C.\" , \"Doran\", role = c(\"ctb\")), person(\"Stephane\" , \"Dray\", role = c(\"ctb\")), person(\"Charles\" , \"Dupont\", role = c(\"ctb\")), person(\"Dirk\" , \"Eddelbuettel\", role = c(\"ctb\")), person(\"Claus\" , \"Ekstrom\", role = c(\"ctb\")), person(\"Martin\" , \"Elff\", role = c(\"ctb\")), person(\"Jeff\" , \"Enos\", role = c(\"ctb\")), person(\"Richard W.\" , \"Farebrother\", role = c(\"ctb\")), person(\"John\" , \"Fox\", role = c(\"ctb\")), person(\"Romain\" , \"Francois\", role = c(\"ctb\")), person(\"Michael\" , \"Friendly\", role = c(\"ctb\")), person(\"Tal\" , \"Galili\", role = c(\"ctb\")), person(\"Matthias\" , \"Gamer\", role = c(\"ctb\")), person(\"Joseph L.\" , \"Gastwirth\", role = c(\"ctb\")), person(\"Vilmantas\" , \"Gegzna\", role = c(\"ctb\")), person(\"Yulia R.\" , \"Gel\", role = c(\"ctb\")), person(\"Sereina\" , \"Graber\", role = c(\"ctb\")), person(\"Juergen\" , \"Gross\", role = c(\"ctb\")), person(\"Gabor\" , \"Grothendieck\", role = c(\"ctb\")), person(\"Frank E.\" , \"Harrell Jr\", role = c(\"ctb\")), person(\"Richard\" , \"Heiberger\", role = c(\"ctb\")), person(\"Michael\" , \"Hoehle\", role = c(\"ctb\")), person(\"Christian W.\" , \"Hoffmann\", role = c(\"ctb\")), person(\"Soeren\" , \"Hojsgaard\", role = c(\"ctb\")), person(\"Torsten\" , \"Hothorn\", role = c(\"ctb\")), person(\"Markus\" , \"Huerzeler\", role = c(\"ctb\")), person(\"Wallace W.\" , \"Hui\", role = c(\"ctb\")), person(\"Pete\" , \"Hurd\", role = c(\"ctb\")), person(\"Rob J.\" , \"Hyndman\", role = c(\"ctb\")), person(\"Christopher\" , \"Jackson\", role = c(\"ctb\")), person(\"Matthias\" , \"Kohl\", role = c(\"ctb\")), person(\"Mikko\" , \"Korpela\", role = c(\"ctb\")), person(\"Max\" , \"Kuhn\", role = c(\"ctb\")), person(\"Detlew\" , \"Labes\", role = c(\"ctb\")), person(\"Friederich\" , \"Leisch\", role = c(\"ctb\")), person(\"Jim\" , \"Lemon\", role = c(\"ctb\")), person(\"Dong\" , \"Li\", role = c(\"ctb\")), person(\"Martin\" , \"Maechler\", role = c(\"ctb\")), person(\"Arni\" , \"Magnusson\", role = c(\"ctb\")), person(\"Ben\" , \"Mainwaring\", role = c(\"ctb\")), person(\"Daniel\" , \"Malter\", role = c(\"ctb\")), person(\"George\" , \"Marsaglia\", role = c(\"ctb\")), person(\"John\" , \"Marsaglia\", role = c(\"ctb\")), person(\"Alina\" , \"Matei\", role = c(\"ctb\")), person(\"David\" , \"Meyer\", role = c(\"ctb\")), person(\"Weiwen\" , \"Miao\", role = c(\"ctb\")), person(\"Giovanni\" , \"Millo\", role = c(\"ctb\")), person(\"Yongyi\" , \"Min\", role = c(\"ctb\")), person(\"David\" , \"Mitchell\", role = c(\"ctb\")), person(\"Cyril Flurin\" , \"Moser\", role = c(\"ctb\")), person(\"Franziska\" , \"Mueller\", role = c(\"ctb\")), person(\"Markus\" , \"Naepflin\", role = c(\"ctb\")), person(\"Danielle\" , \"Navarro\", role = c(\"ctb\")), person(\"Henric\" , \"Nilsson\", role = c(\"ctb\")), person(\"Klaus\" , \"Nordhausen\", role = c(\"ctb\")), person(\"Derek\" , \"Ogle\", role = c(\"ctb\")), person(\"Hong\" , \"Ooi\", role = c(\"ctb\")), person(\"Nick\" , \"Parsons\", role = c(\"ctb\")), person(\"Sandrine\" , \"Pavoine\", role = c(\"ctb\")), person(\"Tony\" , \"Plate\", role = c(\"ctb\")), person(\"Luke\" , \"Prendergast\", role = c(\"ctb\")), person(\"Roland\" , \"Rapold\", role = c(\"ctb\")), person(\"William\" , \"Revelle\", role = c(\"ctb\")), person(\"Tyler\" , \"Rinker\", role = c(\"ctb\")), person(\"Brian D.\" , \"Ripley\", role = c(\"ctb\")), person(\"Caroline\" , \"Rodriguez\", role = c(\"ctb\")), person(\"Nathan\" , \"Russell\", role = c(\"ctb\")), person(\"Nick\" , \"Sabbe\", role = c(\"ctb\")), person(\"Ralph\" , \"Scherer\", role = c(\"ctb\")), person(\"Venkatraman E.\", \"Seshan\", role = c(\"ctb\")), person(\"Michael\" , \"Smithson\", role = c(\"ctb\")), person(\"Greg\" , \"Snow\", role = c(\"ctb\")), person(\"Karline\" , \"Soetaert\", role = c(\"ctb\")), person(\"Werner A.\" , \"Stahel\", role = c(\"ctb\")), person(\"Alec\" , \"Stephenson\", role = c(\"ctb\")), person(\"Mark\" , \"Stevenson\", role = c(\"ctb\")), person(\"Ralf\" , \"Stubner\", role = c(\"ctb\")), person(\"Matthias\" , \"Templ\", role = c(\"ctb\")), person(\"Duncan\" , \"Temple Lang\", role = c(\"ctb\")), person(\"Terry\" , \"Therneau\", role = c(\"ctb\")), person(\"Yves\" , \"Tille\", role = c(\"ctb\")), person(\"Luis\" , \"Torgo\", role = c(\"ctb\")), person(\"Adrian\" , \"Trapletti\", role = c(\"ctb\")), person(\"Joshua\" , \"Ulrich\", role = c(\"ctb\")), person(\"Kevin\" , \"Ushey\", role = c(\"ctb\")), person(\"Jeremy\" , \"VanDerWal\", role = c(\"ctb\")), person(\"Bill\" , \"Venables\", role = c(\"ctb\")), person(\"John\" , \"Verzani\", role = c(\"ctb\")), person(\"Pablo J.\" , \"Villacorta Iglesias\", role = c(\"ctb\")), person(\"Gregory R.\" , \"Warnes\", role = c(\"ctb\")), person(\"Stefan\" , \"Wellek\", role = c(\"ctb\")), person(\"Hadley\" , \"Wickham\", role = c(\"ctb\")), person(\"Rand R.\" , \"Wilcox\", role = c(\"ctb\")), person(\"Peter\" , \"Wolf\", role = c(\"ctb\")), person(\"Daniel\" , \"Wollschlaeger\", role = c(\"ctb\")), person(\"Joseph\" , \"Wood\", role = c(\"ctb\")), person(\"Ying\" , \"Wu\", role = c(\"ctb\")), person(\"Thomas\" , \"Yee\", role = c(\"ctb\")), person(\"Achim\" , \"Zeileis\", role = c(\"ctb\")) )", + "Description": "A collection of miscellaneous basic statistic functions and convenience wrappers for efficiently describing data. The author's intention was to create a toolbox, which facilitates the (notoriously time consuming) first descriptive tasks in data analysis, consisting of calculating descriptive statistics, drawing graphical summaries and reporting the results. The package contains furthermore functions to produce documents using MS Word (or PowerPoint) and functions to import data from Excel. Many of the included functions can be found scattered in other packages and other sources written partly by Titans of R. The reason for collecting them here, was primarily to have them consolidated in ONE instead of dozens of packages (which themselves might depend on other packages which are not needed at all), and to provide a common and consistent interface as far as function and arguments naming, NA handling, recycling rules etc. are concerned. Google style guides were used as naming rules (in absence of convincing alternatives). The 'BigCamelCase' style was consequently applied to functions borrowed from contributed R packages as well.", + "Suggests": [ + "RDCOMClient", + "tcltk", + "VGAM", + "R.rsp", + "testthat (>= 3.0.0)" + ], + "Depends": [ + "base", + "stats", + "R (>= 4.2.0)" + ], + "Imports": [ + "graphics", + "grDevices", + "methods", + "MASS", + "utils", + "boot", + "mvtnorm", + "expm", + "Rcpp (>= 0.12.10)", + "rstudioapi", + "Exact", + "gld", + "data.table", + "readxl", + "haven", + "httr", + "withr", + "cli" + ], + "LinkingTo": [ + "Rcpp" + ], + "License": "GPL (>= 2)", + "LazyLoad": "yes", + "LazyData": "yes", + "Additional_repositories": "http://www.omegahat.net/R", + "URL": "https://andrisignorell.github.io/DescTools/, https://github.com/AndriSignorell/DescTools/", + "BugReports": "https://github.com/AndriSignorell/DescTools/issues", + "RoxygenNote": "7.3.2", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "SystemRequirements": "C++17", + "VignetteBuilder": "R.rsp", + "Config/testthat/edition": "3", + "Author": "Andri Signorell [aut, cre] (), Ken Aho [ctb], Andreas Alfons [ctb], Nanina Anderegg [ctb], Tomas Aragon [ctb], Chandima Arachchige [ctb], Antti Arppe [ctb], Adrian Baddeley [ctb], Kamil Barton [ctb], Ben Bolker [ctb], Hans W. Borchers [ctb], Frederico Caeiro [ctb], Stephane Champely [ctb], Daniel Chessel [ctb], Leanne Chhay [ctb], Nicholas Cooper [ctb], Clint Cummins [ctb], Michael Dewey [ctb], Harold C. Doran [ctb], Stephane Dray [ctb], Charles Dupont [ctb], Dirk Eddelbuettel [ctb], Claus Ekstrom [ctb], Martin Elff [ctb], Jeff Enos [ctb], Richard W. Farebrother [ctb], John Fox [ctb], Romain Francois [ctb], Michael Friendly [ctb], Tal Galili [ctb], Matthias Gamer [ctb], Joseph L. Gastwirth [ctb], Vilmantas Gegzna [ctb], Yulia R. Gel [ctb], Sereina Graber [ctb], Juergen Gross [ctb], Gabor Grothendieck [ctb], Frank E. Harrell Jr [ctb], Richard Heiberger [ctb], Michael Hoehle [ctb], Christian W. Hoffmann [ctb], Soeren Hojsgaard [ctb], Torsten Hothorn [ctb], Markus Huerzeler [ctb], Wallace W. Hui [ctb], Pete Hurd [ctb], Rob J. Hyndman [ctb], Christopher Jackson [ctb], Matthias Kohl [ctb], Mikko Korpela [ctb], Max Kuhn [ctb], Detlew Labes [ctb], Friederich Leisch [ctb], Jim Lemon [ctb], Dong Li [ctb], Martin Maechler [ctb], Arni Magnusson [ctb], Ben Mainwaring [ctb], Daniel Malter [ctb], George Marsaglia [ctb], John Marsaglia [ctb], Alina Matei [ctb], David Meyer [ctb], Weiwen Miao [ctb], Giovanni Millo [ctb], Yongyi Min [ctb], David Mitchell [ctb], Cyril Flurin Moser [ctb], Franziska Mueller [ctb], Markus Naepflin [ctb], Danielle Navarro [ctb], Henric Nilsson [ctb], Klaus Nordhausen [ctb], Derek Ogle [ctb], Hong Ooi [ctb], Nick Parsons [ctb], Sandrine Pavoine [ctb], Tony Plate [ctb], Luke Prendergast [ctb], Roland Rapold [ctb], William Revelle [ctb], Tyler Rinker [ctb], Brian D. Ripley [ctb], Caroline Rodriguez [ctb], Nathan Russell [ctb], Nick Sabbe [ctb], Ralph Scherer [ctb], Venkatraman E. Seshan [ctb], Michael Smithson [ctb], Greg Snow [ctb], Karline Soetaert [ctb], Werner A. Stahel [ctb], Alec Stephenson [ctb], Mark Stevenson [ctb], Ralf Stubner [ctb], Matthias Templ [ctb], Duncan Temple Lang [ctb], Terry Therneau [ctb], Yves Tille [ctb], Luis Torgo [ctb], Adrian Trapletti [ctb], Joshua Ulrich [ctb], Kevin Ushey [ctb], Jeremy VanDerWal [ctb], Bill Venables [ctb], John Verzani [ctb], Pablo J. Villacorta Iglesias [ctb], Gregory R. Warnes [ctb], Stefan Wellek [ctb], Hadley Wickham [ctb], Rand R. Wilcox [ctb], Peter Wolf [ctb], Daniel Wollschlaeger [ctb], Joseph Wood [ctb], Ying Wu [ctb], Thomas Yee [ctb], Achim Zeileis [ctb]", + "Maintainer": "Andri Signorell ", + "Repository": "CRAN" + }, + "Exact": { + "Package": "Exact", + "Version": "3.3", + "Source": "Repository", + "Type": "Package", + "Title": "Unconditional Exact Test", + "Authors@R": "person(\"Peter\", \"Calhoun\", email=\"calhoun.peter@gmail.com\", role=c(\"aut\", \"cre\"))", + "Author": "Peter Calhoun [aut, cre]", + "Maintainer": "Peter Calhoun ", + "Description": "Performs unconditional exact tests and power calculations for 2x2 contingency tables. For comparing two independent proportions, performs Barnard's test (1945) using the original CSM test (Barnard, 1947 ), using Fisher's p-value referred to as Boschloo's test (1970) , or using a Z-statistic (Suissa and Shuster, 1985, ). For comparing two binary proportions, performs unconditional exact test using McNemar's Z-statistic (Berger and Sidik, 2003, ), using McNemar's conditional p-value, using McNemar's Z-statistic with continuity correction, or using CSM test. Calculates confidence intervals for the difference in proportion. This package interacts with pre-computed data available through the ExactData R package, which is available in a 'drat' repository. Install the ExactData R package from GitHub at . The ExactData R package is approximately 85 MB.", + "License": "GPL-2", + "Depends": [ + "R (>= 3.5.0)" + ], + "Imports": [ + "graphics", + "stats", + "utils", + "rootSolve" + ], + "Suggests": [ + "ExactData" + ], + "Additional_repositories": "https://pcalhoun1.github.io/drat", + "NeedsCompilation": "no", + "Repository": "CRAN" + }, + "MASS": { + "Package": "MASS", + "Version": "7.3-64", + "Source": "Repository", + "Priority": "recommended", + "Date": "2025-01-06", + "Revision": "$Rev: 3680 $", + "Depends": [ + "R (>= 4.4.0)", + "grDevices", + "graphics", + "stats", + "utils" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "lattice", + "nlme", + "nnet", + "survival" + ], + "Authors@R": "c(person(\"Brian\", \"Ripley\", role = c(\"aut\", \"cre\", \"cph\"), email = \"Brian.Ripley@R-project.org\"), person(\"Bill\", \"Venables\", role = c(\"aut\", \"cph\")), person(c(\"Douglas\", \"M.\"), \"Bates\", role = \"ctb\"), person(\"Kurt\", \"Hornik\", role = \"trl\", comment = \"partial port ca 1998\"), person(\"Albrecht\", \"Gebhardt\", role = \"trl\", comment = \"partial port ca 1998\"), person(\"David\", \"Firth\", role = \"ctb\", comment = \"support functions for polr\"))", + "Description": "Functions and datasets to support Venables and Ripley, \"Modern Applied Statistics with S\" (4th edition, 2002).", + "Title": "Support Functions and Datasets for Venables and Ripley's MASS", + "LazyData": "yes", + "ByteCompile": "yes", + "License": "GPL-2 | GPL-3", + "URL": "http://www.stats.ox.ac.uk/pub/MASS4/", + "Contact": "", + "NeedsCompilation": "yes", + "Author": "Brian Ripley [aut, cre, cph], Bill Venables [aut, cph], Douglas M. Bates [ctb], Kurt Hornik [trl] (partial port ca 1998), Albrecht Gebhardt [trl] (partial port ca 1998), David Firth [ctb] (support functions for polr)", + "Maintainer": "Brian Ripley ", + "Repository": "CRAN" + }, + "Matrix": { + "Package": "Matrix", + "Version": "1.7-2", + "Source": "Repository", + "VersionNote": "do also bump src/version.h, inst/include/Matrix/version.h", + "Date": "2025-01-20", + "Priority": "recommended", + "Title": "Sparse and Dense Matrix Classes and Methods", + "Description": "A rich hierarchy of sparse and dense matrix classes, including general, symmetric, triangular, and diagonal matrices with numeric, logical, or pattern entries. Efficient methods for operating on such matrices, often wrapping the 'BLAS', 'LAPACK', and 'SuiteSparse' libraries.", + "License": "GPL (>= 2) | file LICENCE", + "URL": "https://Matrix.R-forge.R-project.org", + "BugReports": "https://R-forge.R-project.org/tracker/?atid=294&group_id=61", + "Contact": "Matrix-authors@R-project.org", + "Authors@R": "c(person(\"Douglas\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Martin\", \"Maechler\", role = c(\"aut\", \"cre\"), email = \"mmaechler+Matrix@gmail.com\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Mikael\", \"Jagan\", role = \"aut\", comment = c(ORCID = \"0000-0002-3542-2938\")), person(\"Timothy A.\", \"Davis\", role = \"ctb\", comment = c(ORCID = \"0000-0001-7614-6899\", \"SuiteSparse libraries\", \"collaborators listed in dir(system.file(\\\"doc\\\", \\\"SuiteSparse\\\", package=\\\"Matrix\\\"), pattern=\\\"License\\\", full.names=TRUE, recursive=TRUE)\")), person(\"George\", \"Karypis\", role = \"ctb\", comment = c(ORCID = \"0000-0003-2753-1437\", \"METIS library\", \"Copyright: Regents of the University of Minnesota\")), person(\"Jason\", \"Riedy\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4345-4200\", \"GNU Octave's condest() and onenormest()\", \"Copyright: Regents of the University of California\")), person(\"Jens\", \"Oehlschlägel\", role = \"ctb\", comment = \"initial nearPD()\"), person(\"R Core Team\", role = \"ctb\", comment = c(ROR = \"02zz1nj61\", \"base R's matrix implementation\")))", + "Depends": [ + "R (>= 4.4)", + "methods" + ], + "Imports": [ + "grDevices", + "graphics", + "grid", + "lattice", + "stats", + "utils" + ], + "Suggests": [ + "MASS", + "datasets", + "sfsmisc", + "tools" + ], + "Enhances": [ + "SparseM", + "graph" + ], + "LazyData": "no", + "LazyDataNote": "not possible, since we use data/*.R and our S4 classes", + "BuildResaveData": "no", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Douglas Bates [aut] (), Martin Maechler [aut, cre] (), Mikael Jagan [aut] (), Timothy A. Davis [ctb] (, SuiteSparse libraries, collaborators listed in dir(system.file(\"doc\", \"SuiteSparse\", package=\"Matrix\"), pattern=\"License\", full.names=TRUE, recursive=TRUE)), George Karypis [ctb] (, METIS library, Copyright: Regents of the University of Minnesota), Jason Riedy [ctb] (, GNU Octave's condest() and onenormest(), Copyright: Regents of the University of California), Jens Oehlschlägel [ctb] (initial nearPD()), R Core Team [ctb] (02zz1nj61, base R's matrix implementation)", + "Maintainer": "Martin Maechler ", + "Repository": "CRAN" + }, + "R.cache": { + "Package": "R.cache", + "Version": "0.16.0", + "Source": "Repository", + "Depends": [ + "R (>= 2.14.0)" + ], + "Imports": [ + "utils", + "R.methodsS3 (>= 1.8.1)", + "R.oo (>= 1.24.0)", + "R.utils (>= 2.10.1)", + "digest (>= 0.6.13)" + ], + "Title": "Fast and Light-Weight Caching (Memoization) of Objects and Results to Speed Up Computations", + "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", + "Author": "Henrik Bengtsson [aut, cre, cph]", + "Maintainer": "Henrik Bengtsson ", + "Description": "Memoization can be used to speed up repetitive and computational expensive function calls. The first time a function that implements memoization is called the results are stored in a cache memory. The next time the function is called with the same set of parameters, the results are momentarily retrieved from the cache avoiding repeating the calculations. With this package, any R object can be cached in a key-value storage where the key can be an arbitrary set of R objects. The cache memory is persistent (on the file system).", + "License": "LGPL (>= 2.1)", + "LazyLoad": "TRUE", + "URL": "https://github.com/HenrikBengtsson/R.cache", + "BugReports": "https://github.com/HenrikBengtsson/R.cache/issues", + "RoxygenNote": "7.2.1", + "NeedsCompilation": "no", + "Repository": "CRAN" + }, + "R.methodsS3": { + "Package": "R.methodsS3", + "Version": "1.8.2", + "Source": "Repository", + "Depends": [ + "R (>= 2.13.0)" + ], + "Imports": [ + "utils" + ], + "Suggests": [ + "codetools" + ], + "Title": "S3 Methods Simplified", + "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", + "Author": "Henrik Bengtsson [aut, cre, cph]", + "Maintainer": "Henrik Bengtsson ", + "Description": "Methods that simplify the setup of S3 generic functions and S3 methods. Major effort has been made in making definition of methods as simple as possible with a minimum of maintenance for package developers. For example, generic functions are created automatically, if missing, and naming conflict are automatically solved, if possible. The method setMethodS3() is a good start for those who in the future may want to migrate to S4. This is a cross-platform package implemented in pure R that generates standard S3 methods.", + "License": "LGPL (>= 2.1)", + "LazyLoad": "TRUE", + "URL": "https://github.com/HenrikBengtsson/R.methodsS3", + "BugReports": "https://github.com/HenrikBengtsson/R.methodsS3/issues", + "NeedsCompilation": "no", + "Repository": "CRAN" + }, + "R.oo": { + "Package": "R.oo", + "Version": "1.27.0", + "Source": "Repository", + "Depends": [ + "R (>= 2.13.0)", + "R.methodsS3 (>= 1.8.2)" + ], + "Imports": [ + "methods", + "utils" + ], + "Suggests": [ + "tools" + ], + "Title": "R Object-Oriented Programming with or without References", + "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", + "Author": "Henrik Bengtsson [aut, cre, cph]", + "Maintainer": "Henrik Bengtsson ", + "Description": "Methods and classes for object-oriented programming in R with or without references. Large effort has been made on making definition of methods as simple as possible with a minimum of maintenance for package developers. The package has been developed since 2001 and is now considered very stable. This is a cross-platform package implemented in pure R that defines standard S3 classes without any tricks.", + "License": "LGPL (>= 2.1)", + "LazyLoad": "TRUE", + "URL": "https://github.com/HenrikBengtsson/R.oo", + "BugReports": "https://github.com/HenrikBengtsson/R.oo/issues", + "NeedsCompilation": "no", + "Repository": "CRAN" + }, + "R.utils": { + "Package": "R.utils", + "Version": "2.12.3", + "Source": "Repository", + "Depends": [ + "R (>= 2.14.0)", + "R.oo" + ], + "Imports": [ + "methods", + "utils", + "tools", + "R.methodsS3" + ], + "Suggests": [ + "datasets", + "digest (>= 0.6.10)" + ], + "Title": "Various Programming Utilities", + "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", + "Author": "Henrik Bengtsson [aut, cre, cph]", + "Maintainer": "Henrik Bengtsson ", + "Description": "Utility functions useful when programming and developing R packages.", + "License": "LGPL (>= 2.1)", + "LazyLoad": "TRUE", + "URL": "https://henrikbengtsson.github.io/R.utils/, https://github.com/HenrikBengtsson/R.utils", + "BugReports": "https://github.com/HenrikBengtsson/R.utils/issues", + "NeedsCompilation": "no", + "Repository": "CRAN" + }, + "R6": { + "Package": "R6", + "Version": "2.6.0", + "Source": "Repository", + "Title": "Encapsulated Classes with Reference Semantics", + "Authors@R": "c( person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Creates classes with reference semantics, similar to R's built-in reference classes. Compared to reference classes, R6 classes are simpler and lighter-weight, and they are not built on S4 classes so they do not require the methods package. These classes allow public and private members, and they support inheritance, even when the classes are defined in different packages.", + "License": "MIT + file LICENSE", + "URL": "https://r6.r-lib.org, https://github.com/r-lib/R6", + "BugReports": "https://github.com/r-lib/R6/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Suggests": [ + "lobstr", + "testthat (>= 3.0.0)" + ], + "Config/Needs/website": "tidyverse/tidytemplate, ggplot2, microbenchmark, scales", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Winston Chang ", + "Repository": "CRAN" + }, + "RColorBrewer": { + "Package": "RColorBrewer", + "Version": "1.1-3", + "Source": "Repository", + "Date": "2022-04-03", + "Title": "ColorBrewer Palettes", + "Authors@R": "c(person(given = \"Erich\", family = \"Neuwirth\", role = c(\"aut\", \"cre\"), email = \"erich.neuwirth@univie.ac.at\"))", + "Author": "Erich Neuwirth [aut, cre]", + "Maintainer": "Erich Neuwirth ", + "Depends": [ + "R (>= 2.0.0)" + ], + "Description": "Provides color schemes for maps (and other graphics) designed by Cynthia Brewer as described at http://colorbrewer2.org.", + "License": "Apache License 2.0", + "NeedsCompilation": "no", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "Rcpp": { + "Package": "Rcpp", + "Version": "1.0.14", + "Source": "Repository", + "Title": "Seamless R and C++ Integration", + "Date": "2025-01-11", + "Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Romain\", \"Francois\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"JJ\", \"Allaire\", role = \"aut\", comment = c(ORCID = \"0000-0003-0174-9868\")), person(\"Kevin\", \"Ushey\", role = \"aut\", comment = c(ORCID = \"0000-0003-2880-7407\")), person(\"Qiang\", \"Kou\", role = \"aut\", comment = c(ORCID = \"0000-0001-6786-5453\")), person(\"Nathan\", \"Russell\", role = \"aut\"), person(\"Iñaki\", \"Ucar\", role = \"aut\", comment = c(ORCID = \"0000-0001-6403-5550\")), person(\"Doug\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"John\", \"Chambers\", role = \"aut\"))", + "Description": "The 'Rcpp' package provides R functions as well as C++ classes which offer a seamless integration of R and C++. Many R data types and objects can be mapped back and forth to C++ equivalents which facilitates both writing of new code as well as easier integration of third-party libraries. Documentation about 'Rcpp' is provided by several vignettes included in this package, via the 'Rcpp Gallery' site at , the paper by Eddelbuettel and Francois (2011, ), the book by Eddelbuettel (2013, ) and the paper by Eddelbuettel and Balamuta (2018, ); see 'citation(\"Rcpp\")' for details.", + "Imports": [ + "methods", + "utils" + ], + "Suggests": [ + "tinytest", + "inline", + "rbenchmark", + "pkgKitten (>= 0.1.2)" + ], + "URL": "https://www.rcpp.org, https://dirk.eddelbuettel.com/code/rcpp.html, https://github.com/RcppCore/Rcpp", + "License": "GPL (>= 2)", + "BugReports": "https://github.com/RcppCore/Rcpp/issues", + "MailingList": "rcpp-devel@lists.r-forge.r-project.org", + "RoxygenNote": "6.1.1", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Dirk Eddelbuettel [aut, cre] (), Romain Francois [aut] (), JJ Allaire [aut] (), Kevin Ushey [aut] (), Qiang Kou [aut] (), Nathan Russell [aut], Iñaki Ucar [aut] (), Doug Bates [aut] (), John Chambers [aut]", + "Maintainer": "Dirk Eddelbuettel ", + "Repository": "CRAN" + }, + "arrow": { + "Package": "arrow", + "Version": "17.0.0.1", + "Source": "Repository", + "Title": "Integration to 'Apache' 'Arrow'", + "Authors@R": "c( person(\"Neal\", \"Richardson\", email = \"neal.p.richardson@gmail.com\", role = c(\"aut\")), person(\"Ian\", \"Cook\", email = \"ianmcook@gmail.com\", role = c(\"aut\")), person(\"Nic\", \"Crane\", email = \"thisisnic@gmail.com\", role = c(\"aut\")), person(\"Dewey\", \"Dunnington\", role = c(\"aut\"), email = \"dewey@fishandwhistle.net\", comment = c(ORCID = \"0000-0002-9415-4582\")), person(\"Romain\", \"Fran\\u00e7ois\", role = c(\"aut\"), comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Jonathan\", \"Keane\", email = \"jkeane@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Drago\\u0219\", \"Moldovan-Gr\\u00fcnfeld\", email = \"dragos.mold@gmail.com\", role = c(\"aut\")), person(\"Jeroen\", \"Ooms\", email = \"jeroen@berkeley.edu\", role = c(\"aut\")), person(\"Jacob\", \"Wujciak-Jens\", email = \"jacob@wujciak.de\", role = c(\"aut\")), person(\"Javier\", \"Luraschi\", email = \"javier@rstudio.com\", role = c(\"ctb\")), person(\"Karl\", \"Dunkle Werner\", email = \"karldw@users.noreply.github.com\", role = c(\"ctb\"), comment = c(ORCID = \"0000-0003-0523-7309\")), person(\"Jeffrey\", \"Wong\", email = \"jeffreyw@netflix.com\", role = c(\"ctb\")), person(\"Apache Arrow\", email = \"dev@arrow.apache.org\", role = c(\"aut\", \"cph\")) )", + "Description": "'Apache' 'Arrow' is a cross-language development platform for in-memory data. It specifies a standardized language-independent columnar memory format for flat and hierarchical data, organized for efficient analytic operations on modern hardware. This package provides an interface to the 'Arrow C++' library.", + "Depends": [ + "R (>= 4.0)" + ], + "License": "Apache License (>= 2.0)", + "URL": "https://github.com/apache/arrow/, https://arrow.apache.org/docs/r/", + "BugReports": "https://github.com/apache/arrow/issues", + "Encoding": "UTF-8", + "Language": "en-US", + "SystemRequirements": "C++17; for AWS S3 support on Linux, libcurl and openssl (optional); cmake >= 3.16 (build-time only, and only for full source build)", + "Biarch": "true", + "Imports": [ + "assertthat", + "bit64 (>= 0.9-7)", + "glue", + "methods", + "purrr", + "R6", + "rlang (>= 1.0.0)", + "stats", + "tidyselect (>= 1.0.0)", + "utils", + "vctrs" + ], + "RoxygenNote": "7.3.1", + "Config/testthat/edition": "3", + "Config/build/bootstrap": "TRUE", + "Suggests": [ + "blob", + "curl", + "cli", + "DBI", + "dbplyr", + "decor", + "distro", + "dplyr", + "duckdb (>= 0.2.8)", + "hms", + "jsonlite", + "knitr", + "lubridate", + "pillar", + "pkgload", + "reticulate", + "rmarkdown", + "stringi", + "stringr", + "sys", + "testthat (>= 3.1.0)", + "tibble", + "tzdb", + "withr" + ], + "LinkingTo": [ + "cpp11 (>= 0.4.2)" + ], + "Collate": "'arrowExports.R' 'enums.R' 'arrow-object.R' 'type.R' 'array-data.R' 'arrow-datum.R' 'array.R' 'arrow-info.R' 'arrow-package.R' 'arrow-tabular.R' 'buffer.R' 'chunked-array.R' 'io.R' 'compression.R' 'scalar.R' 'compute.R' 'config.R' 'csv.R' 'dataset.R' 'dataset-factory.R' 'dataset-format.R' 'dataset-partition.R' 'dataset-scan.R' 'dataset-write.R' 'dictionary.R' 'dplyr-across.R' 'dplyr-arrange.R' 'dplyr-by.R' 'dplyr-collect.R' 'dplyr-count.R' 'dplyr-datetime-helpers.R' 'dplyr-distinct.R' 'dplyr-eval.R' 'dplyr-filter.R' 'dplyr-funcs-agg.R' 'dplyr-funcs-augmented.R' 'dplyr-funcs-conditional.R' 'dplyr-funcs-datetime.R' 'dplyr-funcs-doc.R' 'dplyr-funcs-math.R' 'dplyr-funcs-simple.R' 'dplyr-funcs-string.R' 'dplyr-funcs-type.R' 'expression.R' 'dplyr-funcs.R' 'dplyr-glimpse.R' 'dplyr-group-by.R' 'dplyr-join.R' 'dplyr-mutate.R' 'dplyr-select.R' 'dplyr-slice.R' 'dplyr-summarize.R' 'dplyr-union.R' 'record-batch.R' 'table.R' 'dplyr.R' 'duckdb.R' 'extension.R' 'feather.R' 'field.R' 'filesystem.R' 'flight.R' 'install-arrow.R' 'ipc-stream.R' 'json.R' 'memory-pool.R' 'message.R' 'metadata.R' 'parquet.R' 'python.R' 'query-engine.R' 'record-batch-reader.R' 'record-batch-writer.R' 'reexports-bit64.R' 'reexports-tidyselect.R' 'schema.R' 'udf.R' 'util.R'", + "NeedsCompilation": "yes", + "Author": "Neal Richardson [aut], Ian Cook [aut], Nic Crane [aut], Dewey Dunnington [aut] (), Romain François [aut] (), Jonathan Keane [aut, cre], Dragoș Moldovan-Grünfeld [aut], Jeroen Ooms [aut], Jacob Wujciak-Jens [aut], Javier Luraschi [ctb], Karl Dunkle Werner [ctb] (), Jeffrey Wong [ctb], Apache Arrow [aut, cph]", + "Maintainer": "Jonathan Keane ", + "Repository": "RSPM" + }, + "askpass": { + "Package": "askpass", + "Version": "1.2.1", + "Source": "Repository", + "Type": "Package", + "Title": "Password Entry Utilities for R, Git, and SSH", + "Authors@R": "person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\"))", + "Description": "Cross-platform utilities for prompting the user for credentials or a passphrase, for example to authenticate with a server or read a protected key. Includes native programs for MacOS and Windows, hence no 'tcltk' is required. Password entry can be invoked in two different ways: directly from R via the askpass() function, or indirectly as password-entry back-end for 'ssh-agent' or 'git-credential' via the SSH_ASKPASS and GIT_ASKPASS environment variables. Thereby the user can be prompted for credentials or a passphrase if needed when R calls out to git or ssh.", + "License": "MIT + file LICENSE", + "URL": "https://r-lib.r-universe.dev/askpass", + "BugReports": "https://github.com/r-lib/askpass/issues", + "Encoding": "UTF-8", + "Imports": [ + "sys (>= 2.1)" + ], + "RoxygenNote": "7.2.3", + "Suggests": [ + "testthat" + ], + "Language": "en-US", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] ()", + "Maintainer": "Jeroen Ooms ", + "Repository": "RSPM" + }, + "assertthat": { + "Package": "assertthat", + "Version": "0.2.1", + "Source": "Repository", + "Title": "Easy Pre and Post Assertions", + "Authors@R": "person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", c(\"aut\", \"cre\"))", + "Description": "An extension to stopifnot() that makes it easy to declare the pre and post conditions that you code should satisfy, while also producing friendly error messages so that your users know what's gone wrong.", + "License": "GPL-3", + "Imports": [ + "tools" + ], + "Suggests": [ + "testthat", + "covr" + ], + "RoxygenNote": "6.0.1", + "Collate": "'assert-that.r' 'on-failure.r' 'assertions-file.r' 'assertions-scalar.R' 'assertions.r' 'base.r' 'base-comparison.r' 'base-is.r' 'base-logical.r' 'base-misc.r' 'utils.r' 'validate-that.R'", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "backports": { + "Package": "backports", + "Version": "1.5.0", + "Source": "Repository", + "Type": "Package", + "Title": "Reimplementations of Functions Introduced Since R-3.0.0", + "Authors@R": "c( person(\"Michel\", \"Lang\", NULL, \"michellang@gmail.com\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Duncan\", \"Murdoch\", NULL, \"murdoch.duncan@gmail.com\", role = c(\"aut\")), person(\"R Core Team\", role = \"aut\"))", + "Maintainer": "Michel Lang ", + "Description": "Functions introduced or changed since R v3.0.0 are re-implemented in this package. The backports are conditionally exported in order to let R resolve the function name to either the implemented backport, or the respective base version, if available. Package developers can make use of new functions or arguments by selectively importing specific backports to support older installations.", + "URL": "https://github.com/r-lib/backports", + "BugReports": "https://github.com/r-lib/backports/issues", + "License": "GPL-2 | GPL-3", + "NeedsCompilation": "yes", + "ByteCompile": "yes", + "Depends": [ + "R (>= 3.0.0)" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "Author": "Michel Lang [cre, aut] (), Duncan Murdoch [aut], R Core Team [aut]", + "Repository": "RSPM" + }, + "base64enc": { + "Package": "base64enc", + "Version": "0.1-3", + "Source": "Repository", + "Title": "Tools for base64 encoding", + "Author": "Simon Urbanek ", + "Maintainer": "Simon Urbanek ", + "Depends": [ + "R (>= 2.9.0)" + ], + "Enhances": [ + "png" + ], + "Description": "This package provides tools for handling base64 encoding. It is more flexible than the orphaned base64 package.", + "License": "GPL-2 | GPL-3", + "URL": "http://www.rforge.net/base64enc", + "NeedsCompilation": "yes", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "bit": { + "Package": "bit", + "Version": "4.5.0.1", + "Source": "Repository", + "Type": "Package", + "Title": "Classes and Methods for Fast Memory-Efficient Boolean Selections", + "Date": "2024-09-17", + "Authors@R": "c(person(given = \"Jens\", family = \"Oehlschlägel\", role = c(\"aut\", \"cre\"), email = \"Jens.Oehlschlaegel@truecluster.com\"), person(given = \"Brian\", family = \"Ripley\", role = \"ctb\"))", + "Author": "Jens Oehlschlägel [aut, cre], Brian Ripley [ctb]", + "Maintainer": "Jens Oehlschlägel ", + "Depends": [ + "R (>= 3.4.0)" + ], + "Suggests": [ + "testthat (>= 0.11.0)", + "roxygen2", + "knitr", + "markdown", + "rmarkdown", + "microbenchmark", + "bit64 (>= 4.0.0)", + "ff (>= 4.0.0)" + ], + "Description": "Provided are classes for boolean and skewed boolean vectors, fast boolean methods, fast unique and non-unique integer sorting, fast set operations on sorted and unsorted sets of integers, and foundations for ff (range index, compression, chunked processing).", + "License": "GPL-2 | GPL-3", + "LazyLoad": "yes", + "ByteCompile": "yes", + "Encoding": "UTF-8", + "URL": "https://github.com/truecluster/bit", + "VignetteBuilder": "knitr, rmarkdown", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Repository": "CRAN" + }, + "bit64": { + "Package": "bit64", + "Version": "4.6.0-1", + "Source": "Repository", + "Title": "A S3 Class for Vectors of 64bit Integers", + "Authors@R": "c( person(\"Michael\", \"Chirico\", email = \"michaelchirico4@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Jens\", \"Oehlschlägel\", role = \"aut\"), person(\"Leonardo\", \"Silvestri\", role = \"ctb\"), person(\"Ofek\", \"Shilon\", role = \"ctb\") )", + "Depends": [ + "R (>= 3.4.0)", + "bit (>= 4.0.0)" + ], + "Description": "Package 'bit64' provides serializable S3 atomic 64bit (signed) integers. These are useful for handling database keys and exact counting in +-2^63. WARNING: do not use them as replacement for 32bit integers, integer64 are not supported for subscripting by R-core and they have different semantics when combined with double, e.g. integer64 + double => integer64. Class integer64 can be used in vectors, matrices, arrays and data.frames. Methods are available for coercion from and to logicals, integers, doubles, characters and factors as well as many elementwise and summary functions. Many fast algorithmic operations such as 'match' and 'order' support inter- active data exploration and manipulation and optionally leverage caching.", + "License": "GPL-2 | GPL-3", + "LazyLoad": "yes", + "ByteCompile": "yes", + "URL": "https://github.com/r-lib/bit64", + "Encoding": "UTF-8", + "Imports": [ + "graphics", + "methods", + "stats", + "utils" + ], + "Suggests": [ + "testthat (>= 3.0.3)", + "withr" + ], + "Config/testthat/edition": "3", + "Config/needs/development": "testthat", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Michael Chirico [aut, cre], Jens Oehlschlägel [aut], Leonardo Silvestri [ctb], Ofek Shilon [ctb]", + "Maintainer": "Michael Chirico ", + "Repository": "CRAN" + }, + "boot": { + "Package": "boot", + "Version": "1.3-31", + "Source": "Repository", + "Priority": "recommended", + "Date": "2024-08-28", + "Authors@R": "c(person(\"Angelo\", \"Canty\", role = \"aut\", email = \"cantya@mcmaster.ca\", comment = \"author of original code for S\"), person(\"Brian\", \"Ripley\", role = c(\"aut\", \"trl\"), email = \"ripley@stats.ox.ac.uk\", comment = \"conversion to R, maintainer 1999--2022, author of parallel support\"), person(\"Alessandra R.\", \"Brazzale\", role = c(\"ctb\", \"cre\"), email = \"brazzale@stat.unipd.it\", comment = \"minor bug fixes\"))", + "Maintainer": "Alessandra R. Brazzale ", + "Note": "Maintainers are not available to give advice on using a package they did not author.", + "Description": "Functions and datasets for bootstrapping from the book \"Bootstrap Methods and Their Application\" by A. C. Davison and D. V. Hinkley (1997, CUP), originally written by Angelo Canty for S.", + "Title": "Bootstrap Functions (Originally by Angelo Canty for S)", + "Depends": [ + "R (>= 3.0.0)", + "graphics", + "stats" + ], + "Suggests": [ + "MASS", + "survival" + ], + "LazyData": "yes", + "ByteCompile": "yes", + "License": "Unlimited", + "NeedsCompilation": "no", + "Author": "Angelo Canty [aut] (author of original code for S), Brian Ripley [aut, trl] (conversion to R, maintainer 1999--2022, author of parallel support), Alessandra R. Brazzale [ctb, cre] (minor bug fixes)", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "bslib": { + "Package": "bslib", + "Version": "0.9.0", + "Source": "Repository", + "Title": "Custom 'Bootstrap' 'Sass' Themes for 'shiny' and 'rmarkdown'", + "Authors@R": "c( person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Garrick\", \"Aden-Buie\", , \"garrick@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0002-7111-0077\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(, \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Javi\", \"Aguilar\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap colorpicker library\"), person(\"Thomas\", \"Park\", role = c(\"ctb\", \"cph\"), comment = \"Bootswatch library\"), person(, \"PayPal\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap accessibility plugin\") )", + "Description": "Simplifies custom 'CSS' styling of both 'shiny' and 'rmarkdown' via 'Bootstrap' 'Sass'. Supports 'Bootstrap' 3, 4 and 5 as well as their various 'Bootswatch' themes. An interactive widget is also provided for previewing themes in real time.", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/bslib/, https://github.com/rstudio/bslib", + "BugReports": "https://github.com/rstudio/bslib/issues", + "Depends": [ + "R (>= 2.10)" + ], + "Imports": [ + "base64enc", + "cachem", + "fastmap (>= 1.1.1)", + "grDevices", + "htmltools (>= 0.5.8)", + "jquerylib (>= 0.1.3)", + "jsonlite", + "lifecycle", + "memoise (>= 2.0.1)", + "mime", + "rlang", + "sass (>= 0.4.9)" + ], + "Suggests": [ + "bsicons", + "curl", + "fontawesome", + "future", + "ggplot2", + "knitr", + "magrittr", + "rappdirs", + "rmarkdown (>= 2.7)", + "shiny (> 1.8.1)", + "testthat", + "thematic", + "tools", + "utils", + "withr", + "yaml" + ], + "Config/Needs/deploy": "BH, chiflights22, colourpicker, commonmark, cpp11, cpsievert/chiflights22, cpsievert/histoslider, dplyr, DT, ggplot2, ggridges, gt, hexbin, histoslider, htmlwidgets, lattice, leaflet, lubridate, markdown, modelr, plotly, reactable, reshape2, rprojroot, rsconnect, rstudio/shiny, scales, styler, tibble", + "Config/Needs/routine": "chromote, desc, renv", + "Config/Needs/website": "brio, crosstalk, dplyr, DT, ggplot2, glue, htmlwidgets, leaflet, lorem, palmerpenguins, plotly, purrr, rprojroot, rstudio/htmltools, scales, stringr, tidyr, webshot2", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Config/testthat/start-first": "zzzz-bs-sass, fonts, zzz-precompile, theme-*, rmd-*", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "Collate": "'accordion.R' 'breakpoints.R' 'bs-current-theme.R' 'bs-dependencies.R' 'bs-global.R' 'bs-remove.R' 'bs-theme-layers.R' 'bs-theme-preset-bootswatch.R' 'bs-theme-preset-brand.R' 'bs-theme-preset-builtin.R' 'bs-theme-preset.R' 'utils.R' 'bs-theme-preview.R' 'bs-theme-update.R' 'bs-theme.R' 'bslib-package.R' 'buttons.R' 'card.R' 'deprecated.R' 'files.R' 'fill.R' 'imports.R' 'input-dark-mode.R' 'input-switch.R' 'layout.R' 'nav-items.R' 'nav-update.R' 'navbar_options.R' 'navs-legacy.R' 'navs.R' 'onLoad.R' 'page.R' 'popover.R' 'precompiled.R' 'print.R' 'shiny-devmode.R' 'sidebar.R' 'staticimports.R' 'tooltip.R' 'utils-deps.R' 'utils-shiny.R' 'utils-tags.R' 'value-box.R' 'version-default.R' 'versions.R'", + "NeedsCompilation": "no", + "Author": "Carson Sievert [aut, cre] (), Joe Cheng [aut], Garrick Aden-Buie [aut] (), Posit Software, PBC [cph, fnd], Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Javi Aguilar [ctb, cph] (Bootstrap colorpicker library), Thomas Park [ctb, cph] (Bootswatch library), PayPal [ctb, cph] (Bootstrap accessibility plugin)", + "Maintainer": "Carson Sievert ", + "Repository": "CRAN" + }, + "cachem": { + "Package": "cachem", + "Version": "1.1.0", + "Source": "Repository", + "Title": "Cache R Objects with Automatic Pruning", + "Description": "Key-value stores with automatic pruning. Caches can limit either their total size or the age of the oldest object (or both), automatically pruning objects to maintain the constraints.", + "Authors@R": "c( person(\"Winston\", \"Chang\", , \"winston@posit.co\", c(\"aut\", \"cre\")), person(family = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")))", + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "ByteCompile": "true", + "URL": "https://cachem.r-lib.org/, https://github.com/r-lib/cachem", + "Imports": [ + "rlang", + "fastmap (>= 1.2.0)" + ], + "Suggests": [ + "testthat" + ], + "RoxygenNote": "7.2.3", + "Config/Needs/routine": "lobstr", + "Config/Needs/website": "pkgdown", + "NeedsCompilation": "yes", + "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Winston Chang ", + "Repository": "RSPM" + }, + "callr": { + "Package": "callr", + "Version": "3.7.6", + "Source": "Repository", + "Title": "Call R from R", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\", \"cph\"), comment = c(ORCID = \"0000-0001-7098-9676\")), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Ascent Digital Services\", role = c(\"cph\", \"fnd\")) )", + "Description": "It is sometimes useful to perform a computation in a separate R process, without affecting the current R process at all. This packages does exactly that.", + "License": "MIT + file LICENSE", + "URL": "https://callr.r-lib.org, https://github.com/r-lib/callr", + "BugReports": "https://github.com/r-lib/callr/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "processx (>= 3.6.1)", + "R6", + "utils" + ], + "Suggests": [ + "asciicast (>= 2.3.1)", + "cli (>= 1.1.0)", + "mockery", + "ps", + "rprojroot", + "spelling", + "testthat (>= 3.2.0)", + "withr (>= 2.3.0)" + ], + "Config/Needs/website": "r-lib/asciicast, glue, htmlwidgets, igraph, tibble, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.3.1.9000", + "NeedsCompilation": "no", + "Author": "Gábor Csárdi [aut, cre, cph] (), Winston Chang [aut], Posit Software, PBC [cph, fnd], Ascent Digital Services [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "RSPM" + }, + "cellranger": { + "Package": "cellranger", + "Version": "1.1.0", + "Source": "Repository", + "Title": "Translate Spreadsheet Cell Ranges to Rows and Columns", + "Authors@R": "c( person(\"Jennifer\", \"Bryan\", , \"jenny@stat.ubc.ca\", c(\"cre\", \"aut\")), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", \"ctb\") )", + "Description": "Helper functions to work with spreadsheets and the \"A1:D10\" style of cell range specification.", + "Depends": [ + "R (>= 3.0.0)" + ], + "License": "MIT + file LICENSE", + "LazyData": "true", + "URL": "https://github.com/rsheets/cellranger", + "BugReports": "https://github.com/rsheets/cellranger/issues", + "Suggests": [ + "covr", + "testthat (>= 1.0.0)", + "knitr", + "rmarkdown" + ], + "RoxygenNote": "5.0.1.9000", + "VignetteBuilder": "knitr", + "Imports": [ + "rematch", + "tibble" + ], + "NeedsCompilation": "no", + "Author": "Jennifer Bryan [cre, aut], Hadley Wickham [ctb]", + "Maintainer": "Jennifer Bryan ", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "checkmate": { + "Package": "checkmate", + "Version": "2.3.2", + "Source": "Repository", + "Type": "Package", + "Title": "Fast and Versatile Argument Checks", + "Description": "Tests and assertions to perform frequent argument checks. A substantial part of the package was written in C to minimize any worries about execution time overhead.", + "Authors@R": "c( person(\"Michel\", \"Lang\", NULL, \"michellang@gmail.com\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Bernd\", \"Bischl\", NULL, \"bernd_bischl@gmx.net\", role = \"ctb\"), person(\"Dénes\", \"Tóth\", NULL, \"toth.denes@kogentum.hu\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4262-3217\")) )", + "URL": "https://mllg.github.io/checkmate/, https://github.com/mllg/checkmate", + "URLNote": "https://github.com/mllg/checkmate", + "BugReports": "https://github.com/mllg/checkmate/issues", + "NeedsCompilation": "yes", + "ByteCompile": "yes", + "Encoding": "UTF-8", + "Depends": [ + "R (>= 3.0.0)" + ], + "Imports": [ + "backports (>= 1.1.0)", + "utils" + ], + "Suggests": [ + "R6", + "fastmatch", + "data.table (>= 1.9.8)", + "devtools", + "ggplot2", + "knitr", + "magrittr", + "microbenchmark", + "rmarkdown", + "testthat (>= 3.0.4)", + "tinytest (>= 1.1.0)", + "tibble" + ], + "License": "BSD_3_clause + file LICENSE", + "VignetteBuilder": "knitr", + "RoxygenNote": "7.3.2", + "Collate": "'AssertCollection.R' 'allMissing.R' 'anyInfinite.R' 'anyMissing.R' 'anyNaN.R' 'asInteger.R' 'assert.R' 'helper.R' 'makeExpectation.R' 'makeTest.R' 'makeAssertion.R' 'checkAccess.R' 'checkArray.R' 'checkAtomic.R' 'checkAtomicVector.R' 'checkCharacter.R' 'checkChoice.R' 'checkClass.R' 'checkComplex.R' 'checkCount.R' 'checkDataFrame.R' 'checkDataTable.R' 'checkDate.R' 'checkDirectoryExists.R' 'checkDisjunct.R' 'checkDouble.R' 'checkEnvironment.R' 'checkFALSE.R' 'checkFactor.R' 'checkFileExists.R' 'checkFlag.R' 'checkFormula.R' 'checkFunction.R' 'checkInt.R' 'checkInteger.R' 'checkIntegerish.R' 'checkList.R' 'checkLogical.R' 'checkMatrix.R' 'checkMultiClass.R' 'checkNamed.R' 'checkNames.R' 'checkNull.R' 'checkNumber.R' 'checkNumeric.R' 'checkOS.R' 'checkPOSIXct.R' 'checkPathForOutput.R' 'checkPermutation.R' 'checkR6.R' 'checkRaw.R' 'checkScalar.R' 'checkScalarNA.R' 'checkSetEqual.R' 'checkString.R' 'checkSubset.R' 'checkTRUE.R' 'checkTibble.R' 'checkVector.R' 'coalesce.R' 'isIntegerish.R' 'matchArg.R' 'qassert.R' 'qassertr.R' 'vname.R' 'wfwl.R' 'zzz.R'", + "Author": "Michel Lang [cre, aut] (), Bernd Bischl [ctb], Dénes Tóth [ctb] ()", + "Maintainer": "Michel Lang ", + "Repository": "RSPM" + }, + "class": { + "Package": "class", + "Version": "7.3-23", + "Source": "Repository", + "Priority": "recommended", + "Date": "2025-01-01", + "Depends": [ + "R (>= 3.0.0)", + "stats", + "utils" + ], + "Imports": [ + "MASS" + ], + "Authors@R": "c(person(\"Brian\", \"Ripley\", role = c(\"aut\", \"cre\", \"cph\"), email = \"Brian.Ripley@R-project.org\"), person(\"William\", \"Venables\", role = \"cph\"))", + "Description": "Various functions for classification, including k-nearest neighbour, Learning Vector Quantization and Self-Organizing Maps.", + "Title": "Functions for Classification", + "ByteCompile": "yes", + "License": "GPL-2 | GPL-3", + "URL": "http://www.stats.ox.ac.uk/pub/MASS4/", + "NeedsCompilation": "yes", + "Author": "Brian Ripley [aut, cre, cph], William Venables [cph]", + "Maintainer": "Brian Ripley ", + "Repository": "CRAN" + }, + "cli": { + "Package": "cli", + "Version": "3.6.4", + "Source": "Repository", + "Title": "Helpers for Developing Command Line Interfaces", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"gabor@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Kirill\", \"Müller\", role = \"ctb\"), person(\"Salim\", \"Brüggemann\", , \"salim-b@pm.me\", role = \"ctb\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A suite of tools to build attractive command line interfaces ('CLIs'), from semantic elements: headings, lists, alerts, paragraphs, etc. Supports custom themes via a 'CSS'-like language. It also contains a number of lower level 'CLI' elements: rules, boxes, trees, and 'Unicode' symbols with 'ASCII' alternatives. It support ANSI colors and text styles as well.", + "License": "MIT + file LICENSE", + "URL": "https://cli.r-lib.org, https://github.com/r-lib/cli", + "BugReports": "https://github.com/r-lib/cli/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "utils" + ], + "Suggests": [ + "callr", + "covr", + "crayon", + "digest", + "glue (>= 1.6.0)", + "grDevices", + "htmltools", + "htmlwidgets", + "knitr", + "methods", + "processx", + "ps (>= 1.3.4.9000)", + "rlang (>= 1.0.2.9003)", + "rmarkdown", + "rprojroot", + "rstudioapi", + "testthat (>= 3.2.0)", + "tibble", + "whoami", + "withr" + ], + "Config/Needs/website": "r-lib/asciicast, bench, brio, cpp11, decor, desc, fansi, prettyunits, sessioninfo, tidyverse/tidytemplate, usethis, vctrs", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Gábor Csárdi [aut, cre], Hadley Wickham [ctb], Kirill Müller [ctb], Salim Brüggemann [ctb] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + }, + "clipr": { + "Package": "clipr", + "Version": "0.8.0", + "Source": "Repository", + "Type": "Package", + "Title": "Read and Write from the System Clipboard", + "Authors@R": "c( person(\"Matthew\", \"Lincoln\", , \"matthew.d.lincoln@gmail.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4387-3384\")), person(\"Louis\", \"Maddox\", role = \"ctb\"), person(\"Steve\", \"Simpson\", role = \"ctb\"), person(\"Jennifer\", \"Bryan\", role = \"ctb\") )", + "Description": "Simple utility functions to read from and write to the Windows, OS X, and X11 clipboards.", + "License": "GPL-3", + "URL": "https://github.com/mdlincoln/clipr, http://matthewlincoln.net/clipr/", + "BugReports": "https://github.com/mdlincoln/clipr/issues", + "Imports": [ + "utils" + ], + "Suggests": [ + "covr", + "knitr", + "rmarkdown", + "rstudioapi (>= 0.5)", + "testthat (>= 2.0.0)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.1.2", + "SystemRequirements": "xclip (https://github.com/astrand/xclip) or xsel (http://www.vergenet.net/~conrad/software/xsel/) for accessing the X11 clipboard, or wl-clipboard (https://github.com/bugaevc/wl-clipboard) for systems using Wayland.", + "NeedsCompilation": "no", + "Author": "Matthew Lincoln [aut, cre] (), Louis Maddox [ctb], Steve Simpson [ctb], Jennifer Bryan [ctb]", + "Maintainer": "Matthew Lincoln ", + "Repository": "RSPM" + }, + "colorspace": { + "Package": "colorspace", + "Version": "2.1-1", + "Source": "Repository", + "Date": "2024-07-26", + "Title": "A Toolbox for Manipulating and Assessing Colors and Palettes", + "Authors@R": "c(person(given = \"Ross\", family = \"Ihaka\", role = \"aut\", email = \"ihaka@stat.auckland.ac.nz\"), person(given = \"Paul\", family = \"Murrell\", role = \"aut\", email = \"paul@stat.auckland.ac.nz\", comment = c(ORCID = \"0000-0002-3224-8858\")), person(given = \"Kurt\", family = \"Hornik\", role = \"aut\", email = \"Kurt.Hornik@R-project.org\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(given = c(\"Jason\", \"C.\"), family = \"Fisher\", role = \"aut\", email = \"jfisher@usgs.gov\", comment = c(ORCID = \"0000-0001-9032-8912\")), person(given = \"Reto\", family = \"Stauffer\", role = \"aut\", email = \"Reto.Stauffer@uibk.ac.at\", comment = c(ORCID = \"0000-0002-3798-5507\")), person(given = c(\"Claus\", \"O.\"), family = \"Wilke\", role = \"aut\", email = \"wilke@austin.utexas.edu\", comment = c(ORCID = \"0000-0002-7470-9261\")), person(given = c(\"Claire\", \"D.\"), family = \"McWhite\", role = \"aut\", email = \"claire.mcwhite@utmail.utexas.edu\", comment = c(ORCID = \"0000-0001-7346-3047\")), person(given = \"Achim\", family = \"Zeileis\", role = c(\"aut\", \"cre\"), email = \"Achim.Zeileis@R-project.org\", comment = c(ORCID = \"0000-0003-0918-3766\")))", + "Description": "Carries out mapping between assorted color spaces including RGB, HSV, HLS, CIEXYZ, CIELUV, HCL (polar CIELUV), CIELAB, and polar CIELAB. Qualitative, sequential, and diverging color palettes based on HCL colors are provided along with corresponding ggplot2 color scales. Color palette choice is aided by an interactive app (with either a Tcl/Tk or a shiny graphical user interface) and shiny apps with an HCL color picker and a color vision deficiency emulator. Plotting functions for displaying and assessing palettes include color swatches, visualizations of the HCL space, and trajectories in HCL and/or RGB spectrum. Color manipulation functions include: desaturation, lightening/darkening, mixing, and simulation of color vision deficiencies (deutanomaly, protanomaly, tritanomaly). Details can be found on the project web page at and in the accompanying scientific paper: Zeileis et al. (2020, Journal of Statistical Software, ).", + "Depends": [ + "R (>= 3.0.0)", + "methods" + ], + "Imports": [ + "graphics", + "grDevices", + "stats" + ], + "Suggests": [ + "datasets", + "utils", + "KernSmooth", + "MASS", + "kernlab", + "mvtnorm", + "vcd", + "tcltk", + "shiny", + "shinyjs", + "ggplot2", + "dplyr", + "scales", + "grid", + "png", + "jpeg", + "knitr", + "rmarkdown", + "RColorBrewer", + "rcartocolor", + "scico", + "viridis", + "wesanderson" + ], + "VignetteBuilder": "knitr", + "License": "BSD_3_clause + file LICENSE", + "URL": "https://colorspace.R-Forge.R-project.org/, https://hclwizard.org/", + "BugReports": "https://colorspace.R-Forge.R-project.org/contact.html", + "LazyData": "yes", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "NeedsCompilation": "yes", + "Author": "Ross Ihaka [aut], Paul Murrell [aut] (), Kurt Hornik [aut] (), Jason C. Fisher [aut] (), Reto Stauffer [aut] (), Claus O. Wilke [aut] (), Claire D. McWhite [aut] (), Achim Zeileis [aut, cre] ()", + "Maintainer": "Achim Zeileis ", + "Repository": "RSPM" + }, + "commonmark": { + "Package": "commonmark", + "Version": "1.9.2", + "Source": "Repository", + "Type": "Package", + "Title": "High Performance CommonMark and Github Markdown Rendering in R", + "Authors@R": "c( person(\"Jeroen\", \"Ooms\", ,\"jeroenooms@gmail.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"John MacFarlane\", role = \"cph\", comment = \"Author of cmark\"))", + "Description": "The CommonMark specification defines a rationalized version of markdown syntax. This package uses the 'cmark' reference implementation for converting markdown text into various formats including html, latex and groff man. In addition it exposes the markdown parse tree in xml format. Also includes opt-in support for GFM extensions including tables, autolinks, and strikethrough text.", + "License": "BSD_2_clause + file LICENSE", + "URL": "https://docs.ropensci.org/commonmark/ https://ropensci.r-universe.dev/commonmark", + "BugReports": "https://github.com/r-lib/commonmark/issues", + "Suggests": [ + "curl", + "testthat", + "xml2" + ], + "RoxygenNote": "7.2.3", + "Language": "en-US", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] (), John MacFarlane [cph] (Author of cmark)", + "Maintainer": "Jeroen Ooms ", + "Repository": "RSPM" + }, + "cowplot": { + "Package": "cowplot", + "Version": "1.1.3", + "Source": "Repository", + "Title": "Streamlined Plot Theme and Plot Annotations for 'ggplot2'", + "Authors@R": "person( given = \"Claus O.\", family = \"Wilke\", role = c(\"aut\", \"cre\"), email = \"wilke@austin.utexas.edu\", comment = c(ORCID = \"0000-0002-7470-9261\") )", + "Description": "Provides various features that help with creating publication-quality figures with 'ggplot2', such as a set of themes, functions to align plots and arrange them into complex compound figures, and functions that make it easy to annotate plots and or mix plots with images. The package was originally written for internal use in the Wilke lab, hence the name (Claus O. Wilke's plot package). It has also been used extensively in the book Fundamentals of Data Visualization.", + "URL": "https://wilkelab.org/cowplot/", + "BugReports": "https://github.com/wilkelab/cowplot/issues", + "Depends": [ + "R (>= 3.5.0)" + ], + "Imports": [ + "ggplot2 (>= 3.4.0)", + "grid", + "gtable", + "grDevices", + "methods", + "rlang", + "scales" + ], + "License": "GPL-2", + "Suggests": [ + "Cairo", + "covr", + "dplyr", + "forcats", + "gridGraphics (>= 0.4-0)", + "knitr", + "lattice", + "magick", + "maps", + "PASWR", + "patchwork", + "rmarkdown", + "ragg", + "testthat (>= 1.0.0)", + "tidyr", + "vdiffr (>= 0.3.0)", + "VennDiagram" + ], + "VignetteBuilder": "knitr", + "Collate": "'add_sub.R' 'align_plots.R' 'as_grob.R' 'as_gtable.R' 'axis_canvas.R' 'cowplot.R' 'draw.R' 'get_plot_component.R' 'get_axes.R' 'get_titles.R' 'get_legend.R' 'get_panel.R' 'gtable.R' 'key_glyph.R' 'plot_grid.R' 'save.R' 'set_null_device.R' 'setup.R' 'stamp.R' 'themes.R' 'utils_ggplot2.R'", + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Claus O. Wilke [aut, cre] ()", + "Maintainer": "Claus O. Wilke ", + "Repository": "CRAN" + }, + "cpp11": { + "Package": "cpp11", + "Version": "0.5.1", + "Source": "Repository", + "Title": "A C++11 Interface for R's C Interface", + "Authors@R": "c( person(\"Davis\", \"Vaughan\", email = \"davis@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4777-038X\")), person(\"Jim\",\"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Romain\", \"François\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Benjamin\", \"Kietzman\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides a header only, C++11 interface to R's C interface. Compared to other approaches 'cpp11' strives to be safe against long jumps from the C API as well as C++ exceptions, conform to normal R function semantics and supports interaction with 'ALTREP' vectors.", + "License": "MIT + file LICENSE", + "URL": "https://cpp11.r-lib.org, https://github.com/r-lib/cpp11", + "BugReports": "https://github.com/r-lib/cpp11/issues", + "Depends": [ + "R (>= 4.0.0)" + ], + "Suggests": [ + "bench", + "brio", + "callr", + "cli", + "covr", + "decor", + "desc", + "ggplot2", + "glue", + "knitr", + "lobstr", + "mockery", + "progress", + "rmarkdown", + "scales", + "Rcpp", + "testthat (>= 3.2.0)", + "tibble", + "utils", + "vctrs", + "withr" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/Needs/cpp11/cpp_register": "brio, cli, decor, desc, glue, tibble, vctrs", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Davis Vaughan [aut, cre] (), Jim Hester [aut] (), Romain François [aut] (), Benjamin Kietzman [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Davis Vaughan ", + "Repository": "CRAN" + }, + "crayon": { + "Package": "crayon", + "Version": "1.5.3", + "Source": "Repository", + "Title": "Colored Terminal Output", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Brodie\", \"Gaslam\", , \"brodie.gaslam@yahoo.com\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "The crayon package is now superseded. Please use the 'cli' package for new projects. Colored terminal output on terminals that support 'ANSI' color and highlight codes. It also works in 'Emacs' 'ESS'. 'ANSI' color support is automatically detected. Colors and highlighting can be combined and nested. New styles can also be created easily. This package was inspired by the 'chalk' 'JavaScript' project.", + "License": "MIT + file LICENSE", + "URL": "https://r-lib.github.io/crayon/, https://github.com/r-lib/crayon", + "BugReports": "https://github.com/r-lib/crayon/issues", + "Imports": [ + "grDevices", + "methods", + "utils" + ], + "Suggests": [ + "mockery", + "rstudioapi", + "testthat", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "Collate": "'aaa-rstudio-detect.R' 'aaaa-rematch2.R' 'aab-num-ansi-colors.R' 'aac-num-ansi-colors.R' 'ansi-256.R' 'ansi-palette.R' 'combine.R' 'string.R' 'utils.R' 'crayon-package.R' 'disposable.R' 'enc-utils.R' 'has_ansi.R' 'has_color.R' 'link.R' 'styles.R' 'machinery.R' 'parts.R' 'print.R' 'style-var.R' 'show.R' 'string_operations.R'", + "NeedsCompilation": "no", + "Author": "Gábor Csárdi [aut, cre], Brodie Gaslam [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "RSPM" + }, + "crosstalk": { + "Package": "crosstalk", + "Version": "1.2.1", + "Source": "Repository", + "Type": "Package", + "Title": "Inter-Widget Interactivity for HTML Widgets", + "Authors@R": "c( person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@posit.co\"), person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"carson@posit.co\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js library\"), person(\"Kristopher Michael\", \"Kowal\", role = c(\"ctb\", \"cph\"), comment = \"es5-shim library\"), person(family = \"es5-shim contributors\", role = c(\"ctb\", \"cph\"), comment = \"es5-shim library\"), person(\"Denis\", \"Ineshin\", role = c(\"ctb\", \"cph\"), comment = \"ion.rangeSlider library\"), person(\"Sami\", \"Samhuri\", role = c(\"ctb\", \"cph\"), comment = \"Javascript strftime library\") )", + "Description": "Provides building blocks for allowing HTML widgets to communicate with each other, with Shiny or without (i.e. static .html files). Currently supports linked brushing and filtering.", + "License": "MIT + file LICENSE", + "Imports": [ + "htmltools (>= 0.3.6)", + "jsonlite", + "lazyeval", + "R6" + ], + "Suggests": [ + "shiny", + "ggplot2", + "testthat (>= 2.1.0)", + "sass", + "bslib" + ], + "URL": "https://rstudio.github.io/crosstalk/, https://github.com/rstudio/crosstalk", + "BugReports": "https://github.com/rstudio/crosstalk/issues", + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Joe Cheng [aut], Carson Sievert [aut, cre] (), Posit Software, PBC [cph, fnd], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Brian Reavis [ctb, cph] (selectize.js library), Kristopher Michael Kowal [ctb, cph] (es5-shim library), es5-shim contributors [ctb, cph] (es5-shim library), Denis Ineshin [ctb, cph] (ion.rangeSlider library), Sami Samhuri [ctb, cph] (Javascript strftime library)", + "Maintainer": "Carson Sievert ", + "Repository": "RSPM" + }, + "curl": { + "Package": "curl", + "Version": "6.2.0", + "Source": "Repository", + "Type": "Package", + "Title": "A Modern and Flexible Web Client for R", + "Authors@R": "c( person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Posit Software, PBC\", role = \"cph\"))", + "Description": "Bindings to 'libcurl' for performing fully configurable HTTP/FTP requests where responses can be processed in memory, on disk, or streaming via the callback or connection interfaces. Some knowledge of 'libcurl' is recommended; for a more-user-friendly web client see the 'httr2' package which builds on this package with http specific tools and logic.", + "License": "MIT + file LICENSE", + "SystemRequirements": "libcurl (>= 7.62): libcurl-devel (rpm) or libcurl4-openssl-dev (deb)", + "URL": "https://jeroen.r-universe.dev/curl", + "BugReports": "https://github.com/jeroen/curl/issues", + "Suggests": [ + "spelling", + "testthat (>= 1.0.0)", + "knitr", + "jsonlite", + "later", + "rmarkdown", + "httpuv (>= 1.4.4)", + "webutils" + ], + "VignetteBuilder": "knitr", + "Depends": [ + "R (>= 3.0.0)" + ], + "RoxygenNote": "7.3.2.9000", + "Encoding": "UTF-8", + "Language": "en-US", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] (), Hadley Wickham [ctb], Posit Software, PBC [cph]", + "Maintainer": "Jeroen Ooms ", + "Repository": "CRAN" + }, + "data.table": { + "Package": "data.table", + "Version": "1.16.4", + "Source": "Repository", + "Title": "Extension of `data.frame`", + "Depends": [ + "R (>= 3.3.0)" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "bit64 (>= 4.0.0)", + "bit (>= 4.0.4)", + "R.utils", + "xts", + "zoo (>= 1.8-1)", + "yaml", + "knitr", + "markdown" + ], + "Description": "Fast aggregation of large data (e.g. 100GB in RAM), fast ordered joins, fast add/modify/delete of columns by group using no copies at all, list columns, friendly and fast character-separated-value read/write. Offers a natural and flexible syntax, for faster development.", + "License": "MPL-2.0 | file LICENSE", + "URL": "https://r-datatable.com, https://Rdatatable.gitlab.io/data.table, https://github.com/Rdatatable/data.table", + "BugReports": "https://github.com/Rdatatable/data.table/issues", + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "ByteCompile": "TRUE", + "Authors@R": "c( person(\"Tyson\",\"Barrett\", role=c(\"aut\",\"cre\"), email=\"t.barrett88@gmail.com\", comment = c(ORCID=\"0000-0002-2137-1391\")), person(\"Matt\",\"Dowle\", role=\"aut\", email=\"mattjdowle@gmail.com\"), person(\"Arun\",\"Srinivasan\", role=\"aut\", email=\"asrini@pm.me\"), person(\"Jan\",\"Gorecki\", role=\"aut\"), person(\"Michael\",\"Chirico\", role=\"aut\", comment = c(ORCID=\"0000-0003-0787-087X\")), person(\"Toby\",\"Hocking\", role=\"aut\", comment = c(ORCID=\"0000-0002-3146-0865\")), person(\"Benjamin\",\"Schwendinger\",role=\"aut\", comment = c(ORCID=\"0000-0003-3315-8114\")), person(\"Pasha\",\"Stetsenko\", role=\"ctb\"), person(\"Tom\",\"Short\", role=\"ctb\"), person(\"Steve\",\"Lianoglou\", role=\"ctb\"), person(\"Eduard\",\"Antonyan\", role=\"ctb\"), person(\"Markus\",\"Bonsch\", role=\"ctb\"), person(\"Hugh\",\"Parsonage\", role=\"ctb\"), person(\"Scott\",\"Ritchie\", role=\"ctb\"), person(\"Kun\",\"Ren\", role=\"ctb\"), person(\"Xianying\",\"Tan\", role=\"ctb\"), person(\"Rick\",\"Saporta\", role=\"ctb\"), person(\"Otto\",\"Seiskari\", role=\"ctb\"), person(\"Xianghui\",\"Dong\", role=\"ctb\"), person(\"Michel\",\"Lang\", role=\"ctb\"), person(\"Watal\",\"Iwasaki\", role=\"ctb\"), person(\"Seth\",\"Wenchel\", role=\"ctb\"), person(\"Karl\",\"Broman\", role=\"ctb\"), person(\"Tobias\",\"Schmidt\", role=\"ctb\"), person(\"David\",\"Arenburg\", role=\"ctb\"), person(\"Ethan\",\"Smith\", role=\"ctb\"), person(\"Francois\",\"Cocquemas\", role=\"ctb\"), person(\"Matthieu\",\"Gomez\", role=\"ctb\"), person(\"Philippe\",\"Chataignon\", role=\"ctb\"), person(\"Nello\",\"Blaser\", role=\"ctb\"), person(\"Dmitry\",\"Selivanov\", role=\"ctb\"), person(\"Andrey\",\"Riabushenko\", role=\"ctb\"), person(\"Cheng\",\"Lee\", role=\"ctb\"), person(\"Declan\",\"Groves\", role=\"ctb\"), person(\"Daniel\",\"Possenriede\", role=\"ctb\"), person(\"Felipe\",\"Parages\", role=\"ctb\"), person(\"Denes\",\"Toth\", role=\"ctb\"), person(\"Mus\",\"Yaramaz-David\", role=\"ctb\"), person(\"Ayappan\",\"Perumal\", role=\"ctb\"), person(\"James\",\"Sams\", role=\"ctb\"), person(\"Martin\",\"Morgan\", role=\"ctb\"), person(\"Michael\",\"Quinn\", role=\"ctb\"), person(\"@javrucebo\",\"\", role=\"ctb\"), person(\"@marc-outins\",\"\", role=\"ctb\"), person(\"Roy\",\"Storey\", role=\"ctb\"), person(\"Manish\",\"Saraswat\", role=\"ctb\"), person(\"Morgan\",\"Jacob\", role=\"ctb\"), person(\"Michael\",\"Schubmehl\", role=\"ctb\"), person(\"Davis\",\"Vaughan\", role=\"ctb\"), person(\"Leonardo\",\"Silvestri\", role=\"ctb\"), person(\"Jim\",\"Hester\", role=\"ctb\"), person(\"Anthony\",\"Damico\", role=\"ctb\"), person(\"Sebastian\",\"Freundt\", role=\"ctb\"), person(\"David\",\"Simons\", role=\"ctb\"), person(\"Elliott\",\"Sales de Andrade\", role=\"ctb\"), person(\"Cole\",\"Miller\", role=\"ctb\"), person(\"Jens Peder\",\"Meldgaard\", role=\"ctb\"), person(\"Vaclav\",\"Tlapak\", role=\"ctb\"), person(\"Kevin\",\"Ushey\", role=\"ctb\"), person(\"Dirk\",\"Eddelbuettel\", role=\"ctb\"), person(\"Tony\",\"Fischetti\", role=\"ctb\"), person(\"Ofek\",\"Shilon\", role=\"ctb\"), person(\"Vadim\",\"Khotilovich\", role=\"ctb\"), person(\"Hadley\",\"Wickham\", role=\"ctb\"), person(\"Bennet\",\"Becker\", role=\"ctb\"), person(\"Kyle\",\"Haynes\", role=\"ctb\"), person(\"Boniface Christian\",\"Kamgang\", role=\"ctb\"), person(\"Olivier\",\"Delmarcell\", role=\"ctb\"), person(\"Josh\",\"O'Brien\", role=\"ctb\"), person(\"Dereck\",\"de Mezquita\", role=\"ctb\"), person(\"Michael\",\"Czekanski\", role=\"ctb\"), person(\"Dmitry\", \"Shemetov\", role=\"ctb\"), person(\"Nitish\", \"Jha\", role=\"ctb\"), person(\"Joshua\", \"Wu\", role=\"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role=\"ctb\"), person(\"Anirban\", \"Chetia\", role=\"ctb\"), person(\"Doris\", \"Amoakohene\", role=\"ctb\"), person(\"Ivan\", \"Krylov\", role=\"ctb\") )", + "NeedsCompilation": "yes", + "Author": "Tyson Barrett [aut, cre] (), Matt Dowle [aut], Arun Srinivasan [aut], Jan Gorecki [aut], Michael Chirico [aut] (), Toby Hocking [aut] (), Benjamin Schwendinger [aut] (), Pasha Stetsenko [ctb], Tom Short [ctb], Steve Lianoglou [ctb], Eduard Antonyan [ctb], Markus Bonsch [ctb], Hugh Parsonage [ctb], Scott Ritchie [ctb], Kun Ren [ctb], Xianying Tan [ctb], Rick Saporta [ctb], Otto Seiskari [ctb], Xianghui Dong [ctb], Michel Lang [ctb], Watal Iwasaki [ctb], Seth Wenchel [ctb], Karl Broman [ctb], Tobias Schmidt [ctb], David Arenburg [ctb], Ethan Smith [ctb], Francois Cocquemas [ctb], Matthieu Gomez [ctb], Philippe Chataignon [ctb], Nello Blaser [ctb], Dmitry Selivanov [ctb], Andrey Riabushenko [ctb], Cheng Lee [ctb], Declan Groves [ctb], Daniel Possenriede [ctb], Felipe Parages [ctb], Denes Toth [ctb], Mus Yaramaz-David [ctb], Ayappan Perumal [ctb], James Sams [ctb], Martin Morgan [ctb], Michael Quinn [ctb], @javrucebo [ctb], @marc-outins [ctb], Roy Storey [ctb], Manish Saraswat [ctb], Morgan Jacob [ctb], Michael Schubmehl [ctb], Davis Vaughan [ctb], Leonardo Silvestri [ctb], Jim Hester [ctb], Anthony Damico [ctb], Sebastian Freundt [ctb], David Simons [ctb], Elliott Sales de Andrade [ctb], Cole Miller [ctb], Jens Peder Meldgaard [ctb], Vaclav Tlapak [ctb], Kevin Ushey [ctb], Dirk Eddelbuettel [ctb], Tony Fischetti [ctb], Ofek Shilon [ctb], Vadim Khotilovich [ctb], Hadley Wickham [ctb], Bennet Becker [ctb], Kyle Haynes [ctb], Boniface Christian Kamgang [ctb], Olivier Delmarcell [ctb], Josh O'Brien [ctb], Dereck de Mezquita [ctb], Michael Czekanski [ctb], Dmitry Shemetov [ctb], Nitish Jha [ctb], Joshua Wu [ctb], Iago Giné-Vázquez [ctb], Anirban Chetia [ctb], Doris Amoakohene [ctb], Ivan Krylov [ctb]", + "Maintainer": "Tyson Barrett ", + "Repository": "CRAN" + }, + "desc": { + "Package": "desc", + "Version": "1.4.3", + "Source": "Repository", + "Title": "Manipulate DESCRIPTION Files", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Kirill\", \"Müller\", role = \"aut\"), person(\"Jim\", \"Hester\", , \"james.f.hester@gmail.com\", role = \"aut\"), person(\"Maëlle\", \"Salmon\", role = \"ctb\", comment = c(ORCID = \"0000-0002-2815-0399\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Maintainer": "Gábor Csárdi ", + "Description": "Tools to read, write, create, and manipulate DESCRIPTION files. It is intended for packages that create or manipulate other packages.", + "License": "MIT + file LICENSE", + "URL": "https://desc.r-lib.org/, https://github.com/r-lib/desc", + "BugReports": "https://github.com/r-lib/desc/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "cli", + "R6", + "utils" + ], + "Suggests": [ + "callr", + "covr", + "gh", + "spelling", + "testthat", + "whoami", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.2.3", + "Collate": "'assertions.R' 'authors-at-r.R' 'built.R' 'classes.R' 'collate.R' 'constants.R' 'deps.R' 'desc-package.R' 'description.R' 'encoding.R' 'find-package-root.R' 'latex.R' 'non-oo-api.R' 'package-archives.R' 'read.R' 'remotes.R' 'str.R' 'syntax_checks.R' 'urls.R' 'utils.R' 'validate.R' 'version.R'", + "NeedsCompilation": "no", + "Author": "Gábor Csárdi [aut, cre], Kirill Müller [aut], Jim Hester [aut], Maëlle Salmon [ctb] (), Posit Software, PBC [cph, fnd]", + "Repository": "RSPM" + }, + "digest": { + "Package": "digest", + "Version": "0.6.37", + "Source": "Repository", + "Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Antoine\", \"Lucas\", role=\"ctb\"), person(\"Jarek\", \"Tuszynski\", role=\"ctb\"), person(\"Henrik\", \"Bengtsson\", role=\"ctb\", comment = c(ORCID = \"0000-0002-7579-5165\")), person(\"Simon\", \"Urbanek\", role=\"ctb\", comment = c(ORCID = \"0000-0003-2297-1732\")), person(\"Mario\", \"Frasca\", role=\"ctb\"), person(\"Bryan\", \"Lewis\", role=\"ctb\"), person(\"Murray\", \"Stokely\", role=\"ctb\"), person(\"Hannes\", \"Muehleisen\", role=\"ctb\"), person(\"Duncan\", \"Murdoch\", role=\"ctb\"), person(\"Jim\", \"Hester\", role=\"ctb\"), person(\"Wush\", \"Wu\", role=\"ctb\", comment = c(ORCID = \"0000-0001-5180-0567\")), person(\"Qiang\", \"Kou\", role=\"ctb\", comment = c(ORCID = \"0000-0001-6786-5453\")), person(\"Thierry\", \"Onkelinx\", role=\"ctb\", comment = c(ORCID = \"0000-0001-8804-4216\")), person(\"Michel\", \"Lang\", role=\"ctb\", comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Viliam\", \"Simko\", role=\"ctb\"), person(\"Kurt\", \"Hornik\", role=\"ctb\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(\"Radford\", \"Neal\", role=\"ctb\", comment = c(ORCID = \"0000-0002-2473-3407\")), person(\"Kendon\", \"Bell\", role=\"ctb\", comment = c(ORCID = \"0000-0002-9093-8312\")), person(\"Matthew\", \"de Queljoe\", role=\"ctb\"), person(\"Dmitry\", \"Selivanov\", role=\"ctb\"), person(\"Ion\", \"Suruceanu\", role=\"ctb\"), person(\"Bill\", \"Denney\", role=\"ctb\"), person(\"Dirk\", \"Schumacher\", role=\"ctb\"), person(\"András\", \"Svraka\", role=\"ctb\"), person(\"Sergey\", \"Fedorov\", role=\"ctb\"), person(\"Will\", \"Landau\", role=\"ctb\", comment = c(ORCID = \"0000-0003-1878-3253\")), person(\"Floris\", \"Vanderhaeghe\", role=\"ctb\", comment = c(ORCID = \"0000-0002-6378-6229\")), person(\"Kevin\", \"Tappe\", role=\"ctb\"), person(\"Harris\", \"McGehee\", role=\"ctb\"), person(\"Tim\", \"Mastny\", role=\"ctb\"), person(\"Aaron\", \"Peikert\", role=\"ctb\", comment = c(ORCID = \"0000-0001-7813-818X\")), person(\"Mark\", \"van der Loo\", role=\"ctb\", comment = c(ORCID = \"0000-0002-9807-4686\")), person(\"Chris\", \"Muir\", role=\"ctb\", comment = c(ORCID = \"0000-0003-2555-3878\")), person(\"Moritz\", \"Beller\", role=\"ctb\", comment = c(ORCID = \"0000-0003-4852-0526\")), person(\"Sebastian\", \"Campbell\", role=\"ctb\"), person(\"Winston\", \"Chang\", role=\"ctb\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Dean\", \"Attali\", role=\"ctb\", comment = c(ORCID = \"0000-0002-5645-3493\")), person(\"Michael\", \"Chirico\", role=\"ctb\", comment = c(ORCID = \"0000-0003-0787-087X\")), person(\"Kevin\", \"Ushey\", role=\"ctb\"))", + "Date": "2024-08-19", + "Title": "Create Compact Hash Digests of R Objects", + "Description": "Implementation of a function 'digest()' for the creation of hash digests of arbitrary R objects (using the 'md5', 'sha-1', 'sha-256', 'crc32', 'xxhash', 'murmurhash', 'spookyhash', 'blake3', 'crc32c', 'xxh3_64', and 'xxh3_128' algorithms) permitting easy comparison of R language objects, as well as functions such as'hmac()' to create hash-based message authentication code. Please note that this package is not meant to be deployed for cryptographic purposes for which more comprehensive (and widely tested) libraries such as 'OpenSSL' should be used.", + "URL": "https://github.com/eddelbuettel/digest, https://dirk.eddelbuettel.com/code/digest.html", + "BugReports": "https://github.com/eddelbuettel/digest/issues", + "Depends": [ + "R (>= 3.3.0)" + ], + "Imports": [ + "utils" + ], + "License": "GPL (>= 2)", + "Suggests": [ + "tinytest", + "simplermarkdown" + ], + "VignetteBuilder": "simplermarkdown", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Dirk Eddelbuettel [aut, cre] (), Antoine Lucas [ctb], Jarek Tuszynski [ctb], Henrik Bengtsson [ctb] (), Simon Urbanek [ctb] (), Mario Frasca [ctb], Bryan Lewis [ctb], Murray Stokely [ctb], Hannes Muehleisen [ctb], Duncan Murdoch [ctb], Jim Hester [ctb], Wush Wu [ctb] (), Qiang Kou [ctb] (), Thierry Onkelinx [ctb] (), Michel Lang [ctb] (), Viliam Simko [ctb], Kurt Hornik [ctb] (), Radford Neal [ctb] (), Kendon Bell [ctb] (), Matthew de Queljoe [ctb], Dmitry Selivanov [ctb], Ion Suruceanu [ctb], Bill Denney [ctb], Dirk Schumacher [ctb], András Svraka [ctb], Sergey Fedorov [ctb], Will Landau [ctb] (), Floris Vanderhaeghe [ctb] (), Kevin Tappe [ctb], Harris McGehee [ctb], Tim Mastny [ctb], Aaron Peikert [ctb] (), Mark van der Loo [ctb] (), Chris Muir [ctb] (), Moritz Beller [ctb] (), Sebastian Campbell [ctb], Winston Chang [ctb] (), Dean Attali [ctb] (), Michael Chirico [ctb] (), Kevin Ushey [ctb]", + "Maintainer": "Dirk Eddelbuettel ", + "Repository": "CRAN" + }, + "dplyr": { + "Package": "dplyr", + "Version": "1.1.4", + "Source": "Repository", + "Type": "Package", + "Title": "A Grammar of Data Manipulation", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Romain\", \"François\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Lionel\", \"Henry\", role = \"aut\"), person(\"Kirill\", \"Müller\", role = \"aut\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4777-038X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A fast, consistent tool for working with data frame like objects, both in memory and out of memory.", + "License": "MIT + file LICENSE", + "URL": "https://dplyr.tidyverse.org, https://github.com/tidyverse/dplyr", + "BugReports": "https://github.com/tidyverse/dplyr/issues", + "Depends": [ + "R (>= 3.5.0)" + ], + "Imports": [ + "cli (>= 3.4.0)", + "generics", + "glue (>= 1.3.2)", + "lifecycle (>= 1.0.3)", + "magrittr (>= 1.5)", + "methods", + "pillar (>= 1.9.0)", + "R6", + "rlang (>= 1.1.0)", + "tibble (>= 3.2.0)", + "tidyselect (>= 1.2.0)", + "utils", + "vctrs (>= 0.6.4)" + ], + "Suggests": [ + "bench", + "broom", + "callr", + "covr", + "DBI", + "dbplyr (>= 2.2.1)", + "ggplot2", + "knitr", + "Lahman", + "lobstr", + "microbenchmark", + "nycflights13", + "purrr", + "rmarkdown", + "RMySQL", + "RPostgreSQL", + "RSQLite", + "stringi (>= 1.7.6)", + "testthat (>= 3.1.5)", + "tidyr (>= 1.3.0)", + "withr" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse, shiny, pkgdown, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre] (), Romain François [aut] (), Lionel Henry [aut], Kirill Müller [aut] (), Davis Vaughan [aut] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "e1071": { + "Package": "e1071", + "Version": "1.7-16", + "Source": "Repository", + "Title": "Misc Functions of the Department of Statistics, Probability Theory Group (Formerly: E1071), TU Wien", + "Imports": [ + "graphics", + "grDevices", + "class", + "stats", + "methods", + "utils", + "proxy" + ], + "Suggests": [ + "cluster", + "mlbench", + "nnet", + "randomForest", + "rpart", + "SparseM", + "xtable", + "Matrix", + "MASS", + "slam" + ], + "Authors@R": "c(person(given = \"David\", family = \"Meyer\", role = c(\"aut\", \"cre\"), email = \"David.Meyer@R-project.org\", comment = c(ORCID = \"0000-0002-5196-3048\")), person(given = \"Evgenia\", family = \"Dimitriadou\", role = c(\"aut\",\"cph\")), person(given = \"Kurt\", family = \"Hornik\", role = \"aut\", email = \"Kurt.Hornik@R-project.org\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(given = \"Andreas\", family = \"Weingessel\", role = \"aut\"), person(given = \"Friedrich\", family = \"Leisch\", role = \"aut\"), person(given = \"Chih-Chung\", family = \"Chang\", role = c(\"ctb\",\"cph\"), comment = \"libsvm C++-code\"), person(given = \"Chih-Chen\", family = \"Lin\", role = c(\"ctb\",\"cph\"), comment = \"libsvm C++-code\"))", + "Description": "Functions for latent class analysis, short time Fourier transform, fuzzy clustering, support vector machines, shortest path computation, bagged clustering, naive Bayes classifier, generalized k-nearest neighbour ...", + "License": "GPL-2 | GPL-3", + "LazyLoad": "yes", + "NeedsCompilation": "yes", + "Author": "David Meyer [aut, cre] (), Evgenia Dimitriadou [aut, cph], Kurt Hornik [aut] (), Andreas Weingessel [aut], Friedrich Leisch [aut], Chih-Chung Chang [ctb, cph] (libsvm C++-code), Chih-Chen Lin [ctb, cph] (libsvm C++-code)", + "Maintainer": "David Meyer ", + "Repository": "CRAN" + }, + "evaluate": { + "Package": "evaluate", + "Version": "1.0.3", + "Source": "Repository", + "Type": "Package", + "Title": "Parsing and Evaluation Tools that Provide More Details than the Default", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Yihui\", \"Xie\", role = \"aut\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Michael\", \"Lawrence\", role = \"ctb\"), person(\"Thomas\", \"Kluyver\", role = \"ctb\"), person(\"Jeroen\", \"Ooms\", role = \"ctb\"), person(\"Barret\", \"Schloerke\", role = \"ctb\"), person(\"Adam\", \"Ryczkowski\", role = \"ctb\"), person(\"Hiroaki\", \"Yutani\", role = \"ctb\"), person(\"Michel\", \"Lang\", role = \"ctb\"), person(\"Karolis\", \"Koncevičius\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Parsing and evaluation tools that make it easy to recreate the command line behaviour of R.", + "License": "MIT + file LICENSE", + "URL": "https://evaluate.r-lib.org/, https://github.com/r-lib/evaluate", + "BugReports": "https://github.com/r-lib/evaluate/issues", + "Depends": [ + "R (>= 3.6.0)" + ], + "Suggests": [ + "callr", + "covr", + "ggplot2 (>= 3.3.6)", + "lattice", + "methods", + "pkgload", + "rlang", + "knitr", + "testthat (>= 3.0.0)", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre], Yihui Xie [aut] (), Michael Lawrence [ctb], Thomas Kluyver [ctb], Jeroen Ooms [ctb], Barret Schloerke [ctb], Adam Ryczkowski [ctb], Hiroaki Yutani [ctb], Michel Lang [ctb], Karolis Koncevičius [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "CRAN" + }, + "expm": { + "Package": "expm", + "Version": "1.0-0", + "Source": "Repository", + "Type": "Package", + "Title": "Matrix Exponential, Log, 'etc'", + "Date": "2024-08-19", + "Authors@R": "c(person(\"Martin\", \"Maechler\", role=c(\"aut\",\"cre\"), email=\"maechler@stat.math.ethz.ch\", comment = c(ORCID = \"0000-0002-8685-9910\")) , person(\"Christophe\",\"Dutang\", role = \"aut\", comment = c(ORCID = \"0000-0001-6732-1501\")) , person(\"Vincent\", \"Goulet\", role = \"aut\", comment = c(ORCID = \"0000-0002-9315-5719\")) , person(\"Douglas\", \"Bates\", role = \"ctb\", comment = \"cosmetic clean up, in svn r42\") , person(\"David\", \"Firth\", role = \"ctb\", comment = \"expm(method= \\\"PadeO\\\" and \\\"TaylorO\\\")\") , person(\"Marina\", \"Shapira\", role = \"ctb\", comment = \"expm(method= \\\"PadeO\\\" and \\\"TaylorO\\\")\") , person(\"Michael\", \"Stadelmann\", role = \"ctb\", comment = \"\\\"Higham08*\\\" methods, see ?expm.Higham08...\") )", + "Contact": "expm-developers@lists.R-forge.R-project.org", + "Description": "Computation of the matrix exponential, logarithm, sqrt, and related quantities, using traditional and modern methods.", + "Depends": [ + "Matrix" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "RColorBrewer", + "sfsmisc", + "Rmpfr" + ], + "BuildResaveData": "no", + "License": "GPL (>= 2)", + "URL": "https://R-Forge.R-project.org/projects/expm/", + "BugReports": "https://R-forge.R-project.org/tracker/?atid=472&group_id=107", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Martin Maechler [aut, cre] (), Christophe Dutang [aut] (), Vincent Goulet [aut] (), Douglas Bates [ctb] (cosmetic clean up, in svn r42), David Firth [ctb] (expm(method= \"PadeO\" and \"TaylorO\")), Marina Shapira [ctb] (expm(method= \"PadeO\" and \"TaylorO\")), Michael Stadelmann [ctb] (\"Higham08*\" methods, see ?expm.Higham08...)", + "Maintainer": "Martin Maechler ", + "Repository": "CRAN" + }, + "fansi": { + "Package": "fansi", + "Version": "1.0.6", + "Source": "Repository", + "Title": "ANSI Control Sequence Aware String Functions", + "Description": "Counterparts to R string manipulation functions that account for the effects of ANSI text formatting control sequences.", + "Authors@R": "c( person(\"Brodie\", \"Gaslam\", email=\"brodie.gaslam@yahoo.com\", role=c(\"aut\", \"cre\")), person(\"Elliott\", \"Sales De Andrade\", role=\"ctb\"), person(family=\"R Core Team\", email=\"R-core@r-project.org\", role=\"cph\", comment=\"UTF8 byte length calcs from src/util.c\" ))", + "Depends": [ + "R (>= 3.1.0)" + ], + "License": "GPL-2 | GPL-3", + "URL": "https://github.com/brodieG/fansi", + "BugReports": "https://github.com/brodieG/fansi/issues", + "VignetteBuilder": "knitr", + "Suggests": [ + "unitizer", + "knitr", + "rmarkdown" + ], + "Imports": [ + "grDevices", + "utils" + ], + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "Collate": "'constants.R' 'fansi-package.R' 'internal.R' 'load.R' 'misc.R' 'nchar.R' 'strwrap.R' 'strtrim.R' 'strsplit.R' 'substr2.R' 'trimws.R' 'tohtml.R' 'unhandled.R' 'normalize.R' 'sgr.R'", + "NeedsCompilation": "yes", + "Author": "Brodie Gaslam [aut, cre], Elliott Sales De Andrade [ctb], R Core Team [cph] (UTF8 byte length calcs from src/util.c)", + "Maintainer": "Brodie Gaslam ", + "Repository": "RSPM" + }, + "farver": { + "Package": "farver", + "Version": "2.1.2", + "Source": "Repository", + "Type": "Package", + "Title": "High Performance Colour Space Manipulation", + "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Berendea\", \"Nicolae\", role = \"aut\", comment = \"Author of the ColorSpace C++ library\"), person(\"Romain\", \"François\", , \"romain@purrple.cat\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "The encoding of colour can be handled in many different ways, using different colour spaces. As different colour spaces have different uses, efficient conversion between these representations are important. The 'farver' package provides a set of functions that gives access to very fast colour space conversion and comparisons implemented in C++, and offers speed improvements over the 'convertColor' function in the 'grDevices' package.", + "License": "MIT + file LICENSE", + "URL": "https://farver.data-imaginist.com, https://github.com/thomasp85/farver", + "BugReports": "https://github.com/thomasp85/farver/issues", + "Suggests": [ + "covr", + "testthat (>= 3.0.0)" + ], + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "NeedsCompilation": "yes", + "Author": "Thomas Lin Pedersen [cre, aut] (), Berendea Nicolae [aut] (Author of the ColorSpace C++ library), Romain François [aut] (), Posit, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "RSPM" + }, + "fastmap": { + "Package": "fastmap", + "Version": "1.2.0", + "Source": "Repository", + "Title": "Fast Data Structures", + "Authors@R": "c( person(\"Winston\", \"Chang\", email = \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(given = \"Tessil\", role = \"cph\", comment = \"hopscotch_map library\") )", + "Description": "Fast implementation of data structures, including a key-value store, stack, and queue. Environments are commonly used as key-value stores in R, but every time a new key is used, it is added to R's global symbol table, causing a small amount of memory leakage. This can be problematic in cases where many different keys are used. Fastmap avoids this memory leak issue by implementing the map using data structures in C++.", + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "Suggests": [ + "testthat (>= 2.1.1)" + ], + "URL": "https://r-lib.github.io/fastmap/, https://github.com/r-lib/fastmap", + "BugReports": "https://github.com/r-lib/fastmap/issues", + "NeedsCompilation": "yes", + "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd], Tessil [cph] (hopscotch_map library)", + "Maintainer": "Winston Chang ", + "Repository": "RSPM" + }, + "flextable": { + "Package": "flextable", + "Version": "0.9.7", + "Source": "Repository", + "Type": "Package", + "Title": "Functions for Tabular Reporting", + "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"ArData\", role = \"cph\"), person(\"Clementine\", \"Jager\", role = \"ctb\"), person(\"Eli\", \"Daniels\", role = \"ctb\"), person(\"Panagiotis\", \"Skintzos\", , \"panagiotis.skintzos@ardata.fr\", role = \"aut\"), person(\"Quentin\", \"Fazilleau\", role = \"ctb\"), person(\"Maxim\", \"Nazarov\", role = \"ctb\"), person(\"Titouan\", \"Robert\", role = \"ctb\"), person(\"Michael\", \"Barrowman\", role = \"ctb\"), person(\"Atsushi\", \"Yasumoto\", role = \"ctb\"), person(\"Paul\", \"Julian\", role = \"ctb\"), person(\"Sean\", \"Browning\", role = \"ctb\"), person(\"Rémi\", \"Thériault\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4315-6788\")), person(\"Samuel\", \"Jobert\", role = \"ctb\"), person(\"Keith\", \"Newman\", role = \"ctb\") )", + "Description": "Use a grammar for creating and customizing pretty tables. The following formats are supported: 'HTML', 'PDF', 'RTF', 'Microsoft Word', 'Microsoft PowerPoint' and R 'Grid Graphics'. 'R Markdown', 'Quarto' and the package 'officer' can be used to produce the result files. The syntax is the same for the user regardless of the type of output to be produced. A set of functions allows the creation, definition of cell arrangement, addition of headers or footers, formatting and definition of cell content with text and or images. The package also offers a set of high-level functions that allow tabular reporting of statistical models and the creation of complex cross tabulations.", + "License": "GPL-3", + "URL": "https://ardata-fr.github.io/flextable-book/, https://davidgohel.github.io/flextable/", + "BugReports": "https://github.com/davidgohel/flextable/issues", + "Imports": [ + "data.table (>= 1.13.0)", + "gdtools (>= 0.4.0)", + "graphics", + "grDevices", + "grid", + "htmltools", + "knitr", + "officer (>= 0.6.7)", + "ragg", + "rlang", + "rmarkdown (>= 2.0)", + "stats", + "utils", + "uuid (>= 0.1-4)", + "xml2" + ], + "Suggests": [ + "bookdown (>= 0.40)", + "broom", + "broom.mixed", + "chromote", + "cluster", + "commonmark", + "doconv (>= 0.3.0)", + "equatags", + "ggplot2", + "lme4", + "magick", + "mgcv", + "nlme", + "officedown", + "pdftools", + "pkgdown (>= 2.0.0)", + "scales", + "svglite", + "tables (>= 0.9.17)", + "testthat (>= 3.0.0)", + "webshot2", + "withr", + "xtable" + ], + "VignetteBuilder": "knitr", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "David Gohel [aut, cre], ArData [cph], Clementine Jager [ctb], Eli Daniels [ctb], Panagiotis Skintzos [aut], Quentin Fazilleau [ctb], Maxim Nazarov [ctb], Titouan Robert [ctb], Michael Barrowman [ctb], Atsushi Yasumoto [ctb], Paul Julian [ctb], Sean Browning [ctb], Rémi Thériault [ctb] (), Samuel Jobert [ctb], Keith Newman [ctb]", + "Maintainer": "David Gohel ", + "Repository": "CRAN" + }, + "fontBitstreamVera": { + "Package": "fontBitstreamVera", + "Version": "0.1.1", + "Source": "Repository", + "Title": "Fonts with 'Bitstream Vera Fonts' License", + "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel.hry@gmail.com\", c(\"cre\", \"aut\")), person(\"Bitstream\", role = \"cph\"))", + "Description": "Provides fonts licensed under the 'Bitstream Vera Fonts' license for the 'fontquiver' package.", + "Depends": [ + "R (>= 3.0.0)" + ], + "License": "file LICENCE", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "5.0.1", + "NeedsCompilation": "no", + "Author": "Lionel Henry [cre, aut], Bitstream [cph]", + "Maintainer": "Lionel Henry ", + "License_is_FOSS": "yes", + "Repository": "CRAN" + }, + "fontLiberation": { + "Package": "fontLiberation", + "Version": "0.1.0", + "Source": "Repository", + "Title": "Liberation Fonts", + "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", \"cre\"), person(\"Pravin Satpute\", role = \"aut\"), person(\"Steve Matteson\", role = \"aut\"), person(\"Red Hat, Inc\", role = \"cph\"), person(\"Google Corporation\", role = \"cph\"))", + "Description": "A placeholder for the Liberation fontset intended for the `fontquiver` package. This fontset covers the 12 combinations of families (sans, serif, mono) and faces (plain, bold, italic, bold italic) supported in R graphics devices.", + "Depends": [ + "R (>= 3.0)" + ], + "License": "file LICENSE", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "5.0.1", + "NeedsCompilation": "no", + "Author": "Lionel Henry [cre], Pravin Satpute [aut], Steve Matteson [aut], Red Hat, Inc [cph], Google Corporation [cph]", + "Maintainer": "Lionel Henry ", + "Repository": "CRAN", + "License_is_FOSS": "yes" + }, + "fontawesome": { + "Package": "fontawesome", + "Version": "0.5.3", + "Source": "Repository", + "Type": "Package", + "Title": "Easily Work with 'Font Awesome' Icons", + "Description": "Easily and flexibly insert 'Font Awesome' icons into 'R Markdown' documents and 'Shiny' apps. These icons can be inserted into HTML content through inline 'SVG' tags or 'i' tags. There is also a utility function for exporting 'Font Awesome' icons as 'PNG' images for those situations where raster graphics are needed.", + "Authors@R": "c( person(\"Richard\", \"Iannone\", , \"rich@posit.co\", c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Christophe\", \"Dervieux\", , \"cderv@posit.co\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"ctb\"), person(\"Dave\", \"Gandy\", role = c(\"ctb\", \"cph\"), comment = \"Font-Awesome font\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "License": "MIT + file LICENSE", + "URL": "https://github.com/rstudio/fontawesome, https://rstudio.github.io/fontawesome/", + "BugReports": "https://github.com/rstudio/fontawesome/issues", + "Encoding": "UTF-8", + "ByteCompile": "true", + "RoxygenNote": "7.3.2", + "Depends": [ + "R (>= 3.3.0)" + ], + "Imports": [ + "rlang (>= 1.0.6)", + "htmltools (>= 0.5.1.1)" + ], + "Suggests": [ + "covr", + "dplyr (>= 1.0.8)", + "gt (>= 0.9.0)", + "knitr (>= 1.31)", + "testthat (>= 3.0.0)", + "rsvg" + ], + "Config/testthat/edition": "3", + "NeedsCompilation": "no", + "Author": "Richard Iannone [aut, cre] (), Christophe Dervieux [ctb] (), Winston Chang [ctb], Dave Gandy [ctb, cph] (Font-Awesome font), Posit Software, PBC [cph, fnd]", + "Maintainer": "Richard Iannone ", + "Repository": "CRAN" + }, + "fontquiver": { + "Package": "fontquiver", + "Version": "0.2.1", + "Source": "Repository", + "Title": "Set of Installed Fonts", + "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", c(\"cre\", \"aut\")), person(\"RStudio\", role = \"cph\"), person(\"George Douros\", role = \"cph\", comment = \"Symbola font\"))", + "Description": "Provides a set of fonts with permissive licences. This is useful when you want to avoid system fonts to make sure your outputs are reproducible.", + "Depends": [ + "R (>= 3.0.0)" + ], + "Imports": [ + "fontBitstreamVera (>= 0.1.0)", + "fontLiberation (>= 0.1.0)" + ], + "Suggests": [ + "testthat", + "htmltools" + ], + "License": "GPL-3 | file LICENSE", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "5.0.1", + "Collate": "'font-getters.R' 'fontset.R' 'fontset-bitstream-vera.R' 'fontset-dejavu.R' 'fontset-liberation.R' 'fontset-symbola.R' 'html-dependency.R' 'utils.R'", + "NeedsCompilation": "no", + "Author": "Lionel Henry [cre, aut], RStudio [cph], George Douros [cph] (Symbola font)", + "Maintainer": "Lionel Henry ", + "Repository": "CRAN" + }, + "forcats": { + "Package": "forcats", + "Version": "1.0.0", + "Source": "Repository", + "Title": "Tools for Working with Categorical Variables (Factors)", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = c(\"aut\", \"cre\")), person(\"RStudio\", role = c(\"cph\", \"fnd\")) )", + "Description": "Helpers for reordering factor levels (including moving specified levels to front, ordering by first appearance, reversing, and randomly shuffling), and tools for modifying factor levels (including collapsing rare levels into other, 'anonymising', and manually 'recoding').", + "License": "MIT + file LICENSE", + "URL": "https://forcats.tidyverse.org/, https://github.com/tidyverse/forcats", + "BugReports": "https://github.com/tidyverse/forcats/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "cli (>= 3.4.0)", + "glue", + "lifecycle", + "magrittr", + "rlang (>= 1.0.0)", + "tibble" + ], + "Suggests": [ + "covr", + "dplyr", + "ggplot2", + "knitr", + "readr", + "rmarkdown", + "testthat (>= 3.0.0)", + "withr" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre], RStudio [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "formatters": { + "Package": "formatters", + "Version": "0.5.10.9001", + "Source": "Repository", + "Title": "ASCII Formatting for Values and Tables", + "Date": "2025-02-05", + "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "We provide a framework for rendering complex tables to ASCII, and a set of formatters for transforming values or sets of values into ASCII-ready display strings.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/formatters/, https://github.com/insightsengineering/formatters/", + "BugReports": "https://github.com/insightsengineering/formatters/issues", + "Depends": [ + "methods", + "R (>= 2.10)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "grid", + "htmltools (>= 0.5.3)", + "lifecycle (>= 0.2.0)", + "stringi (>= 1.7.12)" + ], + "Suggests": [ + "dplyr (>= 1.0.9)", + "gt (>= 0.10.0)", + "huxtable (>= 2.0.0)", + "knitr (>= 1.42)", + "r2rtf (>= 0.3.2)", + "rmarkdown (>= 2.23)", + "testthat (>= 3.0.4)", + "withr (>= 2.0.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/Needs/verdepcheck": "mllg/checkmate, rstudio/htmltools, r-lib/lifecycle, tidyverse/dplyr, rstudio/gt, hughjonesd/huxtable, yihui/knitr, Merck/r2rtf, rstudio/rmarkdown, gagolews/stringi, r-lib/testthat, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "LazyData": "true", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Collate": "'data.R' 'format_value.R' 'matrix_form.R' 'generics.R' 'labels.R' 'mpf_exporters.R' 'package.R' 'page_size.R' 'pagination.R' 'tostring.R' 'utils.R' 'zzz.R'", + "Config/pak/sysreqs": "libicu-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/formatters", + "RemoteRef": "HEAD", + "RemoteSha": "ee566c9b53f010edae9d0d9a64af82b41cee7b66", + "NeedsCompilation": "no", + "Author": "Gabriel Becker [aut] (original creator of the package), Adrian Waddell [aut], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Joe Zhu " + }, + "fs": { + "Package": "fs", + "Version": "1.6.5", + "Source": "Repository", + "Title": "Cross-Platform File System Operations Based on 'libuv'", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A cross-platform interface to file system operations, built on top of the 'libuv' C library.", + "License": "MIT + file LICENSE", + "URL": "https://fs.r-lib.org, https://github.com/r-lib/fs", + "BugReports": "https://github.com/r-lib/fs/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "covr", + "crayon", + "knitr", + "pillar (>= 1.0.0)", + "rmarkdown", + "spelling", + "testthat (>= 3.0.0)", + "tibble (>= 1.1.0)", + "vctrs (>= 0.3.0)", + "withr" + ], + "VignetteBuilder": "knitr", + "ByteCompile": "true", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Copyright": "file COPYRIGHTS", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.2.3", + "SystemRequirements": "GNU make", + "NeedsCompilation": "yes", + "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut, cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + }, + "gdtools": { + "Package": "gdtools", + "Version": "0.4.1", + "Source": "Repository", + "Title": "Utilities for Graphical Rendering and Fonts Management", + "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", , \"jeroen@berkeley.edu\", role = \"aut\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Yixuan\", \"Qiu\", role = \"ctb\"), person(\"R Core Team\", role = \"cph\", comment = \"Cairo code from X11 device\"), person(\"ArData\", role = \"cph\"), person(\"RStudio\", role = \"cph\") )", + "Description": "Tools are provided to compute metrics of formatted strings and to check the availability of a font. Another set of functions is provided to support the collection of fonts from 'Google Fonts' in a cache. Their use is simple within 'R Markdown' documents and 'shiny' applications but also with graphic productions generated with the 'ggiraph', 'ragg' and 'svglite' packages or with tabular productions from the 'flextable' package.", + "License": "GPL-3 | file LICENSE", + "URL": "https://davidgohel.github.io/gdtools/", + "BugReports": "https://github.com/davidgohel/gdtools/issues", + "Depends": [ + "R (>= 4.0.0)" + ], + "Imports": [ + "fontquiver (>= 0.2.0)", + "htmltools", + "Rcpp (>= 0.12.12)", + "systemfonts (>= 1.1.0)", + "tools" + ], + "Suggests": [ + "curl", + "gfonts", + "methods", + "testthat" + ], + "LinkingTo": [ + "Rcpp" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "SystemRequirements": "cairo, freetype2, fontconfig", + "NeedsCompilation": "yes", + "Author": "David Gohel [aut, cre], Hadley Wickham [aut], Lionel Henry [aut], Jeroen Ooms [aut] (), Yixuan Qiu [ctb], R Core Team [cph] (Cairo code from X11 device), ArData [cph], RStudio [cph]", + "Maintainer": "David Gohel ", + "Repository": "CRAN" + }, + "generics": { + "Package": "generics", + "Version": "0.1.3", + "Source": "Repository", + "Title": "Common S3 Generics not Provided by Base R Methods Related to Model Fitting", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = c(\"aut\", \"cre\")), person(\"Max\", \"Kuhn\", , \"max@rstudio.com\", role = \"aut\"), person(\"Davis\", \"Vaughan\", , \"davis@rstudio.com\", role = \"aut\"), person(\"RStudio\", role = \"cph\") )", + "Description": "In order to reduce potential package dependencies and conflicts, generics provides a number of commonly used S3 generics.", + "License": "MIT + file LICENSE", + "URL": "https://generics.r-lib.org, https://github.com/r-lib/generics", + "BugReports": "https://github.com/r-lib/generics/issues", + "Depends": [ + "R (>= 3.2)" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "covr", + "pkgload", + "testthat (>= 3.0.0)", + "tibble", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.0", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre], Max Kuhn [aut], Davis Vaughan [aut], RStudio [cph]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "ggplot2": { + "Package": "ggplot2", + "Version": "3.5.1", + "Source": "Repository", + "Title": "Create Elegant Data Visualisations Using the Grammar of Graphics", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Winston\", \"Chang\", role = \"aut\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Lionel\", \"Henry\", role = \"aut\"), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Kohske\", \"Takahashi\", role = \"aut\"), person(\"Claus\", \"Wilke\", role = \"aut\", comment = c(ORCID = \"0000-0002-7470-9261\")), person(\"Kara\", \"Woo\", role = \"aut\", comment = c(ORCID = \"0000-0002-5125-4188\")), person(\"Hiroaki\", \"Yutani\", role = \"aut\", comment = c(ORCID = \"0000-0002-3385-7233\")), person(\"Dewey\", \"Dunnington\", role = \"aut\", comment = c(ORCID = \"0000-0002-9415-4582\")), person(\"Teun\", \"van den Brand\", role = \"aut\", comment = c(ORCID = \"0000-0002-9335-7468\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A system for 'declaratively' creating graphics, based on \"The Grammar of Graphics\". You provide the data, tell 'ggplot2' how to map variables to aesthetics, what graphical primitives to use, and it takes care of the details.", + "License": "MIT + file LICENSE", + "URL": "https://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2", + "BugReports": "https://github.com/tidyverse/ggplot2/issues", + "Depends": [ + "R (>= 3.5)" + ], + "Imports": [ + "cli", + "glue", + "grDevices", + "grid", + "gtable (>= 0.1.1)", + "isoband", + "lifecycle (> 1.0.1)", + "MASS", + "mgcv", + "rlang (>= 1.1.0)", + "scales (>= 1.3.0)", + "stats", + "tibble", + "vctrs (>= 0.6.0)", + "withr (>= 2.5.0)" + ], + "Suggests": [ + "covr", + "dplyr", + "ggplot2movies", + "hexbin", + "Hmisc", + "knitr", + "mapproj", + "maps", + "multcomp", + "munsell", + "nlme", + "profvis", + "quantreg", + "ragg (>= 1.2.6)", + "RColorBrewer", + "rmarkdown", + "rpart", + "sf (>= 0.7-3)", + "svglite (>= 2.1.2)", + "testthat (>= 3.1.2)", + "vdiffr (>= 1.0.6)", + "xml2" + ], + "Enhances": [ + "sp" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "ggtext, tidyr, forcats, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.3.1", + "Collate": "'ggproto.R' 'ggplot-global.R' 'aaa-.R' 'aes-colour-fill-alpha.R' 'aes-evaluation.R' 'aes-group-order.R' 'aes-linetype-size-shape.R' 'aes-position.R' 'compat-plyr.R' 'utilities.R' 'aes.R' 'utilities-checks.R' 'legend-draw.R' 'geom-.R' 'annotation-custom.R' 'annotation-logticks.R' 'geom-polygon.R' 'geom-map.R' 'annotation-map.R' 'geom-raster.R' 'annotation-raster.R' 'annotation.R' 'autolayer.R' 'autoplot.R' 'axis-secondary.R' 'backports.R' 'bench.R' 'bin.R' 'coord-.R' 'coord-cartesian-.R' 'coord-fixed.R' 'coord-flip.R' 'coord-map.R' 'coord-munch.R' 'coord-polar.R' 'coord-quickmap.R' 'coord-radial.R' 'coord-sf.R' 'coord-transform.R' 'data.R' 'docs_layer.R' 'facet-.R' 'facet-grid-.R' 'facet-null.R' 'facet-wrap.R' 'fortify-lm.R' 'fortify-map.R' 'fortify-multcomp.R' 'fortify-spatial.R' 'fortify.R' 'stat-.R' 'geom-abline.R' 'geom-rect.R' 'geom-bar.R' 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' 'geom-col.R' 'geom-path.R' 'geom-contour.R' 'geom-count.R' 'geom-crossbar.R' 'geom-segment.R' 'geom-curve.R' 'geom-defaults.R' 'geom-ribbon.R' 'geom-density.R' 'geom-density2d.R' 'geom-dotplot.R' 'geom-errorbar.R' 'geom-errorbarh.R' 'geom-freqpoly.R' 'geom-function.R' 'geom-hex.R' 'geom-histogram.R' 'geom-hline.R' 'geom-jitter.R' 'geom-label.R' 'geom-linerange.R' 'geom-point.R' 'geom-pointrange.R' 'geom-quantile.R' 'geom-rug.R' 'geom-sf.R' 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' 'geom-tile.R' 'geom-violin.R' 'geom-vline.R' 'ggplot2-package.R' 'grob-absolute.R' 'grob-dotstack.R' 'grob-null.R' 'grouping.R' 'theme-elements.R' 'guide-.R' 'guide-axis.R' 'guide-axis-logticks.R' 'guide-axis-stack.R' 'guide-axis-theta.R' 'guide-legend.R' 'guide-bins.R' 'guide-colorbar.R' 'guide-colorsteps.R' 'guide-custom.R' 'layer.R' 'guide-none.R' 'guide-old.R' 'guides-.R' 'guides-grid.R' 'hexbin.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' 'labeller.R' 'labels.R' 'layer-sf.R' 'layout.R' 'limits.R' 'margins.R' 'performance.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' 'plot.R' 'position-.R' 'position-collide.R' 'position-dodge.R' 'position-dodge2.R' 'position-identity.R' 'position-jitter.R' 'position-jitterdodge.R' 'position-nudge.R' 'position-stack.R' 'quick-plot.R' 'reshape-add-margins.R' 'save.R' 'scale-.R' 'scale-alpha.R' 'scale-binned.R' 'scale-brewer.R' 'scale-colour.R' 'scale-continuous.R' 'scale-date.R' 'scale-discrete-.R' 'scale-expansion.R' 'scale-gradient.R' 'scale-grey.R' 'scale-hue.R' 'scale-identity.R' 'scale-linetype.R' 'scale-linewidth.R' 'scale-manual.R' 'scale-shape.R' 'scale-size.R' 'scale-steps.R' 'scale-type.R' 'scale-view.R' 'scale-viridis.R' 'scales-.R' 'stat-align.R' 'stat-bin.R' 'stat-bin2d.R' 'stat-bindot.R' 'stat-binhex.R' 'stat-boxplot.R' 'stat-contour.R' 'stat-count.R' 'stat-density-2d.R' 'stat-density.R' 'stat-ecdf.R' 'stat-ellipse.R' 'stat-function.R' 'stat-identity.R' 'stat-qq-line.R' 'stat-qq.R' 'stat-quantilemethods.R' 'stat-sf-coordinates.R' 'stat-sf.R' 'stat-smooth-methods.R' 'stat-smooth.R' 'stat-sum.R' 'stat-summary-2d.R' 'stat-summary-bin.R' 'stat-summary-hex.R' 'stat-summary.R' 'stat-unique.R' 'stat-ydensity.R' 'summarise-plot.R' 'summary.R' 'theme.R' 'theme-defaults.R' 'theme-current.R' 'utilities-break.R' 'utilities-grid.R' 'utilities-help.R' 'utilities-matrix.R' 'utilities-patterns.R' 'utilities-resolution.R' 'utilities-tidy-eval.R' 'zxx.R' 'zzz.R'", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut] (), Winston Chang [aut] (), Lionel Henry [aut], Thomas Lin Pedersen [aut, cre] (), Kohske Takahashi [aut], Claus Wilke [aut] (), Kara Woo [aut] (), Hiroaki Yutani [aut] (), Dewey Dunnington [aut] (), Teun van den Brand [aut] (), Posit, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "RSPM" + }, + "gld": { + "Package": "gld", + "Version": "2.6.7", + "Source": "Repository", + "Date": "2025-01-17", + "Title": "Estimation and Use of the Generalised (Tukey) Lambda Distribution", + "Suggests": [], + "Imports": [ + "stats", + "graphics", + "e1071", + "lmom" + ], + "Authors@R": "c(person(given=\"Robert\",family=\"King\", role=c(\"aut\",\"cre\"), email=\"Robert.King.Newcastle@gmail.com\", comment=c(ORCID=\"0000-0001-7495-6599\")), person(given=\"Benjamin\",family=\"Dean\", role=\"aut\", email=\"Benjamin.Dean@uon.edu.au\"), person(given=\"Sigbert\",family=\"Klinke\", role=\"aut\"), person(given=\"Paul\",family=\"van Staden\", role=\"aut\",email=\"paul.vanstaden@up.ac.za\", comment=c(ORCID=\"0000-0002-5710-5984\")) )", + "Description": "The generalised lambda distribution, or Tukey lambda distribution, provides a wide variety of shapes with one functional form. This package provides random numbers, quantiles, probabilities, densities and density quantiles for four different types of the distribution, the FKML (Freimer et al 1988), RS (Ramberg and Schmeiser 1974), GPD (van Staden and Loots 2009) and FM5 - see documentation for details. It provides the density function, distribution function, and Quantile-Quantile plots. It implements a variety of estimation methods for the distribution, including diagnostic plots. Estimation methods include the starship (all 4 types), method of L-Moments for the GPD and FKML types, and a number of methods for only the FKML type. These include maximum likelihood, maximum product of spacings, Titterington's method, Moments, Trimmed L-Moments and Distributional Least Absolutes.", + "License": "GPL (>= 2)", + "URL": "https://github.com/newystats/gld/", + "NeedsCompilation": "yes", + "Author": "Robert King [aut, cre] (), Benjamin Dean [aut], Sigbert Klinke [aut], Paul van Staden [aut] ()", + "Maintainer": "Robert King ", + "Repository": "CRAN" + }, + "glue": { + "Package": "glue", + "Version": "1.8.0", + "Source": "Repository", + "Title": "Interpreted String Literals", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "An implementation of interpreted string literals, inspired by Python's Literal String Interpolation and Docstrings and Julia's Triple-Quoted String Literals .", + "License": "MIT + file LICENSE", + "URL": "https://glue.tidyverse.org/, https://github.com/tidyverse/glue", + "BugReports": "https://github.com/tidyverse/glue/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "methods" + ], + "Suggests": [ + "crayon", + "DBI (>= 1.2.0)", + "dplyr", + "knitr", + "magrittr", + "rlang", + "rmarkdown", + "RSQLite", + "testthat (>= 3.2.0)", + "vctrs (>= 0.3.0)", + "waldo (>= 0.5.3)", + "withr" + ], + "VignetteBuilder": "knitr", + "ByteCompile": "true", + "Config/Needs/website": "bench, forcats, ggbeeswarm, ggplot2, R.utils, rprintf, tidyr, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Jim Hester [aut] (), Jennifer Bryan [aut, cre] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Jennifer Bryan ", + "Repository": "RSPM" + }, + "gridExtra": { + "Package": "gridExtra", + "Version": "2.3", + "Source": "Repository", + "Authors@R": "c(person(\"Baptiste\", \"Auguie\", email = \"baptiste.auguie@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Anton\", \"Antonov\", email = \"tonytonov@gmail.com\", role = c(\"ctb\")))", + "License": "GPL (>= 2)", + "Title": "Miscellaneous Functions for \"Grid\" Graphics", + "Type": "Package", + "Description": "Provides a number of user-level functions to work with \"grid\" graphics, notably to arrange multiple grid-based plots on a page, and draw tables.", + "VignetteBuilder": "knitr", + "Imports": [ + "gtable", + "grid", + "grDevices", + "graphics", + "utils" + ], + "Suggests": [ + "ggplot2", + "egg", + "lattice", + "knitr", + "testthat" + ], + "RoxygenNote": "6.0.1", + "NeedsCompilation": "no", + "Author": "Baptiste Auguie [aut, cre], Anton Antonov [ctb]", + "Maintainer": "Baptiste Auguie ", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "gtable": { + "Package": "gtable", + "Version": "0.3.6", + "Source": "Repository", + "Title": "Arrange 'Grobs' in Tables", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Tools to make it easier to work with \"tables\" of 'grobs'. The 'gtable' package defines a 'gtable' grob class that specifies a grid along with a list of grobs and their placement in the grid. Further the package makes it easy to manipulate and combine 'gtable' objects so that complex compositions can be built up sequentially.", + "License": "MIT + file LICENSE", + "URL": "https://gtable.r-lib.org, https://github.com/r-lib/gtable", + "BugReports": "https://github.com/r-lib/gtable/issues", + "Depends": [ + "R (>= 4.0)" + ], + "Imports": [ + "cli", + "glue", + "grid", + "lifecycle", + "rlang (>= 1.1.0)", + "stats" + ], + "Suggests": [ + "covr", + "ggplot2", + "knitr", + "profvis", + "rmarkdown", + "testthat (>= 3.0.0)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/usethis/last-upkeep": "2024-10-25", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut], Thomas Lin Pedersen [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "CRAN" + }, + "haven": { + "Package": "haven", + "Version": "2.5.4", + "Source": "Repository", + "Title": "Import and Export 'SPSS', 'Stata' and 'SAS' Files", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Evan\", \"Miller\", role = c(\"aut\", \"cph\"), comment = \"Author of included ReadStat code\"), person(\"Danny\", \"Smith\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Import foreign statistical formats into R via the embedded 'ReadStat' C library, .", + "License": "MIT + file LICENSE", + "URL": "https://haven.tidyverse.org, https://github.com/tidyverse/haven, https://github.com/WizardMac/ReadStat", + "BugReports": "https://github.com/tidyverse/haven/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli (>= 3.0.0)", + "forcats (>= 0.2.0)", + "hms", + "lifecycle", + "methods", + "readr (>= 0.1.0)", + "rlang (>= 0.4.0)", + "tibble", + "tidyselect", + "vctrs (>= 0.3.0)" + ], + "Suggests": [ + "covr", + "crayon", + "fs", + "knitr", + "pillar (>= 1.4.0)", + "rmarkdown", + "testthat (>= 3.0.0)", + "utf8" + ], + "LinkingTo": [ + "cpp11" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "SystemRequirements": "GNU make, zlib: zlib1g-dev (deb), zlib-devel (rpm)", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre], Evan Miller [aut, cph] (Author of included ReadStat code), Danny Smith [aut], Posit Software, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "highr": { + "Package": "highr", + "Version": "0.11", + "Source": "Repository", + "Type": "Package", + "Title": "Syntax Highlighting for R Source Code", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Yixuan\", \"Qiu\", role = \"aut\"), person(\"Christopher\", \"Gandrud\", role = \"ctb\"), person(\"Qiang\", \"Li\", role = \"ctb\") )", + "Description": "Provides syntax highlighting for R source code. Currently it supports LaTeX and HTML output. Source code of other languages is supported via Andre Simon's highlight package ().", + "Depends": [ + "R (>= 3.3.0)" + ], + "Imports": [ + "xfun (>= 0.18)" + ], + "Suggests": [ + "knitr", + "markdown", + "testit" + ], + "License": "GPL", + "URL": "https://github.com/yihui/highr", + "BugReports": "https://github.com/yihui/highr/issues", + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "NeedsCompilation": "no", + "Author": "Yihui Xie [aut, cre] (), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", + "Maintainer": "Yihui Xie ", + "Repository": "RSPM" + }, + "hms": { + "Package": "hms", + "Version": "1.1.3", + "Source": "Repository", + "Title": "Pretty Time of Day", + "Date": "2023-03-21", + "Authors@R": "c( person(\"Kirill\", \"Müller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(\"R Consortium\", role = \"fnd\"), person(\"RStudio\", role = \"fnd\") )", + "Description": "Implements an S3 class for storing and formatting time-of-day values, based on the 'difftime' class.", + "Imports": [ + "lifecycle", + "methods", + "pkgconfig", + "rlang (>= 1.0.2)", + "vctrs (>= 0.3.8)" + ], + "Suggests": [ + "crayon", + "lubridate", + "pillar (>= 1.1.0)", + "testthat (>= 3.0.0)" + ], + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "URL": "https://hms.tidyverse.org/, https://github.com/tidyverse/hms", + "BugReports": "https://github.com/tidyverse/hms/issues", + "RoxygenNote": "7.2.3", + "Config/testthat/edition": "3", + "Config/autostyle/scope": "line_breaks", + "Config/autostyle/strict": "false", + "Config/Needs/website": "tidyverse/tidytemplate", + "NeedsCompilation": "no", + "Author": "Kirill Müller [aut, cre] (), R Consortium [fnd], RStudio [fnd]", + "Maintainer": "Kirill Müller ", + "Repository": "RSPM" + }, + "htmltools": { + "Package": "htmltools", + "Version": "0.5.8.1", + "Source": "Repository", + "Type": "Package", + "Title": "Tools for HTML", + "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Barret\", \"Schloerke\", , \"barret@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Yihui\", \"Xie\", , \"yihui@posit.co\", role = \"aut\"), person(\"Jeff\", \"Allen\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Tools for HTML generation and output.", + "License": "GPL (>= 2)", + "URL": "https://github.com/rstudio/htmltools, https://rstudio.github.io/htmltools/", + "BugReports": "https://github.com/rstudio/htmltools/issues", + "Depends": [ + "R (>= 2.14.1)" + ], + "Imports": [ + "base64enc", + "digest", + "fastmap (>= 1.1.0)", + "grDevices", + "rlang (>= 1.0.0)", + "utils" + ], + "Suggests": [ + "Cairo", + "markdown", + "ragg", + "shiny", + "testthat", + "withr" + ], + "Enhances": [ + "knitr" + ], + "Config/Needs/check": "knitr", + "Config/Needs/website": "rstudio/quillt, bench", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "Collate": "'colors.R' 'fill.R' 'html_dependency.R' 'html_escape.R' 'html_print.R' 'htmltools-package.R' 'images.R' 'known_tags.R' 'selector.R' 'staticimports.R' 'tag_query.R' 'utils.R' 'tags.R' 'template.R'", + "NeedsCompilation": "yes", + "Author": "Joe Cheng [aut], Carson Sievert [aut, cre] (), Barret Schloerke [aut] (), Winston Chang [aut] (), Yihui Xie [aut], Jeff Allen [aut], Posit Software, PBC [cph, fnd]", + "Maintainer": "Carson Sievert ", + "Repository": "RSPM" + }, + "htmlwidgets": { + "Package": "htmlwidgets", + "Version": "1.6.4", + "Source": "Repository", + "Type": "Package", + "Title": "HTML Widgets for R", + "Authors@R": "c( person(\"Ramnath\", \"Vaidyanathan\", role = c(\"aut\", \"cph\")), person(\"Yihui\", \"Xie\", role = \"aut\"), person(\"JJ\", \"Allaire\", role = \"aut\"), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Kenton\", \"Russell\", role = c(\"aut\", \"cph\")), person(\"Ellis\", \"Hughes\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A framework for creating HTML widgets that render in various contexts including the R console, 'R Markdown' documents, and 'Shiny' web applications.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/ramnathv/htmlwidgets", + "BugReports": "https://github.com/ramnathv/htmlwidgets/issues", + "Imports": [ + "grDevices", + "htmltools (>= 0.5.7)", + "jsonlite (>= 0.9.16)", + "knitr (>= 1.8)", + "rmarkdown", + "yaml" + ], + "Suggests": [ + "testthat" + ], + "Enhances": [ + "shiny (>= 1.1)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Ramnath Vaidyanathan [aut, cph], Yihui Xie [aut], JJ Allaire [aut], Joe Cheng [aut], Carson Sievert [aut, cre] (), Kenton Russell [aut, cph], Ellis Hughes [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Carson Sievert ", + "Repository": "RSPM" + }, + "httpuv": { + "Package": "httpuv", + "Version": "1.6.15", + "Source": "Repository", + "Type": "Package", + "Title": "HTTP and WebSocket Server Library", + "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit, PBC\", \"fnd\", role = \"cph\"), person(\"Hector\", \"Corrada Bravo\", role = \"ctb\"), person(\"Jeroen\", \"Ooms\", role = \"ctb\"), person(\"Andrzej\", \"Krzemienski\", role = \"cph\", comment = \"optional.hpp\"), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library, see src/libuv/AUTHORS file\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library, see src/libuv/AUTHORS file; and http-parser library, see src/http-parser/AUTHORS file\"), person(\"Niels\", \"Provos\", role = \"cph\", comment = \"libuv subcomponent: tree.h\"), person(\"Internet Systems Consortium, Inc.\", role = \"cph\", comment = \"libuv subcomponent: inet_pton and inet_ntop, contained in src/libuv/src/inet.c\"), person(\"Alexander\", \"Chemeris\", role = \"cph\", comment = \"libuv subcomponent: stdint-msvc2008.h (from msinttypes)\"), person(\"Google, Inc.\", role = \"cph\", comment = \"libuv subcomponent: pthread-fixes.c\"), person(\"Sony Mobile Communcations AB\", role = \"cph\", comment = \"libuv subcomponent: pthread-fixes.c\"), person(\"Berkeley Software Design Inc.\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Kenneth\", \"MacKay\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Emergya (Cloud4all, FP7/2007-2013, grant agreement no 289016)\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Steve\", \"Reid\", role = \"aut\", comment = \"SHA-1 implementation\"), person(\"James\", \"Brown\", role = \"aut\", comment = \"SHA-1 implementation\"), person(\"Bob\", \"Trower\", role = \"aut\", comment = \"base64 implementation\"), person(\"Alexander\", \"Peslyak\", role = \"aut\", comment = \"MD5 implementation\"), person(\"Trantor Standard Systems\", role = \"cph\", comment = \"base64 implementation\"), person(\"Igor\", \"Sysoev\", role = \"cph\", comment = \"http-parser\") )", + "Description": "Provides low-level socket and protocol support for handling HTTP and WebSocket requests directly from within R. It is primarily intended as a building block for other packages, rather than making it particularly easy to create complete web applications using httpuv alone. httpuv is built on top of the libuv and http-parser C libraries, both of which were developed by Joyent, Inc. (See LICENSE file for libuv and http-parser license information.)", + "License": "GPL (>= 2) | file LICENSE", + "URL": "https://github.com/rstudio/httpuv", + "BugReports": "https://github.com/rstudio/httpuv/issues", + "Depends": [ + "R (>= 2.15.1)" + ], + "Imports": [ + "later (>= 0.8.0)", + "promises", + "R6", + "Rcpp (>= 1.0.7)", + "utils" + ], + "Suggests": [ + "callr", + "curl", + "testthat", + "websocket" + ], + "LinkingTo": [ + "later", + "Rcpp" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "SystemRequirements": "GNU make, zlib", + "Collate": "'RcppExports.R' 'httpuv.R' 'random_port.R' 'server.R' 'staticServer.R' 'static_paths.R' 'utils.R'", + "NeedsCompilation": "yes", + "Author": "Joe Cheng [aut], Winston Chang [aut, cre], Posit, PBC fnd [cph], Hector Corrada Bravo [ctb], Jeroen Ooms [ctb], Andrzej Krzemienski [cph] (optional.hpp), libuv project contributors [cph] (libuv library, see src/libuv/AUTHORS file), Joyent, Inc. and other Node contributors [cph] (libuv library, see src/libuv/AUTHORS file; and http-parser library, see src/http-parser/AUTHORS file), Niels Provos [cph] (libuv subcomponent: tree.h), Internet Systems Consortium, Inc. [cph] (libuv subcomponent: inet_pton and inet_ntop, contained in src/libuv/src/inet.c), Alexander Chemeris [cph] (libuv subcomponent: stdint-msvc2008.h (from msinttypes)), Google, Inc. [cph] (libuv subcomponent: pthread-fixes.c), Sony Mobile Communcations AB [cph] (libuv subcomponent: pthread-fixes.c), Berkeley Software Design Inc. [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Kenneth MacKay [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Emergya (Cloud4all, FP7/2007-2013, grant agreement no 289016) [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Steve Reid [aut] (SHA-1 implementation), James Brown [aut] (SHA-1 implementation), Bob Trower [aut] (base64 implementation), Alexander Peslyak [aut] (MD5 implementation), Trantor Standard Systems [cph] (base64 implementation), Igor Sysoev [cph] (http-parser)", + "Maintainer": "Winston Chang ", + "Repository": "RSPM" + }, + "httr": { + "Package": "httr", + "Version": "1.4.7", + "Source": "Repository", + "Title": "Tools for Working with URLs and HTTP", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Useful tools for working with HTTP organised by HTTP verbs (GET(), POST(), etc). Configuration functions make it easy to control additional request components (authenticate(), add_headers() and so on).", + "License": "MIT + file LICENSE", + "URL": "https://httr.r-lib.org/, https://github.com/r-lib/httr", + "BugReports": "https://github.com/r-lib/httr/issues", + "Depends": [ + "R (>= 3.5)" + ], + "Imports": [ + "curl (>= 5.0.2)", + "jsonlite", + "mime", + "openssl (>= 0.8)", + "R6" + ], + "Suggests": [ + "covr", + "httpuv", + "jpeg", + "knitr", + "png", + "readr", + "rmarkdown", + "testthat (>= 0.8.0)", + "xml2" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre], Posit, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "isoband": { + "Package": "isoband", + "Version": "0.2.7", + "Source": "Repository", + "Title": "Generate Isolines and Isobands from Regularly Spaced Elevation Grids", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Claus O.\", \"Wilke\", , \"wilke@austin.utexas.edu\", role = \"aut\", comment = c(\"Original author\", ORCID = \"0000-0002-7470-9261\")), person(\"Thomas Lin\", \"Pedersen\", , \"thomasp85@gmail.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-5147-4711\")) )", + "Description": "A fast C++ implementation to generate contour lines (isolines) and contour polygons (isobands) from regularly spaced grids containing elevation data.", + "License": "MIT + file LICENSE", + "URL": "https://isoband.r-lib.org", + "BugReports": "https://github.com/r-lib/isoband/issues", + "Imports": [ + "grid", + "utils" + ], + "Suggests": [ + "covr", + "ggplot2", + "knitr", + "magick", + "microbenchmark", + "rmarkdown", + "sf", + "testthat", + "xml2" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "SystemRequirements": "C++11", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre] (), Claus O. Wilke [aut] (Original author, ), Thomas Lin Pedersen [aut] ()", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "jquerylib": { + "Package": "jquerylib", + "Version": "0.1.4", + "Source": "Repository", + "Title": "Obtain 'jQuery' as an HTML Dependency Object", + "Authors@R": "c( person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"carson@rstudio.com\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@rstudio.com\"), person(family = \"RStudio\", role = \"cph\"), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/lib/jquery-AUTHORS.txt\") )", + "Description": "Obtain any major version of 'jQuery' () and use it in any webpage generated by 'htmltools' (e.g. 'shiny', 'htmlwidgets', and 'rmarkdown'). Most R users don't need to use this package directly, but other R packages (e.g. 'shiny', 'rmarkdown', etc.) depend on this package to avoid bundling redundant copies of 'jQuery'.", + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "Config/testthat/edition": "3", + "RoxygenNote": "7.0.2", + "Imports": [ + "htmltools" + ], + "Suggests": [ + "testthat" + ], + "NeedsCompilation": "no", + "Author": "Carson Sievert [aut, cre] (), Joe Cheng [aut], RStudio [cph], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/lib/jquery-AUTHORS.txt)", + "Maintainer": "Carson Sievert ", + "Repository": "RSPM" + }, + "jsonlite": { + "Package": "jsonlite", + "Version": "1.8.9", + "Source": "Repository", + "Title": "A Simple and Robust JSON Parser and Generator for R", + "License": "MIT + file LICENSE", + "Depends": [ + "methods" + ], + "Authors@R": "c( person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Duncan\", \"Temple Lang\", role = \"ctb\"), person(\"Lloyd\", \"Hilaiel\", role = \"cph\", comment=\"author of bundled libyajl\"))", + "URL": "https://jeroen.r-universe.dev/jsonlite https://arxiv.org/abs/1403.2805", + "BugReports": "https://github.com/jeroen/jsonlite/issues", + "Maintainer": "Jeroen Ooms ", + "VignetteBuilder": "knitr, R.rsp", + "Description": "A reasonably fast JSON parser and generator, optimized for statistical data and the web. Offers simple, flexible tools for working with JSON in R, and is particularly powerful for building pipelines and interacting with a web API. The implementation is based on the mapping described in the vignette (Ooms, 2014). In addition to converting JSON data from/to R objects, 'jsonlite' contains functions to stream, validate, and prettify JSON data. The unit tests included with the package verify that all edge cases are encoded and decoded consistently for use with dynamic data in systems and applications.", + "Suggests": [ + "httr", + "vctrs", + "testthat", + "knitr", + "rmarkdown", + "R.rsp", + "sf" + ], + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] (), Duncan Temple Lang [ctb], Lloyd Hilaiel [cph] (author of bundled libyajl)", + "Repository": "RSPM" + }, + "knitr": { + "Package": "knitr", + "Version": "1.49", + "Source": "Repository", + "Type": "Package", + "Title": "A General-Purpose Package for Dynamic Report Generation in R", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Abhraneel\", \"Sarma\", role = \"ctb\"), person(\"Adam\", \"Vogt\", role = \"ctb\"), person(\"Alastair\", \"Andrew\", role = \"ctb\"), person(\"Alex\", \"Zvoleff\", role = \"ctb\"), person(\"Amar\", \"Al-Zubaidi\", role = \"ctb\"), person(\"Andre\", \"Simon\", role = \"ctb\", comment = \"the CSS files under inst/themes/ were derived from the Highlight package http://www.andre-simon.de\"), person(\"Aron\", \"Atkins\", role = \"ctb\"), person(\"Aaron\", \"Wolen\", role = \"ctb\"), person(\"Ashley\", \"Manton\", role = \"ctb\"), person(\"Atsushi\", \"Yasumoto\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8335-495X\")), person(\"Ben\", \"Baumer\", role = \"ctb\"), person(\"Brian\", \"Diggs\", role = \"ctb\"), person(\"Brian\", \"Zhang\", role = \"ctb\"), person(\"Bulat\", \"Yapparov\", role = \"ctb\"), person(\"Cassio\", \"Pereira\", role = \"ctb\"), person(\"Christophe\", \"Dervieux\", role = \"ctb\"), person(\"David\", \"Hall\", role = \"ctb\"), person(\"David\", \"Hugh-Jones\", role = \"ctb\"), person(\"David\", \"Robinson\", role = \"ctb\"), person(\"Doug\", \"Hemken\", role = \"ctb\"), person(\"Duncan\", \"Murdoch\", role = \"ctb\"), person(\"Elio\", \"Campitelli\", role = \"ctb\"), person(\"Ellis\", \"Hughes\", role = \"ctb\"), person(\"Emily\", \"Riederer\", role = \"ctb\"), person(\"Fabian\", \"Hirschmann\", role = \"ctb\"), person(\"Fitch\", \"Simeon\", role = \"ctb\"), person(\"Forest\", \"Fang\", role = \"ctb\"), person(c(\"Frank\", \"E\", \"Harrell\", \"Jr\"), role = \"ctb\", comment = \"the Sweavel package at inst/misc/Sweavel.sty\"), person(\"Garrick\", \"Aden-Buie\", role = \"ctb\"), person(\"Gregoire\", \"Detrez\", role = \"ctb\"), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Hao\", \"Zhu\", role = \"ctb\"), person(\"Heewon\", \"Jeon\", role = \"ctb\"), person(\"Henrik\", \"Bengtsson\", role = \"ctb\"), person(\"Hiroaki\", \"Yutani\", role = \"ctb\"), person(\"Ian\", \"Lyttle\", role = \"ctb\"), person(\"Hodges\", \"Daniel\", role = \"ctb\"), person(\"Jacob\", \"Bien\", role = \"ctb\"), person(\"Jake\", \"Burkhead\", role = \"ctb\"), person(\"James\", \"Manton\", role = \"ctb\"), person(\"Jared\", \"Lander\", role = \"ctb\"), person(\"Jason\", \"Punyon\", role = \"ctb\"), person(\"Javier\", \"Luraschi\", role = \"ctb\"), person(\"Jeff\", \"Arnold\", role = \"ctb\"), person(\"Jenny\", \"Bryan\", role = \"ctb\"), person(\"Jeremy\", \"Ashkenas\", role = c(\"ctb\", \"cph\"), comment = \"the CSS file at inst/misc/docco-classic.css\"), person(\"Jeremy\", \"Stephens\", role = \"ctb\"), person(\"Jim\", \"Hester\", role = \"ctb\"), person(\"Joe\", \"Cheng\", role = \"ctb\"), person(\"Johannes\", \"Ranke\", role = \"ctb\"), person(\"John\", \"Honaker\", role = \"ctb\"), person(\"John\", \"Muschelli\", role = \"ctb\"), person(\"Jonathan\", \"Keane\", role = \"ctb\"), person(\"JJ\", \"Allaire\", role = \"ctb\"), person(\"Johan\", \"Toloe\", role = \"ctb\"), person(\"Jonathan\", \"Sidi\", role = \"ctb\"), person(\"Joseph\", \"Larmarange\", role = \"ctb\"), person(\"Julien\", \"Barnier\", role = \"ctb\"), person(\"Kaiyin\", \"Zhong\", role = \"ctb\"), person(\"Kamil\", \"Slowikowski\", role = \"ctb\"), person(\"Karl\", \"Forner\", role = \"ctb\"), person(c(\"Kevin\", \"K.\"), \"Smith\", role = \"ctb\"), person(\"Kirill\", \"Mueller\", role = \"ctb\"), person(\"Kohske\", \"Takahashi\", role = \"ctb\"), person(\"Lorenz\", \"Walthert\", role = \"ctb\"), person(\"Lucas\", \"Gallindo\", role = \"ctb\"), person(\"Marius\", \"Hofert\", role = \"ctb\"), person(\"Martin\", \"Modrák\", role = \"ctb\"), person(\"Michael\", \"Chirico\", role = \"ctb\"), person(\"Michael\", \"Friendly\", role = \"ctb\"), person(\"Michal\", \"Bojanowski\", role = \"ctb\"), person(\"Michel\", \"Kuhlmann\", role = \"ctb\"), person(\"Miller\", \"Patrick\", role = \"ctb\"), person(\"Nacho\", \"Caballero\", role = \"ctb\"), person(\"Nick\", \"Salkowski\", role = \"ctb\"), person(\"Niels Richard\", \"Hansen\", role = \"ctb\"), person(\"Noam\", \"Ross\", role = \"ctb\"), person(\"Obada\", \"Mahdi\", role = \"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role = \"ctb\", comment=c(ORCID = \"0000-0002-9101-3362\")), person(\"Pedro\", \"Faria\", role = \"ctb\"), person(\"Qiang\", \"Li\", role = \"ctb\"), person(\"Ramnath\", \"Vaidyanathan\", role = \"ctb\"), person(\"Richard\", \"Cotton\", role = \"ctb\"), person(\"Robert\", \"Krzyzanowski\", role = \"ctb\"), person(\"Rodrigo\", \"Copetti\", role = \"ctb\"), person(\"Romain\", \"Francois\", role = \"ctb\"), person(\"Ruaridh\", \"Williamson\", role = \"ctb\"), person(\"Sagiru\", \"Mati\", role = \"ctb\", comment = c(ORCID = \"0000-0003-1413-3974\")), person(\"Scott\", \"Kostyshak\", role = \"ctb\"), person(\"Sebastian\", \"Meyer\", role = \"ctb\"), person(\"Sietse\", \"Brouwer\", role = \"ctb\"), person(c(\"Simon\", \"de\"), \"Bernard\", role = \"ctb\"), person(\"Sylvain\", \"Rousseau\", role = \"ctb\"), person(\"Taiyun\", \"Wei\", role = \"ctb\"), person(\"Thibaut\", \"Assus\", role = \"ctb\"), person(\"Thibaut\", \"Lamadon\", role = \"ctb\"), person(\"Thomas\", \"Leeper\", role = \"ctb\"), person(\"Tim\", \"Mastny\", role = \"ctb\"), person(\"Tom\", \"Torsney-Weir\", role = \"ctb\"), person(\"Trevor\", \"Davis\", role = \"ctb\"), person(\"Viktoras\", \"Veitas\", role = \"ctb\"), person(\"Weicheng\", \"Zhu\", role = \"ctb\"), person(\"Wush\", \"Wu\", role = \"ctb\"), person(\"Zachary\", \"Foster\", role = \"ctb\"), person(\"Zhian N.\", \"Kamvar\", role = \"ctb\", comment = c(ORCID = \"0000-0003-1458-7108\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides a general-purpose tool for dynamic report generation in R using Literate Programming techniques.", + "Depends": [ + "R (>= 3.6.0)" + ], + "Imports": [ + "evaluate (>= 0.15)", + "highr (>= 0.11)", + "methods", + "tools", + "xfun (>= 0.48)", + "yaml (>= 2.1.19)" + ], + "Suggests": [ + "bslib", + "codetools", + "DBI (>= 0.4-1)", + "digest", + "formatR", + "gifski", + "gridSVG", + "htmlwidgets (>= 0.7)", + "jpeg", + "JuliaCall (>= 0.11.1)", + "magick", + "litedown", + "markdown (>= 1.3)", + "png", + "ragg", + "reticulate (>= 1.4)", + "rgl (>= 0.95.1201)", + "rlang", + "rmarkdown", + "sass", + "showtext", + "styler (>= 1.2.0)", + "targets (>= 0.6.0)", + "testit", + "tibble", + "tikzDevice (>= 0.10)", + "tinytex (>= 0.46)", + "webshot", + "rstudioapi", + "svglite" + ], + "License": "GPL", + "URL": "https://yihui.org/knitr/", + "BugReports": "https://github.com/yihui/knitr/issues", + "Encoding": "UTF-8", + "VignetteBuilder": "litedown, knitr", + "SystemRequirements": "Package vignettes based on R Markdown v2 or reStructuredText require Pandoc (http://pandoc.org). The function rst2pdf() requires rst2pdf (https://github.com/rst2pdf/rst2pdf).", + "Collate": "'block.R' 'cache.R' 'utils.R' 'citation.R' 'hooks-html.R' 'plot.R' 'defaults.R' 'concordance.R' 'engine.R' 'highlight.R' 'themes.R' 'header.R' 'hooks-asciidoc.R' 'hooks-chunk.R' 'hooks-extra.R' 'hooks-latex.R' 'hooks-md.R' 'hooks-rst.R' 'hooks-textile.R' 'hooks.R' 'output.R' 'package.R' 'pandoc.R' 'params.R' 'parser.R' 'pattern.R' 'rocco.R' 'spin.R' 'table.R' 'template.R' 'utils-conversion.R' 'utils-rd2html.R' 'utils-string.R' 'utils-sweave.R' 'utils-upload.R' 'utils-vignettes.R' 'zzz.R'", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Yihui Xie [aut, cre] (), Abhraneel Sarma [ctb], Adam Vogt [ctb], Alastair Andrew [ctb], Alex Zvoleff [ctb], Amar Al-Zubaidi [ctb], Andre Simon [ctb] (the CSS files under inst/themes/ were derived from the Highlight package http://www.andre-simon.de), Aron Atkins [ctb], Aaron Wolen [ctb], Ashley Manton [ctb], Atsushi Yasumoto [ctb] (), Ben Baumer [ctb], Brian Diggs [ctb], Brian Zhang [ctb], Bulat Yapparov [ctb], Cassio Pereira [ctb], Christophe Dervieux [ctb], David Hall [ctb], David Hugh-Jones [ctb], David Robinson [ctb], Doug Hemken [ctb], Duncan Murdoch [ctb], Elio Campitelli [ctb], Ellis Hughes [ctb], Emily Riederer [ctb], Fabian Hirschmann [ctb], Fitch Simeon [ctb], Forest Fang [ctb], Frank E Harrell Jr [ctb] (the Sweavel package at inst/misc/Sweavel.sty), Garrick Aden-Buie [ctb], Gregoire Detrez [ctb], Hadley Wickham [ctb], Hao Zhu [ctb], Heewon Jeon [ctb], Henrik Bengtsson [ctb], Hiroaki Yutani [ctb], Ian Lyttle [ctb], Hodges Daniel [ctb], Jacob Bien [ctb], Jake Burkhead [ctb], James Manton [ctb], Jared Lander [ctb], Jason Punyon [ctb], Javier Luraschi [ctb], Jeff Arnold [ctb], Jenny Bryan [ctb], Jeremy Ashkenas [ctb, cph] (the CSS file at inst/misc/docco-classic.css), Jeremy Stephens [ctb], Jim Hester [ctb], Joe Cheng [ctb], Johannes Ranke [ctb], John Honaker [ctb], John Muschelli [ctb], Jonathan Keane [ctb], JJ Allaire [ctb], Johan Toloe [ctb], Jonathan Sidi [ctb], Joseph Larmarange [ctb], Julien Barnier [ctb], Kaiyin Zhong [ctb], Kamil Slowikowski [ctb], Karl Forner [ctb], Kevin K. Smith [ctb], Kirill Mueller [ctb], Kohske Takahashi [ctb], Lorenz Walthert [ctb], Lucas Gallindo [ctb], Marius Hofert [ctb], Martin Modrák [ctb], Michael Chirico [ctb], Michael Friendly [ctb], Michal Bojanowski [ctb], Michel Kuhlmann [ctb], Miller Patrick [ctb], Nacho Caballero [ctb], Nick Salkowski [ctb], Niels Richard Hansen [ctb], Noam Ross [ctb], Obada Mahdi [ctb], Pavel N. Krivitsky [ctb] (), Pedro Faria [ctb], Qiang Li [ctb], Ramnath Vaidyanathan [ctb], Richard Cotton [ctb], Robert Krzyzanowski [ctb], Rodrigo Copetti [ctb], Romain Francois [ctb], Ruaridh Williamson [ctb], Sagiru Mati [ctb] (), Scott Kostyshak [ctb], Sebastian Meyer [ctb], Sietse Brouwer [ctb], Simon de Bernard [ctb], Sylvain Rousseau [ctb], Taiyun Wei [ctb], Thibaut Assus [ctb], Thibaut Lamadon [ctb], Thomas Leeper [ctb], Tim Mastny [ctb], Tom Torsney-Weir [ctb], Trevor Davis [ctb], Viktoras Veitas [ctb], Weicheng Zhu [ctb], Wush Wu [ctb], Zachary Foster [ctb], Zhian N. Kamvar [ctb] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Yihui Xie ", + "Repository": "CRAN" + }, + "labeling": { + "Package": "labeling", + "Version": "0.4.3", + "Source": "Repository", + "Type": "Package", + "Title": "Axis Labeling", + "Date": "2023-08-29", + "Author": "Justin Talbot,", + "Maintainer": "Nuno Sempere ", + "Description": "Functions which provide a range of axis labeling algorithms.", + "License": "MIT + file LICENSE | Unlimited", + "Collate": "'labeling.R'", + "NeedsCompilation": "no", + "Imports": [ + "stats", + "graphics" + ], + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "labelled": { + "Package": "labelled", + "Version": "2.14.0", + "Source": "Repository", + "Type": "Package", + "Title": "Manipulating Labelled Data", + "Maintainer": "Joseph Larmarange ", + "Authors@R": "c( person(\"Joseph\", \"Larmarange\", email = \"joseph@larmarange.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7097-700X\")), person(\"Daniel\", \"Ludecke\", role = \"ctb\"), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Michal\", \"Bojanowski\", role = \"ctb\"), person(\"François\", \"Briatte\", role = \"ctb\") )", + "Description": "Work with labelled data imported from 'SPSS' or 'Stata' with 'haven' or 'foreign'. This package provides useful functions to deal with \"haven_labelled\" and \"haven_labelled_spss\" classes introduced by 'haven' package.", + "License": "GPL (>= 3)", + "Encoding": "UTF-8", + "Depends": [ + "R (>= 3.2)" + ], + "Imports": [ + "haven (>= 2.4.1)", + "cli", + "dplyr (>= 1.1.0)", + "lifecycle", + "rlang (>= 1.1.0)", + "vctrs", + "stringr", + "tidyr", + "tidyselect" + ], + "Suggests": [ + "testthat (>= 3.2.0)", + "knitr", + "rmarkdown", + "questionr", + "snakecase", + "spelling" + ], + "Enhances": [ + "memisc" + ], + "URL": "https://larmarange.github.io/labelled/, https://github.com/larmarange/labelled", + "BugReports": "https://github.com/larmarange/labelled/issues", + "VignetteBuilder": "knitr", + "LazyData": "true", + "RoxygenNote": "7.3.2", + "Language": "en-US", + "Config/testthat/edition": "3", + "Config/Needs/check": "memisc", + "NeedsCompilation": "no", + "Author": "Joseph Larmarange [aut, cre] (), Daniel Ludecke [ctb], Hadley Wickham [ctb], Michal Bojanowski [ctb], François Briatte [ctb]", + "Repository": "CRAN" + }, + "later": { + "Package": "later", + "Version": "1.4.1", + "Source": "Repository", + "Type": "Package", + "Title": "Utilities for Scheduling Functions to Execute Later with Event Loops", + "Authors@R": "c( person(\"Winston\", \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@posit.co\"), person(\"Joe\", \"Cheng\", role = c(\"aut\"), email = \"joe@posit.co\"), person(\"Charlie\", \"Gao\", role = c(\"aut\"), email = \"charlie.gao@shikokuchuo.net\", comment = c(ORCID = \"0000-0002-0750-061X\")), person(family = \"Posit Software, PBC\", role = \"cph\"), person(\"Marcus\", \"Geelnard\", role = c(\"ctb\", \"cph\"), comment = \"TinyCThread library, https://tinycthread.github.io/\"), person(\"Evan\", \"Nemerson\", role = c(\"ctb\", \"cph\"), comment = \"TinyCThread library, https://tinycthread.github.io/\") )", + "Description": "Executes arbitrary R or C functions some time after the current time, after the R execution stack has emptied. The functions are scheduled in an event loop.", + "URL": "https://r-lib.github.io/later/, https://github.com/r-lib/later", + "BugReports": "https://github.com/r-lib/later/issues", + "License": "MIT + file LICENSE", + "Imports": [ + "Rcpp (>= 0.12.9)", + "rlang" + ], + "LinkingTo": [ + "Rcpp" + ], + "RoxygenNote": "7.3.2", + "Suggests": [ + "knitr", + "nanonext", + "R6", + "rmarkdown", + "testthat (>= 2.1.0)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Winston Chang [aut, cre], Joe Cheng [aut], Charlie Gao [aut] (), Posit Software, PBC [cph], Marcus Geelnard [ctb, cph] (TinyCThread library, https://tinycthread.github.io/), Evan Nemerson [ctb, cph] (TinyCThread library, https://tinycthread.github.io/)", + "Maintainer": "Winston Chang ", + "Repository": "CRAN" + }, + "lattice": { + "Package": "lattice", + "Version": "0.22-6", + "Source": "Repository", + "Date": "2024-03-20", + "Priority": "recommended", + "Title": "Trellis Graphics for R", + "Authors@R": "c(person(\"Deepayan\", \"Sarkar\", role = c(\"aut\", \"cre\"), email = \"deepayan.sarkar@r-project.org\", comment = c(ORCID = \"0000-0003-4107-1553\")), person(\"Felix\", \"Andrews\", role = \"ctb\"), person(\"Kevin\", \"Wright\", role = \"ctb\", comment = \"documentation\"), person(\"Neil\", \"Klepeis\", role = \"ctb\"), person(\"Johan\", \"Larsson\", role = \"ctb\", comment = \"miscellaneous improvements\"), person(\"Zhijian (Jason)\", \"Wen\", role = \"cph\", comment = \"filled contour code\"), person(\"Paul\", \"Murrell\", role = \"ctb\", email = \"paul@stat.auckland.ac.nz\"), person(\"Stefan\", \"Eng\", role = \"ctb\", comment = \"violin plot improvements\"), person(\"Achim\", \"Zeileis\", role = \"ctb\", comment = \"modern colors\"), person(\"Alexandre\", \"Courtiol\", role = \"ctb\", comment = \"generics for larrows, lpolygon, lrect and lsegments\") )", + "Description": "A powerful and elegant high-level data visualization system inspired by Trellis graphics, with an emphasis on multivariate data. Lattice is sufficient for typical graphics needs, and is also flexible enough to handle most nonstandard requirements. See ?Lattice for an introduction.", + "Depends": [ + "R (>= 4.0.0)" + ], + "Suggests": [ + "KernSmooth", + "MASS", + "latticeExtra", + "colorspace" + ], + "Imports": [ + "grid", + "grDevices", + "graphics", + "stats", + "utils" + ], + "Enhances": [ + "chron", + "zoo" + ], + "LazyLoad": "yes", + "LazyData": "yes", + "License": "GPL (>= 2)", + "URL": "https://lattice.r-forge.r-project.org/", + "BugReports": "https://github.com/deepayan/lattice/issues", + "NeedsCompilation": "yes", + "Author": "Deepayan Sarkar [aut, cre] (), Felix Andrews [ctb], Kevin Wright [ctb] (documentation), Neil Klepeis [ctb], Johan Larsson [ctb] (miscellaneous improvements), Zhijian (Jason) Wen [cph] (filled contour code), Paul Murrell [ctb], Stefan Eng [ctb] (violin plot improvements), Achim Zeileis [ctb] (modern colors), Alexandre Courtiol [ctb] (generics for larrows, lpolygon, lrect and lsegments)", + "Maintainer": "Deepayan Sarkar ", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "lazyeval": { + "Package": "lazyeval", + "Version": "0.2.2", + "Source": "Repository", + "Title": "Lazy (Non-Standard) Evaluation", + "Description": "An alternative approach to non-standard evaluation using formulas. Provides a full implementation of LISP style 'quasiquotation', making it easier to generate code with other code.", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", ,\"hadley@rstudio.com\", c(\"aut\", \"cre\")), person(\"RStudio\", role = \"cph\") )", + "License": "GPL-3", + "LazyData": "true", + "Depends": [ + "R (>= 3.1.0)" + ], + "Suggests": [ + "knitr", + "rmarkdown (>= 0.2.65)", + "testthat", + "covr" + ], + "VignetteBuilder": "knitr", + "RoxygenNote": "6.1.1", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre], RStudio [cph]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "lifecycle": { + "Package": "lifecycle", + "Version": "1.0.4", + "Source": "Repository", + "Title": "Manage the Life Cycle of your Package Functions", + "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Manage the life cycle of your exported functions with shared conventions, documentation badges, and user-friendly deprecation warnings.", + "License": "MIT + file LICENSE", + "URL": "https://lifecycle.r-lib.org/, https://github.com/r-lib/lifecycle", + "BugReports": "https://github.com/r-lib/lifecycle/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli (>= 3.4.0)", + "glue", + "rlang (>= 1.1.0)" + ], + "Suggests": [ + "covr", + "crayon", + "knitr", + "lintr", + "rmarkdown", + "testthat (>= 3.0.1)", + "tibble", + "tidyverse", + "tools", + "vctrs", + "withr" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate, usethis", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.1", + "NeedsCompilation": "no", + "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Lionel Henry ", + "Repository": "RSPM" + }, + "lmom": { + "Package": "lmom", + "Version": "3.2", + "Source": "Repository", + "Date": "2024-09-29", + "Title": "L-Moments", + "Author": "J. R. M. Hosking [aut, cre]", + "Maintainer": "J. R. M. Hosking ", + "Authors@R": "person(given = c(\"J.\", \"R.\", \"M.\"), family = \"Hosking\", role = c(\"aut\", \"cre\"), email = \"jrmhosking@gmail.com\")", + "Description": "Functions related to L-moments: computation of L-moments and trimmed L-moments of distributions and data samples; parameter estimation; L-moment ratio diagram; plot vs. quantiles of an extreme-value distribution.", + "Depends": [ + "R (>= 3.0.0)" + ], + "Imports": [ + "stats", + "graphics" + ], + "License": "Common Public License Version 1.0", + "NeedsCompilation": "yes", + "Repository": "CRAN" + }, + "logger": { + "Package": "logger", + "Version": "0.4.0", + "Source": "Repository", + "Type": "Package", + "Title": "A Lightweight, Modern and Flexible Logging Utility", + "Date": "2024-10-19", + "Authors@R": "c( person(\"Gergely\", \"Daróczi\", , \"daroczig@rapporter.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-3149-8537\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"System1\", role = \"fnd\") )", + "Description": "Inspired by the the 'futile.logger' R package and 'logging' Python module, this utility provides a flexible and extensible way of formatting and delivering log messages with low overhead.", + "License": "MIT + file LICENSE", + "URL": "https://daroczig.github.io/logger/", + "BugReports": "https://github.com/daroczig/logger/issues", + "Depends": [ + "R (>= 4.0.0)" + ], + "Imports": [ + "utils" + ], + "Suggests": [ + "botor", + "covr", + "crayon", + "devtools", + "glue", + "jsonlite", + "knitr", + "mirai (>= 1.3.0)", + "pander", + "parallel", + "R.utils", + "rmarkdown", + "roxygen2", + "RPushbullet", + "rsyslog", + "shiny", + "slackr (>= 1.4.1)", + "syslognet", + "telegram", + "testthat (>= 3.0.0)", + "withr" + ], + "Enhances": [ + "futile.logger", + "log4r", + "logging" + ], + "VignetteBuilder": "knitr", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "TRUE", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Gergely Daróczi [aut, cre] (), Hadley Wickham [aut] (), System1 [fnd]", + "Maintainer": "Gergely Daróczi ", + "Repository": "CRAN" + }, + "magrittr": { + "Package": "magrittr", + "Version": "2.0.3", + "Source": "Repository", + "Type": "Package", + "Title": "A Forward-Pipe Operator for R", + "Authors@R": "c( person(\"Stefan Milton\", \"Bache\", , \"stefan@stefanbache.dk\", role = c(\"aut\", \"cph\"), comment = \"Original author and creator of magrittr\"), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", role = \"cre\"), person(\"RStudio\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides a mechanism for chaining commands with a new forward-pipe operator, %>%. This operator will forward a value, or the result of an expression, into the next function call/expression. There is flexible support for the type of right-hand side expressions. For more information, see package vignette. To quote Rene Magritte, \"Ceci n'est pas un pipe.\"", + "License": "MIT + file LICENSE", + "URL": "https://magrittr.tidyverse.org, https://github.com/tidyverse/magrittr", + "BugReports": "https://github.com/tidyverse/magrittr/issues", + "Depends": [ + "R (>= 3.4.0)" + ], + "Suggests": [ + "covr", + "knitr", + "rlang", + "rmarkdown", + "testthat" + ], + "VignetteBuilder": "knitr", + "ByteCompile": "Yes", + "Config/Needs/website": "tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.1.2", + "NeedsCompilation": "yes", + "Author": "Stefan Milton Bache [aut, cph] (Original author and creator of magrittr), Hadley Wickham [aut], Lionel Henry [cre], RStudio [cph, fnd]", + "Maintainer": "Lionel Henry ", + "Repository": "CRAN" + }, + "memoise": { + "Package": "memoise", + "Version": "2.0.1", + "Source": "Repository", + "Title": "'Memoisation' of Functions", + "Authors@R": "c(person(given = \"Hadley\", family = \"Wickham\", role = \"aut\", email = \"hadley@rstudio.com\"), person(given = \"Jim\", family = \"Hester\", role = \"aut\"), person(given = \"Winston\", family = \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@rstudio.com\"), person(given = \"Kirill\", family = \"Müller\", role = \"aut\", email = \"krlmlr+r@mailbox.org\"), person(given = \"Daniel\", family = \"Cook\", role = \"aut\", email = \"danielecook@gmail.com\"), person(given = \"Mark\", family = \"Edmondson\", role = \"ctb\", email = \"r@sunholo.com\"))", + "Description": "Cache the results of a function so that when you call it again with the same arguments it returns the previously computed value.", + "License": "MIT + file LICENSE", + "URL": "https://memoise.r-lib.org, https://github.com/r-lib/memoise", + "BugReports": "https://github.com/r-lib/memoise/issues", + "Imports": [ + "rlang (>= 0.4.10)", + "cachem" + ], + "Suggests": [ + "digest", + "aws.s3", + "covr", + "googleAuthR", + "googleCloudStorageR", + "httr", + "testthat" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.1.2", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut], Jim Hester [aut], Winston Chang [aut, cre], Kirill Müller [aut], Daniel Cook [aut], Mark Edmondson [ctb]", + "Maintainer": "Winston Chang ", + "Repository": "RSPM" + }, + "mgcv": { + "Package": "mgcv", + "Version": "1.9-1", + "Source": "Repository", + "Author": "Simon Wood ", + "Maintainer": "Simon Wood ", + "Title": "Mixed GAM Computation Vehicle with Automatic Smoothness Estimation", + "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Generalized Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2017) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", + "Priority": "recommended", + "Depends": [ + "R (>= 3.6.0)", + "nlme (>= 3.1-64)" + ], + "Imports": [ + "methods", + "stats", + "graphics", + "Matrix", + "splines", + "utils" + ], + "Suggests": [ + "parallel", + "survival", + "MASS" + ], + "LazyLoad": "yes", + "ByteCompile": "yes", + "License": "GPL (>= 2)", + "NeedsCompilation": "yes", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "mime": { + "Package": "mime", + "Version": "0.12", + "Source": "Repository", + "Type": "Package", + "Title": "Map Filenames to MIME Types", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Jeffrey\", \"Horner\", role = \"ctb\"), person(\"Beilei\", \"Bian\", role = \"ctb\") )", + "Description": "Guesses the MIME type from a filename extension using the data derived from /etc/mime.types in UNIX-type systems.", + "Imports": [ + "tools" + ], + "License": "GPL", + "URL": "https://github.com/yihui/mime", + "BugReports": "https://github.com/yihui/mime/issues", + "RoxygenNote": "7.1.1", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Yihui Xie [aut, cre] (), Jeffrey Horner [ctb], Beilei Bian [ctb]", + "Maintainer": "Yihui Xie ", + "Repository": "RSPM" + }, + "munsell": { + "Package": "munsell", + "Version": "0.5.1", + "Source": "Repository", + "Type": "Package", + "Title": "Utilities for Using Munsell Colours", + "Author": "Charlotte Wickham ", + "Maintainer": "Charlotte Wickham ", + "Description": "Provides easy access to, and manipulation of, the Munsell colours. Provides a mapping between Munsell's original notation (e.g. \"5R 5/10\") and hexadecimal strings suitable for use directly in R graphics. Also provides utilities to explore slices through the Munsell colour tree, to transform Munsell colours and display colour palettes.", + "Suggests": [ + "ggplot2", + "testthat" + ], + "Imports": [ + "colorspace", + "methods" + ], + "License": "MIT + file LICENSE", + "URL": "https://cran.r-project.org/package=munsell, https://github.com/cwickham/munsell/", + "RoxygenNote": "7.3.1", + "Encoding": "UTF-8", + "BugReports": "https://github.com/cwickham/munsell/issues", + "NeedsCompilation": "no", + "Repository": "RSPM" + }, + "mvtnorm": { + "Package": "mvtnorm", + "Version": "1.3-3", + "Source": "Repository", + "Title": "Multivariate Normal and t Distributions", + "Date": "2025-01-09", + "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", + "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", + "Imports": [ + "stats" + ], + "Depends": [ + "R(>= 3.5.0)" + ], + "Suggests": [ + "qrng", + "numDeriv" + ], + "License": "GPL-2", + "URL": "http://mvtnorm.R-forge.R-project.org", + "NeedsCompilation": "yes", + "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", + "Maintainer": "Torsten Hothorn ", + "Repository": "CRAN" + }, + "nlme": { + "Package": "nlme", + "Version": "3.1-167", + "Source": "Repository", + "Date": "2025-01-27", + "Priority": "recommended", + "Title": "Linear and Nonlinear Mixed Effects Models", + "Authors@R": "c(person(\"José\", \"Pinheiro\", role = \"aut\", comment = \"S version\"), person(\"Douglas\", \"Bates\", role = \"aut\", comment = \"up to 2007\"), person(\"Saikat\", \"DebRoy\", role = \"ctb\", comment = \"up to 2002\"), person(\"Deepayan\", \"Sarkar\", role = \"ctb\", comment = \"up to 2005\"), person(\"EISPACK authors\", role = \"ctb\", comment = \"src/rs.f\"), person(\"Siem\", \"Heisterkamp\", role = \"ctb\", comment = \"Author fixed sigma\"), person(\"Bert\", \"Van Willigen\",role = \"ctb\", comment = \"Programmer fixed sigma\"), person(\"Johannes\", \"Ranke\", role = \"ctb\", comment = \"varConstProp()\"), person(\"R Core Team\", email = \"R-core@R-project.org\", role = c(\"aut\", \"cre\"), comment = c(ROR = \"02zz1nj61\")))", + "Contact": "see 'MailingList'", + "Description": "Fit and compare Gaussian linear and nonlinear mixed-effects models.", + "Depends": [ + "R (>= 3.6.0)" + ], + "Imports": [ + "graphics", + "stats", + "utils", + "lattice" + ], + "Suggests": [ + "MASS", + "SASmixed" + ], + "LazyData": "yes", + "Encoding": "UTF-8", + "License": "GPL (>= 2)", + "BugReports": "https://bugs.r-project.org", + "MailingList": "R-help@r-project.org", + "URL": "https://svn.r-project.org/R-packages/trunk/nlme/", + "NeedsCompilation": "yes", + "Author": "José Pinheiro [aut] (S version), Douglas Bates [aut] (up to 2007), Saikat DebRoy [ctb] (up to 2002), Deepayan Sarkar [ctb] (up to 2005), EISPACK authors [ctb] (src/rs.f), Siem Heisterkamp [ctb] (Author fixed sigma), Bert Van Willigen [ctb] (Programmer fixed sigma), Johannes Ranke [ctb] (varConstProp()), R Core Team [aut, cre] (02zz1nj61)", + "Maintainer": "R Core Team ", + "Repository": "CRAN" + }, + "officer": { + "Package": "officer", + "Version": "0.6.7", + "Source": "Repository", + "Type": "Package", + "Title": "Manipulation of Microsoft Word and PowerPoint Documents", + "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"Stefan\", \"Moog\", , \"moogs@gmx.de\", role = \"aut\"), person(\"Mark\", \"Heckmann\", , \"heckmann.mark@gmail.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-0736-7417\")), person(\"ArData\", role = \"cph\"), person(\"Frank\", \"Hangler\", , \"frank@plotandscatter.com\", role = \"ctb\", comment = \"function body_replace_all_text\"), person(\"Liz\", \"Sander\", , \"lsander@civisanalytics.com\", role = \"ctb\", comment = \"several documentation fixes\"), person(\"Anton\", \"Victorson\", , \"anton@victorson.se\", role = \"ctb\", comment = \"fixes xml structures\"), person(\"Jon\", \"Calder\", , \"jonmcalder@gmail.com\", role = \"ctb\", comment = \"update vignettes\"), person(\"John\", \"Harrold\", , \"john.m.harrold@gmail.com\", role = \"ctb\", comment = \"function annotate_base\"), person(\"John\", \"Muschelli\", , \"muschellij2@gmail.com\", role = \"ctb\", comment = \"google doc compatibility\"), person(\"Bill\", \"Denney\", , \"wdenney@humanpredictions.com\", role = \"ctb\", comment = c(ORCID = \"0000-0002-5759-428X\", \"function as.matrix.rpptx\")), person(\"Nikolai\", \"Beck\", , \"beck.nikolai@gmail.com\", role = \"ctb\", comment = \"set speaker notes for .pptx documents\"), person(\"Greg\", \"Leleu\", , \"gregoire.leleu@gmail.com\", role = \"ctb\", comment = \"fields functionality in ppt\"), person(\"Majid\", \"Eismann\", role = \"ctb\"), person(\"Hongyuan\", \"Jia\", , \"hongyuanjia@cqust.edu.cn\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0075-8183\")) )", + "Description": "Access and manipulate 'Microsoft Word', 'RTF' and 'Microsoft PowerPoint' documents from R. The package focuses on tabular and graphical reporting from R; it also provides two functions that let users get document content into data objects. A set of functions lets add and remove images, tables and paragraphs of text in new or existing documents. The package does not require any installation of Microsoft products to be able to write Microsoft files.", + "License": "MIT + file LICENSE", + "URL": "https://ardata-fr.github.io/officeverse/, https://davidgohel.github.io/officer/", + "BugReports": "https://github.com/davidgohel/officer/issues", + "Imports": [ + "cli", + "graphics", + "grDevices", + "openssl", + "R6", + "ragg", + "stats", + "utils", + "uuid", + "xml2 (>= 1.1.0)", + "zip (>= 2.1.0)" + ], + "Suggests": [ + "devEMF", + "doconv (>= 0.3.0)", + "ggplot2", + "knitr", + "magick", + "rmarkdown", + "rsvg", + "testthat" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "David Gohel [aut, cre], Stefan Moog [aut], Mark Heckmann [aut] (), ArData [cph], Frank Hangler [ctb] (function body_replace_all_text), Liz Sander [ctb] (several documentation fixes), Anton Victorson [ctb] (fixes xml structures), Jon Calder [ctb] (update vignettes), John Harrold [ctb] (function annotate_base), John Muschelli [ctb] (google doc compatibility), Bill Denney [ctb] (, function as.matrix.rpptx), Nikolai Beck [ctb] (set speaker notes for .pptx documents), Greg Leleu [ctb] (fields functionality in ppt), Majid Eismann [ctb], Hongyuan Jia [ctb] ()", + "Maintainer": "David Gohel ", + "Repository": "CRAN" + }, + "openssl": { + "Package": "openssl", + "Version": "2.3.2", + "Source": "Repository", + "Type": "Package", + "Title": "Toolkit for Encryption, Signatures and Certificates Based on OpenSSL", + "Authors@R": "c(person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Oliver\", \"Keyes\", role = \"ctb\"))", + "Description": "Bindings to OpenSSL libssl and libcrypto, plus custom SSH key parsers. Supports RSA, DSA and EC curves P-256, P-384, P-521, and curve25519. Cryptographic signatures can either be created and verified manually or via x509 certificates. AES can be used in cbc, ctr or gcm mode for symmetric encryption; RSA for asymmetric (public key) encryption or EC for Diffie Hellman. High-level envelope functions combine RSA and AES for encrypting arbitrary sized data. Other utilities include key generators, hash functions (md5, sha1, sha256, etc), base64 encoder, a secure random number generator, and 'bignum' math methods for manually performing crypto calculations on large multibyte integers.", + "License": "MIT + file LICENSE", + "URL": "https://jeroen.r-universe.dev/openssl", + "BugReports": "https://github.com/jeroen/openssl/issues", + "SystemRequirements": "OpenSSL >= 1.0.2", + "VignetteBuilder": "knitr", + "Imports": [ + "askpass" + ], + "Suggests": [ + "curl", + "testthat (>= 2.1.0)", + "digest", + "knitr", + "rmarkdown", + "jsonlite", + "jose", + "sodium" + ], + "RoxygenNote": "7.3.2", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] (), Oliver Keyes [ctb]", + "Maintainer": "Jeroen Ooms ", + "Repository": "CRAN" + }, + "osprey": { + "Package": "osprey", + "Version": "0.1.16.9018", + "Source": "Repository", + "Type": "Package", + "Title": "R Package to Create TLGs", + "Date": "2025-01-31", + "Authors@R": "c( person(\"Nina\", \"Qi\", , \"qit3@gene.com\", role = c(\"aut\", \"cre\")), person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"aut\"), person(\"Liming\", \"Li\", , \"liming.li@roche.com\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")), person(\"Molly\", \"He\", role = \"ctb\"), person(\"Carolyn\", \"Zhang\", role = \"ctb\"), person(\"Tina\", \"Cho\", role = \"ctb\") )", + "Description": "Community effort to collect TLG code and create a catalogue.", + "License": "Apache License 2.0 | file LICENSE", + "URL": "https://insightsengineering.github.io/osprey/, https://github.com/insightsengineering/osprey/", + "BugReports": "https://github.com/insightsengineering/osprey/issues", + "Depends": [ + "dplyr (>= 0.8.0)", + "ggplot2 (>= 3.5.0)", + "R (>= 3.6)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "cowplot", + "DescTools (>= 0.99.53)", + "grDevices", + "grid", + "gridExtra", + "gtable (>= 0.3.4)", + "methods", + "rlang (>= 1.1.0)", + "stats", + "stringr (>= 1.4.1)", + "tibble (>= 2.0.0)", + "tidyr (>= 1.0.0)" + ], + "Suggests": [ + "knitr (>= 1.42)", + "nestcolor (>= 0.1.0)", + "rmarkdown (>= 2.23)", + "tern (>= 0.7.10)", + "testthat (>= 2.0)" + ], + "Config/Needs/verdepcheck": "tidyverse/dplyr, tidyverse/ggplot2, mllg/checkmate, wilkelab/cowplot, AndriSignorell/DescTools, baptiste/gridExtra, r-lib/gtable, r-lib/rlang, tidyverse/stringr, tidyverse/tibble, tidyverse/tidyr, yihui/knitr, insightsengineering/nestcolor, rstudio/rmarkdown, insightsengineering/tern, r-lib/testthat", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "LazyData": "true", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Config/pak/sysreqs": "make libicu-dev libssl-dev libx11-dev zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/osprey", + "RemoteRef": "HEAD", + "RemoteSha": "eff27e6d997cf23a13d9c3e7d0134d88afebff45", + "NeedsCompilation": "no", + "Author": "Nina Qi [aut, cre], Dawid Kaledkowski [aut], Chendi Liao [aut], Liming Li [aut], F. Hoffmann-La Roche AG [cph, fnd], Molly He [ctb], Carolyn Zhang [ctb], Tina Cho [ctb]", + "Maintainer": "Nina Qi " + }, + "pillar": { + "Package": "pillar", + "Version": "1.10.1", + "Source": "Repository", + "Title": "Coloured Formatting for Columns", + "Authors@R": "c(person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Hadley\", family = \"Wickham\", role = \"aut\"), person(given = \"RStudio\", role = \"cph\"))", + "Description": "Provides 'pillar' and 'colonnade' generics designed for formatting columns of data using the full range of colours provided by modern terminals.", + "License": "MIT + file LICENSE", + "URL": "https://pillar.r-lib.org/, https://github.com/r-lib/pillar", + "BugReports": "https://github.com/r-lib/pillar/issues", + "Imports": [ + "cli (>= 2.3.0)", + "glue", + "lifecycle", + "rlang (>= 1.0.2)", + "utf8 (>= 1.1.0)", + "utils", + "vctrs (>= 0.5.0)" + ], + "Suggests": [ + "bit64", + "DBI", + "debugme", + "DiagrammeR", + "dplyr", + "formattable", + "ggplot2", + "knitr", + "lubridate", + "nanotime", + "nycflights13", + "palmerpenguins", + "rmarkdown", + "scales", + "stringi", + "survival", + "testthat (>= 3.1.1)", + "tibble", + "units (>= 0.7.2)", + "vdiffr", + "withr" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2.9000", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Config/testthat/start-first": "format_multi_fuzz, format_multi_fuzz_2, format_multi, ctl_colonnade, ctl_colonnade_1, ctl_colonnade_2", + "Config/autostyle/scope": "line_breaks", + "Config/autostyle/strict": "true", + "Config/gha/extra-packages": "DiagrammeR=?ignore-before-r=3.5.0", + "Config/Needs/website": "tidyverse/tidytemplate", + "NeedsCompilation": "no", + "Author": "Kirill Müller [aut, cre] (), Hadley Wickham [aut], RStudio [cph]", + "Maintainer": "Kirill Müller ", + "Repository": "CRAN" + }, + "pkgbuild": { + "Package": "pkgbuild", + "Version": "1.4.6", + "Source": "Repository", + "Title": "Find Tools Needed to Build R Packages", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides functions used to build R packages. Locates compilers needed to build R packages on various platforms and ensures the PATH is configured appropriately so R can use them.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/pkgbuild, https://pkgbuild.r-lib.org", + "BugReports": "https://github.com/r-lib/pkgbuild/issues", + "Depends": [ + "R (>= 3.5)" + ], + "Imports": [ + "callr (>= 3.2.0)", + "cli (>= 3.4.0)", + "desc", + "processx", + "R6" + ], + "Suggests": [ + "covr", + "cpp11", + "knitr", + "Rcpp", + "rmarkdown", + "testthat (>= 3.2.0)", + "withr (>= 2.3.0)" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut], Jim Hester [aut], Gábor Csárdi [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + }, + "pkgconfig": { + "Package": "pkgconfig", + "Version": "2.0.3", + "Source": "Repository", + "Title": "Private Configuration for 'R' Packages", + "Author": "Gábor Csárdi", + "Maintainer": "Gábor Csárdi ", + "Description": "Set configuration options on a per-package basis. Options set by a given package only apply to that package, other packages are unaffected.", + "License": "MIT + file LICENSE", + "LazyData": "true", + "Imports": [ + "utils" + ], + "Suggests": [ + "covr", + "testthat", + "disposables (>= 1.0.3)" + ], + "URL": "https://github.com/r-lib/pkgconfig#readme", + "BugReports": "https://github.com/r-lib/pkgconfig/issues", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Repository": "RSPM" + }, + "pkgload": { + "Package": "pkgload", + "Version": "1.4.0", + "Source": "Repository", + "Title": "Simulate Package Installation and Attach", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"R Core team\", role = \"ctb\", comment = \"Some namespace and vignette code extracted from base R\") )", + "Description": "Simulates the process of installing a package and then attaching it. This is a key part of the 'devtools' package as it allows you to rapidly iterate while developing a package.", + "License": "GPL-3", + "URL": "https://github.com/r-lib/pkgload, https://pkgload.r-lib.org", + "BugReports": "https://github.com/r-lib/pkgload/issues", + "Depends": [ + "R (>= 3.4.0)" + ], + "Imports": [ + "cli (>= 3.3.0)", + "desc", + "fs", + "glue", + "lifecycle", + "methods", + "pkgbuild", + "processx", + "rlang (>= 1.1.1)", + "rprojroot", + "utils", + "withr (>= 2.4.3)" + ], + "Suggests": [ + "bitops", + "jsonlite", + "mathjaxr", + "pak", + "Rcpp", + "remotes", + "rstudioapi", + "testthat (>= 3.2.1.1)", + "usethis" + ], + "Config/Needs/website": "tidyverse/tidytemplate, ggplot2", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "TRUE", + "Config/testthat/start-first": "dll", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut], Winston Chang [aut], Jim Hester [aut], Lionel Henry [aut, cre], Posit Software, PBC [cph, fnd], R Core team [ctb] (Some namespace and vignette code extracted from base R)", + "Maintainer": "Lionel Henry ", + "Repository": "RSPM" + }, + "plotly": { + "Package": "plotly", + "Version": "4.10.4", + "Source": "Repository", + "Title": "Create Interactive Web Graphics via 'plotly.js'", + "Authors@R": "c(person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"cpsievert1@gmail.com\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Chris\", \"Parmer\", role = \"aut\", email = \"chris@plot.ly\"), person(\"Toby\", \"Hocking\", role = \"aut\", email = \"tdhock5@gmail.com\"), person(\"Scott\", \"Chamberlain\", role = \"aut\", email = \"myrmecocystus@gmail.com\"), person(\"Karthik\", \"Ram\", role = \"aut\", email = \"karthik.ram@gmail.com\"), person(\"Marianne\", \"Corvellec\", role = \"aut\", email = \"marianne.corvellec@igdore.org\", comment = c(ORCID = \"0000-0002-1994-3581\")), person(\"Pedro\", \"Despouy\", role = \"aut\", email = \"pedro@plot.ly\"), person(\"Salim\", \"Brüggemann\", role = \"ctb\", email = \"salim-b@pm.me\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Plotly Technologies Inc.\", role = \"cph\"))", + "License": "MIT + file LICENSE", + "Description": "Create interactive web graphics from 'ggplot2' graphs and/or a custom interface to the (MIT-licensed) JavaScript library 'plotly.js' inspired by the grammar of graphics.", + "URL": "https://plotly-r.com, https://github.com/plotly/plotly.R, https://plotly.com/r/", + "BugReports": "https://github.com/plotly/plotly.R/issues", + "Depends": [ + "R (>= 3.2.0)", + "ggplot2 (>= 3.0.0)" + ], + "Imports": [ + "tools", + "scales", + "httr (>= 1.3.0)", + "jsonlite (>= 1.6)", + "magrittr", + "digest", + "viridisLite", + "base64enc", + "htmltools (>= 0.3.6)", + "htmlwidgets (>= 1.5.2.9001)", + "tidyr (>= 1.0.0)", + "RColorBrewer", + "dplyr", + "vctrs", + "tibble", + "lazyeval (>= 0.2.0)", + "rlang (>= 0.4.10)", + "crosstalk", + "purrr", + "data.table", + "promises" + ], + "Suggests": [ + "MASS", + "maps", + "hexbin", + "ggthemes", + "GGally", + "ggalluvial", + "testthat", + "knitr", + "shiny (>= 1.1.0)", + "shinytest (>= 1.3.0)", + "curl", + "rmarkdown", + "Cairo", + "broom", + "webshot", + "listviewer", + "dendextend", + "sf", + "png", + "IRdisplay", + "processx", + "plotlyGeoAssets", + "forcats", + "withr", + "palmerpenguins", + "rversions", + "reticulate", + "rsvg" + ], + "LazyData": "true", + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "Config/Needs/check": "tidyverse/ggplot2, rcmdcheck, devtools, reshape2", + "NeedsCompilation": "no", + "Author": "Carson Sievert [aut, cre] (), Chris Parmer [aut], Toby Hocking [aut], Scott Chamberlain [aut], Karthik Ram [aut], Marianne Corvellec [aut] (), Pedro Despouy [aut], Salim Brüggemann [ctb] (), Plotly Technologies Inc. [cph]", + "Maintainer": "Carson Sievert ", + "Repository": "CRAN" + }, + "prettyunits": { + "Package": "prettyunits", + "Version": "1.2.0", + "Source": "Repository", + "Title": "Pretty, Human Readable Formatting of Quantities", + "Authors@R": "c( person(\"Gabor\", \"Csardi\", email=\"csardi.gabor@gmail.com\", role=c(\"aut\", \"cre\")), person(\"Bill\", \"Denney\", email=\"wdenney@humanpredictions.com\", role=c(\"ctb\"), comment=c(ORCID=\"0000-0002-5759-428X\")), person(\"Christophe\", \"Regouby\", email=\"christophe.regouby@free.fr\", role=c(\"ctb\")) )", + "Description": "Pretty, human readable formatting of quantities. Time intervals: '1337000' -> '15d 11h 23m 20s'. Vague time intervals: '2674000' -> 'about a month ago'. Bytes: '1337' -> '1.34 kB'. Rounding: '99' with 3 significant digits -> '99.0' p-values: '0.00001' -> '<0.0001'. Colors: '#FF0000' -> 'red'. Quantities: '1239437' -> '1.24 M'.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/prettyunits", + "BugReports": "https://github.com/r-lib/prettyunits/issues", + "Depends": [ + "R(>= 2.10)" + ], + "Suggests": [ + "codetools", + "covr", + "testthat" + ], + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Gabor Csardi [aut, cre], Bill Denney [ctb] (), Christophe Regouby [ctb]", + "Maintainer": "Gabor Csardi ", + "Repository": "RSPM" + }, + "processx": { + "Package": "processx", + "Version": "3.8.5", + "Source": "Repository", + "Title": "Execute and Control System Processes", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\", \"cph\"), comment = c(ORCID = \"0000-0001-7098-9676\")), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Ascent Digital Services\", role = c(\"cph\", \"fnd\")) )", + "Description": "Tools to run system processes in the background. It can check if a background process is running; wait on a background process to finish; get the exit status of finished processes; kill background processes. It can read the standard output and error of the processes, using non-blocking connections. 'processx' can poll a process for standard output or error, with a timeout. It can also poll several processes at once.", + "License": "MIT + file LICENSE", + "URL": "https://processx.r-lib.org, https://github.com/r-lib/processx", + "BugReports": "https://github.com/r-lib/processx/issues", + "Depends": [ + "R (>= 3.4.0)" + ], + "Imports": [ + "ps (>= 1.2.0)", + "R6", + "utils" + ], + "Suggests": [ + "callr (>= 3.7.3)", + "cli (>= 3.3.0)", + "codetools", + "covr", + "curl", + "debugme", + "parallel", + "rlang (>= 1.0.2)", + "testthat (>= 3.0.0)", + "webfakes", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1.9000", + "NeedsCompilation": "yes", + "Author": "Gábor Csárdi [aut, cre, cph] (), Winston Chang [aut], Posit Software, PBC [cph, fnd], Ascent Digital Services [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + }, + "progress": { + "Package": "progress", + "Version": "1.2.3", + "Source": "Repository", + "Title": "Terminal Progress Bars", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Rich\", \"FitzJohn\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Configurable Progress bars, they may include percentage, elapsed time, and/or the estimated completion time. They work in terminals, in 'Emacs' 'ESS', 'RStudio', 'Windows' 'Rgui' and the 'macOS' 'R.app'. The package also provides a 'C++' 'API', that works with or without 'Rcpp'.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/progress#readme, http://r-lib.github.io/progress/", + "BugReports": "https://github.com/r-lib/progress/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "crayon", + "hms", + "prettyunits", + "R6" + ], + "Suggests": [ + "Rcpp", + "testthat (>= 3.0.0)", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Gábor Csárdi [aut, cre], Rich FitzJohn [aut], Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "RSPM" + }, + "promises": { + "Package": "promises", + "Version": "1.3.2", + "Source": "Repository", + "Type": "Package", + "Title": "Abstractions for Promise-Based Asynchronous Programming", + "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides fundamental abstractions for doing asynchronous programming in R using promises. Asynchronous programming is useful for allowing a single R process to orchestrate multiple tasks in the background while also attending to something else. Semantics are similar to 'JavaScript' promises, but with a syntax that is idiomatic R.", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/promises/, https://github.com/rstudio/promises", + "BugReports": "https://github.com/rstudio/promises/issues", + "Imports": [ + "fastmap (>= 1.1.0)", + "later", + "magrittr (>= 1.5)", + "R6", + "Rcpp", + "rlang", + "stats" + ], + "Suggests": [ + "future (>= 1.21.0)", + "knitr", + "purrr", + "rmarkdown", + "spelling", + "testthat", + "vembedr" + ], + "LinkingTo": [ + "later", + "Rcpp" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "rsconnect", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Joe Cheng [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Joe Cheng ", + "Repository": "CRAN" + }, + "proxy": { + "Package": "proxy", + "Version": "0.4-27", + "Source": "Repository", + "Type": "Package", + "Title": "Distance and Similarity Measures", + "Authors@R": "c(person(given = \"David\", family = \"Meyer\", role = c(\"aut\", \"cre\"), email = \"David.Meyer@R-project.org\"), person(given = \"Christian\", family = \"Buchta\", role = \"aut\"))", + "Description": "Provides an extensible framework for the efficient calculation of auto- and cross-proximities, along with implementations of the most popular ones.", + "Depends": [ + "R (>= 3.4.0)" + ], + "Imports": [ + "stats", + "utils" + ], + "Suggests": [ + "cba" + ], + "Collate": "registry.R database.R dist.R similarities.R dissimilarities.R util.R seal.R", + "License": "GPL-2", + "NeedsCompilation": "yes", + "Author": "David Meyer [aut, cre], Christian Buchta [aut]", + "Maintainer": "David Meyer ", + "Repository": "CRAN" + }, + "ps": { + "Package": "ps", + "Version": "1.8.1", + "Source": "Repository", + "Title": "List, Query, Manipulate System Processes", + "Authors@R": "c( person(\"Jay\", \"Loden\", role = \"aut\"), person(\"Dave\", \"Daeschler\", role = \"aut\"), person(\"Giampaolo\", \"Rodola'\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "List, query and manipulate all system processes, on 'Windows', 'Linux' and 'macOS'.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/ps, https://ps.r-lib.org/", + "BugReports": "https://github.com/r-lib/ps/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "utils" + ], + "Suggests": [ + "callr", + "covr", + "curl", + "pillar", + "pingr", + "processx (>= 3.1.0)", + "R6", + "rlang", + "testthat (>= 3.0.0)", + "webfakes", + "withr" + ], + "Biarch": "true", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Jay Loden [aut], Dave Daeschler [aut], Giampaolo Rodola' [aut], Gábor Csárdi [aut, cre], Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + }, + "purrr": { + "Package": "purrr", + "Version": "1.0.4", + "Source": "Repository", + "Title": "Functional Programming Tools", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", + "Description": "A complete and consistent functional programming toolkit for R.", + "License": "MIT + file LICENSE", + "URL": "https://purrr.tidyverse.org/, https://github.com/tidyverse/purrr", + "BugReports": "https://github.com/tidyverse/purrr/issues", + "Depends": [ + "R (>= 4.0)" + ], + "Imports": [ + "cli (>= 3.6.1)", + "lifecycle (>= 1.0.3)", + "magrittr (>= 1.5.0)", + "rlang (>= 1.1.1)", + "vctrs (>= 0.6.3)" + ], + "Suggests": [ + "covr", + "dplyr (>= 0.7.8)", + "httr", + "knitr", + "lubridate", + "rmarkdown", + "testthat (>= 3.0.0)", + "tibble", + "tidyselect" + ], + "LinkingTo": [ + "cli" + ], + "VignetteBuilder": "knitr", + "Biarch": "true", + "Config/build/compilation-database": "true", + "Config/Needs/website": "tidyverse/tidytemplate, tidyr", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "TRUE", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre] (), Lionel Henry [aut], Posit Software, PBC [cph, fnd] (03wc8by49)", + "Maintainer": "Hadley Wickham ", + "Repository": "CRAN" + }, + "ragg": { + "Package": "ragg", + "Version": "1.3.3", + "Source": "Repository", + "Type": "Package", + "Title": "Graphic Devices Based on AGG", + "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Maxim\", \"Shemanarev\", role = c(\"aut\", \"cph\"), comment = \"Author of AGG\"), person(\"Tony\", \"Juricic\", , \"tonygeek@yahoo.com\", role = c(\"ctb\", \"cph\"), comment = \"Contributor to AGG\"), person(\"Milan\", \"Marusinec\", , \"milan@marusinec.sk\", role = c(\"ctb\", \"cph\"), comment = \"Contributor to AGG\"), person(\"Spencer\", \"Garrett\", role = \"ctb\", comment = \"Contributor to AGG\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Maintainer": "Thomas Lin Pedersen ", + "Description": "Anti-Grain Geometry (AGG) is a high-quality and high-performance 2D drawing library. The 'ragg' package provides a set of graphic devices based on AGG to use as alternative to the raster devices provided through the 'grDevices' package.", + "License": "MIT + file LICENSE", + "URL": "https://ragg.r-lib.org, https://github.com/r-lib/ragg", + "BugReports": "https://github.com/r-lib/ragg/issues", + "Imports": [ + "systemfonts (>= 1.0.3)", + "textshaping (>= 0.3.0)" + ], + "Suggests": [ + "covr", + "graphics", + "grid", + "testthat (>= 3.0.0)" + ], + "LinkingTo": [ + "systemfonts", + "textshaping" + ], + "Config/Needs/website": "ggplot2, devoid, magick, bench, tidyr, ggridges, hexbin, sessioninfo, pkgdown, tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "SystemRequirements": "freetype2, libpng, libtiff, libjpeg", + "Config/testthat/edition": "3", + "NeedsCompilation": "yes", + "Author": "Thomas Lin Pedersen [cre, aut] (), Maxim Shemanarev [aut, cph] (Author of AGG), Tony Juricic [ctb, cph] (Contributor to AGG), Milan Marusinec [ctb, cph] (Contributor to AGG), Spencer Garrett [ctb] (Contributor to AGG), Posit, PBC [cph, fnd]", + "Repository": "RSPM" + }, + "rappdirs": { + "Package": "rappdirs", + "Version": "0.3.3", + "Source": "Repository", + "Type": "Package", + "Title": "Application Directories: Determine Where to Save Data, Caches, and Logs", + "Authors@R": "c(person(given = \"Hadley\", family = \"Wickham\", role = c(\"trl\", \"cre\", \"cph\"), email = \"hadley@rstudio.com\"), person(given = \"RStudio\", role = \"cph\"), person(given = \"Sridhar\", family = \"Ratnakumar\", role = \"aut\"), person(given = \"Trent\", family = \"Mick\", role = \"aut\"), person(given = \"ActiveState\", role = \"cph\", comment = \"R/appdir.r, R/cache.r, R/data.r, R/log.r translated from appdirs\"), person(given = \"Eddy\", family = \"Petrisor\", role = \"ctb\"), person(given = \"Trevor\", family = \"Davis\", role = c(\"trl\", \"aut\")), person(given = \"Gabor\", family = \"Csardi\", role = \"ctb\"), person(given = \"Gregory\", family = \"Jefferis\", role = \"ctb\"))", + "Description": "An easy way to determine which directories on the users computer you should use to save data, caches and logs. A port of Python's 'Appdirs' () to R.", + "License": "MIT + file LICENSE", + "URL": "https://rappdirs.r-lib.org, https://github.com/r-lib/rappdirs", + "BugReports": "https://github.com/r-lib/rappdirs/issues", + "Depends": [ + "R (>= 3.2)" + ], + "Suggests": [ + "roxygen2", + "testthat (>= 3.0.0)", + "covr", + "withr" + ], + "Copyright": "Original python appdirs module copyright (c) 2010 ActiveState Software Inc. R port copyright Hadley Wickham, RStudio. See file LICENSE for details.", + "Encoding": "UTF-8", + "RoxygenNote": "7.1.1", + "Config/testthat/edition": "3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [trl, cre, cph], RStudio [cph], Sridhar Ratnakumar [aut], Trent Mick [aut], ActiveState [cph] (R/appdir.r, R/cache.r, R/data.r, R/log.r translated from appdirs), Eddy Petrisor [ctb], Trevor Davis [trl, aut], Gabor Csardi [ctb], Gregory Jefferis [ctb]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "reactR": { + "Package": "reactR", + "Version": "0.6.1", + "Source": "Repository", + "Type": "Package", + "Title": "React Helpers", + "Date": "2024-09-14", + "Authors@R": "c( person( \"Facebook\", \"Inc\" , role = c(\"aut\", \"cph\") , comment = \"React library in lib, https://reactjs.org/; see AUTHORS for full list of contributors\" ), person( \"Michel\",\"Weststrate\", , role = c(\"aut\", \"cph\") , comment = \"mobx library in lib, https://github.com/mobxjs\" ), person( \"Kent\", \"Russell\" , role = c(\"aut\", \"cre\") , comment = \"R interface\" , email = \"kent.russell@timelyportfolio.com\" ), person( \"Alan\", \"Dipert\" , role = c(\"aut\") , comment = \"R interface\" , email = \"alan@rstudio.com\" ), person( \"Greg\", \"Lin\" , role = c(\"aut\") , comment = \"R interface\" , email = \"glin@glin.io\" ) )", + "Maintainer": "Kent Russell ", + "Description": "Make it easy to use 'React' in R with 'htmlwidget' scaffolds, helper dependency functions, an embedded 'Babel' 'transpiler', and examples.", + "URL": "https://github.com/react-R/reactR", + "BugReports": "https://github.com/react-R/reactR/issues", + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "Imports": [ + "htmltools" + ], + "Suggests": [ + "htmlwidgets (>= 1.5.3)", + "rmarkdown", + "shiny", + "V8", + "knitr", + "usethis", + "jsonlite" + ], + "RoxygenNote": "7.3.2", + "VignetteBuilder": "knitr", + "NeedsCompilation": "no", + "Author": "Facebook Inc [aut, cph] (React library in lib, https://reactjs.org/; see AUTHORS for full list of contributors), Michel Weststrate [aut, cph] (mobx library in lib, https://github.com/mobxjs), Kent Russell [aut, cre] (R interface), Alan Dipert [aut] (R interface), Greg Lin [aut] (R interface)", + "Repository": "RSPM" + }, + "reactable": { + "Package": "reactable", + "Version": "0.4.4", + "Source": "Repository", + "Type": "Package", + "Title": "Interactive Data Tables for R", + "Authors@R": "c( person(\"Greg\", \"Lin\", email = \"glin@glin.io\", role = c(\"aut\", \"cre\")), person(\"Tanner\", \"Linsley\", role = c(\"ctb\", \"cph\"), comment = \"React Table library\"), person(family = \"Emotion team and other contributors\", role = c(\"ctb\", \"cph\"), comment = \"Emotion library\"), person(\"Kent\", \"Russell\", role = c(\"ctb\", \"cph\"), comment = \"reactR package\"), person(\"Ramnath\", \"Vaidyanathan\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Joe\", \"Cheng\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"JJ\", \"Allaire\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Yihui\", \"Xie\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Kenton\", \"Russell\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(family = \"Facebook, Inc. and its affiliates\", role = c(\"ctb\", \"cph\"), comment = \"React library\"), person(family = \"FormatJS\", role = c(\"ctb\", \"cph\"), comment = \"FormatJS libraries\"), person(family = \"Feross Aboukhadijeh, and other contributors\", role = c(\"ctb\", \"cph\"), comment = \"buffer library\"), person(\"Roman\", \"Shtylman\", role = c(\"ctb\", \"cph\"), comment = \"process library\"), person(\"James\", \"Halliday\", role = c(\"ctb\", \"cph\"), comment = \"stream-browserify library\"), person(family = \"Posit Software, PBC\", role = c(\"fnd\", \"cph\")) )", + "Description": "Interactive data tables for R, based on the 'React Table' JavaScript library. Provides an HTML widget that can be used in 'R Markdown' or 'Quarto' documents, 'Shiny' applications, or viewed from an R console.", + "License": "MIT + file LICENSE", + "URL": "https://glin.github.io/reactable/, https://github.com/glin/reactable", + "BugReports": "https://github.com/glin/reactable/issues", + "Depends": [ + "R (>= 3.1)" + ], + "Imports": [ + "digest", + "htmltools (>= 0.5.2)", + "htmlwidgets (>= 1.5.3)", + "jsonlite", + "reactR" + ], + "Suggests": [ + "covr", + "crosstalk", + "dplyr", + "fontawesome", + "knitr", + "leaflet", + "MASS", + "rmarkdown", + "shiny", + "sparkline", + "testthat", + "tippy", + "V8" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.2.1", + "Config/testthat/edition": "3", + "NeedsCompilation": "no", + "Author": "Greg Lin [aut, cre], Tanner Linsley [ctb, cph] (React Table library), Emotion team and other contributors [ctb, cph] (Emotion library), Kent Russell [ctb, cph] (reactR package), Ramnath Vaidyanathan [ctb, cph] (htmlwidgets package), Joe Cheng [ctb, cph] (htmlwidgets package), JJ Allaire [ctb, cph] (htmlwidgets package), Yihui Xie [ctb, cph] (htmlwidgets package), Kenton Russell [ctb, cph] (htmlwidgets package), Facebook, Inc. and its affiliates [ctb, cph] (React library), FormatJS [ctb, cph] (FormatJS libraries), Feross Aboukhadijeh, and other contributors [ctb, cph] (buffer library), Roman Shtylman [ctb, cph] (process library), James Halliday [ctb, cph] (stream-browserify library), Posit Software, PBC [fnd, cph]", + "Maintainer": "Greg Lin ", + "Repository": "RSPM" + }, + "readr": { + "Package": "readr", + "Version": "2.1.5", + "Source": "Repository", + "Title": "Read Rectangular Text Data", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Romain\", \"Francois\", role = \"ctb\"), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Shelby\", \"Bearrows\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"https://github.com/mandreyel/\", role = \"cph\", comment = \"mio library\"), person(\"Jukka\", \"Jylänki\", role = c(\"ctb\", \"cph\"), comment = \"grisu3 implementation\"), person(\"Mikkel\", \"Jørgensen\", role = c(\"ctb\", \"cph\"), comment = \"grisu3 implementation\") )", + "Description": "The goal of 'readr' is to provide a fast and friendly way to read rectangular data (like 'csv', 'tsv', and 'fwf'). It is designed to flexibly parse many types of data found in the wild, while still cleanly failing when data unexpectedly changes.", + "License": "MIT + file LICENSE", + "URL": "https://readr.tidyverse.org, https://github.com/tidyverse/readr", + "BugReports": "https://github.com/tidyverse/readr/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli (>= 3.2.0)", + "clipr", + "crayon", + "hms (>= 0.4.1)", + "lifecycle (>= 0.2.0)", + "methods", + "R6", + "rlang", + "tibble", + "utils", + "vroom (>= 1.6.0)" + ], + "Suggests": [ + "covr", + "curl", + "datasets", + "knitr", + "rmarkdown", + "spelling", + "stringi", + "testthat (>= 3.2.0)", + "tzdb (>= 0.1.1)", + "waldo", + "withr", + "xml2" + ], + "LinkingTo": [ + "cpp11", + "tzdb (>= 0.1.1)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "false", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut], Jim Hester [aut], Romain Francois [ctb], Jennifer Bryan [aut, cre] (), Shelby Bearrows [ctb], Posit Software, PBC [cph, fnd], https://github.com/mandreyel/ [cph] (mio library), Jukka Jylänki [ctb, cph] (grisu3 implementation), Mikkel Jørgensen [ctb, cph] (grisu3 implementation)", + "Maintainer": "Jennifer Bryan ", + "Repository": "RSPM" + }, + "readxl": { + "Package": "readxl", + "Version": "1.4.3", + "Source": "Repository", + "Title": "Read Excel Files", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\"), comment = \"Copyright holder of all R code and all C/C++ code without explicit copyright attribution\"), person(\"Marcin\", \"Kalicinski\", role = c(\"ctb\", \"cph\"), comment = \"Author of included RapidXML code\"), person(\"Komarov Valery\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Christophe Leitienne\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Bob Colbert\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"David Hoerl\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Evan Miller\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\") )", + "Description": "Import excel files into R. Supports '.xls' via the embedded 'libxls' C library and '.xlsx' via the embedded 'RapidXML' C++ library . Works on Windows, Mac and Linux without external dependencies.", + "License": "MIT + file LICENSE", + "URL": "https://readxl.tidyverse.org, https://github.com/tidyverse/readxl", + "BugReports": "https://github.com/tidyverse/readxl/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cellranger", + "tibble (>= 2.0.1)", + "utils" + ], + "Suggests": [ + "covr", + "knitr", + "rmarkdown", + "testthat (>= 3.1.6)", + "withr" + ], + "LinkingTo": [ + "cpp11 (>= 0.4.0)", + "progress" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate, tidyverse", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Note": "libxls v1.6.2 (patched) 45abe77", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut] (), Jennifer Bryan [aut, cre] (), Posit, PBC [cph, fnd] (Copyright holder of all R code and all C/C++ code without explicit copyright attribution), Marcin Kalicinski [ctb, cph] (Author of included RapidXML code), Komarov Valery [ctb, cph] (Author of included libxls code), Christophe Leitienne [ctb, cph] (Author of included libxls code), Bob Colbert [ctb, cph] (Author of included libxls code), David Hoerl [ctb, cph] (Author of included libxls code), Evan Miller [ctb, cph] (Author of included libxls code)", + "Maintainer": "Jennifer Bryan ", + "Repository": "RSPM" + }, + "rematch": { + "Package": "rematch", + "Version": "2.0.0", + "Source": "Repository", + "Title": "Match Regular Expressions with a Nicer 'API'", + "Author": "Gabor Csardi", + "Maintainer": "Gabor Csardi ", + "Description": "A small wrapper on 'regexpr' to extract the matches and captured groups from the match of a regular expression to a character vector.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/gaborcsardi/rematch", + "BugReports": "https://github.com/gaborcsardi/rematch/issues", + "RoxygenNote": "5.0.1.9000", + "Suggests": [ + "covr", + "testthat" + ], + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Repository": "RSPM" + }, + "renv": { + "Package": "renv", + "Version": "1.1.1", + "Source": "Repository", + "Type": "Package", + "Title": "Project Environments", + "Authors@R": "c( person(\"Kevin\", \"Ushey\", role = c(\"aut\", \"cre\"), email = \"kevin@rstudio.com\", comment = c(ORCID = \"0000-0003-2880-7407\")), person(\"Hadley\", \"Wickham\", role = c(\"aut\"), email = \"hadley@rstudio.com\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A dependency management toolkit for R. Using 'renv', you can create and manage project-local R libraries, save the state of these libraries to a 'lockfile', and later restore your library as required. Together, these tools can help make your projects more isolated, portable, and reproducible.", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/renv/, https://github.com/rstudio/renv", + "BugReports": "https://github.com/rstudio/renv/issues", + "Imports": [ + "utils" + ], + "Suggests": [ + "BiocManager", + "cli", + "compiler", + "covr", + "cpp11", + "devtools", + "gitcreds", + "jsonlite", + "jsonvalidate", + "knitr", + "miniUI", + "modules", + "packrat", + "pak", + "R6", + "remotes", + "reticulate", + "rmarkdown", + "rstudioapi", + "shiny", + "testthat", + "uuid", + "waldo", + "yaml", + "webfakes" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Config/testthat/start-first": "bioconductor,python,install,restore,snapshot,retrieve,remotes", + "NeedsCompilation": "no", + "Author": "Kevin Ushey [aut, cre] (), Hadley Wickham [aut] (), Posit Software, PBC [cph, fnd]", + "Maintainer": "Kevin Ushey ", + "Repository": "CRAN" + }, + "rlang": { + "Package": "rlang", + "Version": "1.1.5", + "Source": "Repository", + "Title": "Functions for Base Types and Core R and 'Tidyverse' Features", + "Description": "A toolbox for working with base types, core R features like the condition system, and core 'Tidyverse' features like tidy evaluation.", + "Authors@R": "c( person(\"Lionel\", \"Henry\", ,\"lionel@posit.co\", c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", ,\"hadley@posit.co\", \"aut\"), person(given = \"mikefc\", email = \"mikefc@coolbutuseless.com\", role = \"cph\", comment = \"Hash implementation based on Mike's xxhashlite\"), person(given = \"Yann\", family = \"Collet\", role = \"cph\", comment = \"Author of the embedded xxHash library\"), person(given = \"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "License": "MIT + file LICENSE", + "ByteCompile": "true", + "Biarch": "true", + "Depends": [ + "R (>= 3.5.0)" + ], + "Imports": [ + "utils" + ], + "Suggests": [ + "cli (>= 3.1.0)", + "covr", + "crayon", + "fs", + "glue", + "knitr", + "magrittr", + "methods", + "pillar", + "rmarkdown", + "stats", + "testthat (>= 3.0.0)", + "tibble", + "usethis", + "vctrs (>= 0.2.3)", + "withr" + ], + "Enhances": [ + "winch" + ], + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "URL": "https://rlang.r-lib.org, https://github.com/r-lib/rlang", + "BugReports": "https://github.com/r-lib/rlang/issues", + "Config/testthat/edition": "3", + "Config/Needs/website": "dplyr, tidyverse/tidytemplate", + "NeedsCompilation": "yes", + "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut], mikefc [cph] (Hash implementation based on Mike's xxhashlite), Yann Collet [cph] (Author of the embedded xxHash library), Posit, PBC [cph, fnd]", + "Maintainer": "Lionel Henry ", + "Repository": "CRAN" + }, + "rlistings": { + "Package": "rlistings", + "Version": "0.2.10.9002", + "Source": "Repository", + "Title": "Clinical Trial Style Data Readout Listings", + "Date": "2025-02-06", + "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Listings are often part of the submission of clinical trial data in regulatory settings. We provide a framework for the specific formatting features often used when displaying large datasets in that context.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/rlistings/, https://github.com/insightsengineering/rlistings/", + "BugReports": "https://github.com/insightsengineering/rlistings/issues", + "Depends": [ + "formatters (>= 0.5.10)", + "methods", + "tibble (>= 2.0.0)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "grDevices", + "grid", + "stats", + "utils" + ], + "Suggests": [ + "dplyr (>= 1.0.2)", + "knitr (>= 1.42)", + "lifecycle (>= 0.2.0)", + "rmarkdown (>= 2.23)", + "stringi (>= 1.6)", + "testthat (>= 3.1.5)", + "withr (>= 2.0.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/Needs/verdepcheck": "insightsengineering/formatters, tidyverse/tibble, mllg/checkmate, tidyverse/dplyr, yihui/knitr, r-lib/lifecycle, rstudio/rmarkdown, gagolews/stringi, r-lib/testthat, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Gabriel Becker [aut] (original creator of the package), Adrian Waddell [aut], Joe Zhu [aut, cre] (), Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Joe Zhu ", + "Repository": "RSPM" + }, + "rmarkdown": { + "Package": "rmarkdown", + "Version": "2.29", + "Source": "Repository", + "Type": "Package", + "Title": "Dynamic Documents for R", + "Authors@R": "c( person(\"JJ\", \"Allaire\", , \"jj@posit.co\", role = \"aut\"), person(\"Yihui\", \"Xie\", , \"xie@yihui.name\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Christophe\", \"Dervieux\", , \"cderv@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Jonathan\", \"McPherson\", , \"jonathan@posit.co\", role = \"aut\"), person(\"Javier\", \"Luraschi\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevin@posit.co\", role = \"aut\"), person(\"Aron\", \"Atkins\", , \"aron@posit.co\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"aut\"), person(\"Richard\", \"Iannone\", , \"rich@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Andrew\", \"Dunning\", role = \"ctb\", comment = c(ORCID = \"0000-0003-0464-5036\")), person(\"Atsushi\", \"Yasumoto\", role = c(\"ctb\", \"cph\"), comment = c(ORCID = \"0000-0002-8335-495X\", cph = \"Number sections Lua filter\")), person(\"Barret\", \"Schloerke\", role = \"ctb\"), person(\"Carson\", \"Sievert\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Devon\", \"Ryan\", , \"dpryan79@gmail.com\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8549-0971\")), person(\"Frederik\", \"Aust\", , \"frederik.aust@uni-koeln.de\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4900-788X\")), person(\"Jeff\", \"Allen\", , \"jeff@posit.co\", role = \"ctb\"), person(\"JooYoung\", \"Seo\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4064-6012\")), person(\"Malcolm\", \"Barrett\", role = \"ctb\"), person(\"Rob\", \"Hyndman\", , \"Rob.Hyndman@monash.edu\", role = \"ctb\"), person(\"Romain\", \"Lesur\", role = \"ctb\"), person(\"Roy\", \"Storey\", role = \"ctb\"), person(\"Ruben\", \"Arslan\", , \"ruben.arslan@uni-goettingen.de\", role = \"ctb\"), person(\"Sergio\", \"Oller\", role = \"ctb\"), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(, \"jQuery UI contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery UI library; authors listed in inst/rmd/h/jqueryui/AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Alexander\", \"Farkas\", role = c(\"ctb\", \"cph\"), comment = \"html5shiv library\"), person(\"Scott\", \"Jehl\", role = c(\"ctb\", \"cph\"), comment = \"Respond.js library\"), person(\"Ivan\", \"Sagalaev\", role = c(\"ctb\", \"cph\"), comment = \"highlight.js library\"), person(\"Greg\", \"Franko\", role = c(\"ctb\", \"cph\"), comment = \"tocify library\"), person(\"John\", \"MacFarlane\", role = c(\"ctb\", \"cph\"), comment = \"Pandoc templates\"), person(, \"Google, Inc.\", role = c(\"ctb\", \"cph\"), comment = \"ioslides library\"), person(\"Dave\", \"Raggett\", role = \"ctb\", comment = \"slidy library\"), person(, \"W3C\", role = \"cph\", comment = \"slidy library\"), person(\"Dave\", \"Gandy\", role = c(\"ctb\", \"cph\"), comment = \"Font-Awesome\"), person(\"Ben\", \"Sperry\", role = \"ctb\", comment = \"Ionicons\"), person(, \"Drifty\", role = \"cph\", comment = \"Ionicons\"), person(\"Aidan\", \"Lister\", role = c(\"ctb\", \"cph\"), comment = \"jQuery StickyTabs\"), person(\"Benct Philip\", \"Jonsson\", role = c(\"ctb\", \"cph\"), comment = \"pagebreak Lua filter\"), person(\"Albert\", \"Krewinkel\", role = c(\"ctb\", \"cph\"), comment = \"pagebreak Lua filter\") )", + "Description": "Convert R Markdown documents into a variety of formats.", + "License": "GPL-3", + "URL": "https://github.com/rstudio/rmarkdown, https://pkgs.rstudio.com/rmarkdown/", + "BugReports": "https://github.com/rstudio/rmarkdown/issues", + "Depends": [ + "R (>= 3.0)" + ], + "Imports": [ + "bslib (>= 0.2.5.1)", + "evaluate (>= 0.13)", + "fontawesome (>= 0.5.0)", + "htmltools (>= 0.5.1)", + "jquerylib", + "jsonlite", + "knitr (>= 1.43)", + "methods", + "tinytex (>= 0.31)", + "tools", + "utils", + "xfun (>= 0.36)", + "yaml (>= 2.1.19)" + ], + "Suggests": [ + "digest", + "dygraphs", + "fs", + "rsconnect", + "downlit (>= 0.4.0)", + "katex (>= 1.4.0)", + "sass (>= 0.4.0)", + "shiny (>= 1.6.0)", + "testthat (>= 3.0.3)", + "tibble", + "vctrs", + "cleanrmd", + "withr (>= 2.4.2)", + "xml2" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "rstudio/quillt, pkgdown", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "SystemRequirements": "pandoc (>= 1.14) - http://pandoc.org", + "NeedsCompilation": "no", + "Author": "JJ Allaire [aut], Yihui Xie [aut, cre] (), Christophe Dervieux [aut] (), Jonathan McPherson [aut], Javier Luraschi [aut], Kevin Ushey [aut], Aron Atkins [aut], Hadley Wickham [aut], Joe Cheng [aut], Winston Chang [aut], Richard Iannone [aut] (), Andrew Dunning [ctb] (), Atsushi Yasumoto [ctb, cph] (, Number sections Lua filter), Barret Schloerke [ctb], Carson Sievert [ctb] (), Devon Ryan [ctb] (), Frederik Aust [ctb] (), Jeff Allen [ctb], JooYoung Seo [ctb] (), Malcolm Barrett [ctb], Rob Hyndman [ctb], Romain Lesur [ctb], Roy Storey [ctb], Ruben Arslan [ctb], Sergio Oller [ctb], Posit Software, PBC [cph, fnd], jQuery UI contributors [ctb, cph] (jQuery UI library; authors listed in inst/rmd/h/jqueryui/AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Alexander Farkas [ctb, cph] (html5shiv library), Scott Jehl [ctb, cph] (Respond.js library), Ivan Sagalaev [ctb, cph] (highlight.js library), Greg Franko [ctb, cph] (tocify library), John MacFarlane [ctb, cph] (Pandoc templates), Google, Inc. [ctb, cph] (ioslides library), Dave Raggett [ctb] (slidy library), W3C [cph] (slidy library), Dave Gandy [ctb, cph] (Font-Awesome), Ben Sperry [ctb] (Ionicons), Drifty [cph] (Ionicons), Aidan Lister [ctb, cph] (jQuery StickyTabs), Benct Philip Jonsson [ctb, cph] (pagebreak Lua filter), Albert Krewinkel [ctb, cph] (pagebreak Lua filter)", + "Maintainer": "Yihui Xie ", + "Repository": "CRAN" + }, + "rootSolve": { + "Package": "rootSolve", + "Version": "1.8.2.4", + "Source": "Repository", + "Title": "Nonlinear Root Finding, Equilibrium and Steady-State Analysis of Ordinary Differential Equations", + "Authors@R": "c(person(\"Karline\",\"Soetaert\", role = c(\"aut\", \"cre\"), email = \"karline.soetaert@nioz.nl\"), person(\"Alan C.\",\"Hindmarsh\", role = \"ctb\", comment = \"files lsodes.f, sparse.f\"), person(\"S.C.\",\"Eisenstat\", role = \"ctb\", comment = \"file sparse.f\"), person(\"Cleve\",\"Moler\", role = \"ctb\", comment = \"file dlinpk.f\"), person(\"Jack\",\"Dongarra\", role = \"ctb\", comment = \"file dlinpk.f\"), person(\"Youcef\", \"Saad\", role = \"ctb\", comment = \"file dsparsk.f\"))", + "Maintainer": "Karline Soetaert ", + "Author": "Karline Soetaert [aut, cre], Alan C. Hindmarsh [ctb] (files lsodes.f, sparse.f), S.C. Eisenstat [ctb] (file sparse.f), Cleve Moler [ctb] (file dlinpk.f), Jack Dongarra [ctb] (file dlinpk.f), Youcef Saad [ctb] (file dsparsk.f)", + "Depends": [ + "R (>= 2.01)" + ], + "Imports": [ + "stats", + "graphics", + "grDevices" + ], + "Description": "Routines to find the root of nonlinear functions, and to perform steady-state and equilibrium analysis of ordinary differential equations (ODE). Includes routines that: (1) generate gradient and jacobian matrices (full and banded), (2) find roots of non-linear equations by the 'Newton-Raphson' method, (3) estimate steady-state conditions of a system of (differential) equations in full, banded or sparse form, using the 'Newton-Raphson' method, or by dynamically running, (4) solve the steady-state conditions for uni-and multicomponent 1-D, 2-D, and 3-D partial differential equations, that have been converted to ordinary differential equations by numerical differencing (using the method-of-lines approach). Includes fortran code.", + "License": "GPL (>= 2)", + "NeedsCompilation": "yes", + "Repository": "CRAN" + }, + "rprojroot": { + "Package": "rprojroot", + "Version": "2.0.4", + "Source": "Repository", + "Title": "Finding Files in Project Subdirectories", + "Authors@R": "person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\"))", + "Description": "Robust, reliable and flexible paths to files below a project root. The 'root' of a project is defined as a directory that matches a certain criterion, e.g., it contains a certain regular file.", + "License": "MIT + file LICENSE", + "URL": "https://rprojroot.r-lib.org/, https://github.com/r-lib/rprojroot", + "BugReports": "https://github.com/r-lib/rprojroot/issues", + "Depends": [ + "R (>= 3.0.0)" + ], + "Suggests": [ + "covr", + "knitr", + "lifecycle", + "mockr", + "rlang", + "rmarkdown", + "testthat (>= 3.0.0)", + "withr" + ], + "VignetteBuilder": "knitr", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Kirill Müller [aut, cre] ()", + "Maintainer": "Kirill Müller ", + "Repository": "RSPM" + }, + "rstudioapi": { + "Package": "rstudioapi", + "Version": "0.17.1", + "Source": "Repository", + "Title": "Safely Access the RStudio API", + "Description": "Access the RStudio API (if available) and provide informative error messages when it's not.", + "Authors@R": "c( person(\"Kevin\", \"Ushey\", role = c(\"aut\", \"cre\"), email = \"kevin@rstudio.com\"), person(\"JJ\", \"Allaire\", role = c(\"aut\"), email = \"jj@posit.co\"), person(\"Hadley\", \"Wickham\", role = c(\"aut\"), email = \"hadley@posit.co\"), person(\"Gary\", \"Ritchie\", role = c(\"aut\"), email = \"gary@posit.co\"), person(family = \"RStudio\", role = \"cph\") )", + "Maintainer": "Kevin Ushey ", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/rstudioapi/, https://github.com/rstudio/rstudioapi", + "BugReports": "https://github.com/rstudio/rstudioapi/issues", + "RoxygenNote": "7.3.2", + "Suggests": [ + "testthat", + "knitr", + "rmarkdown", + "clipr", + "covr" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Kevin Ushey [aut, cre], JJ Allaire [aut], Hadley Wickham [aut], Gary Ritchie [aut], RStudio [cph]", + "Repository": "CRAN" + }, + "rtables": { + "Package": "rtables", + "Version": "0.6.11.9004", + "Source": "Repository", + "Title": "Reporting Tables", + "Date": "2025-02-06", + "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"Original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Daniel\", \"Sabanés Bové\", , \"daniel.sabanes_bove@roche.com\", role = \"ctb\"), person(\"Maximilian\", \"Mordig\", , \"maximilian_oliver.mordig@roche.com\", role = \"ctb\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Reporting tables often have structure that goes beyond simple rectangular data. The 'rtables' package provides a framework for declaring complex multi-level tabulations and then applying them to data. This framework models both tabulation and the resulting tables as hierarchical, tree-like objects which support sibling sub-tables, arbitrary splitting or grouping of data in row and column dimensions, cells containing multiple values, and the concept of contextual summary computations. A convenient pipe-able interface is provided for declaring table layouts and the corresponding computations, and then applying them to data.", + "License": "Apache License 2.0 | file LICENSE", + "URL": "https://github.com/insightsengineering/rtables, https://insightsengineering.github.io/rtables/", + "BugReports": "https://github.com/insightsengineering/rtables/issues", + "Depends": [ + "formatters (>= 0.5.10)", + "magrittr (>= 1.5)", + "methods", + "R (>= 2.10)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "htmltools (>= 0.5.4)", + "lifecycle (>= 0.2.0)", + "stats", + "stringi (>= 1.6)" + ], + "Suggests": [ + "broom (>= 1.0.5)", + "car (>= 3.0-13)", + "dplyr (>= 1.0.5)", + "knitr (>= 1.42)", + "r2rtf (>= 0.3.2)", + "rmarkdown (>= 2.23)", + "survival (>= 3.3-1)", + "testthat (>= 3.2.1)", + "tibble (>= 3.2.1)", + "tidyr (>= 1.1.3)", + "withr (>= 2.0.0)", + "xml2 (>= 1.3.5)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/Needs/verdepcheck": "insightsengineering/formatters, tidyverse/magrittr, mllg/checkmate, rstudio/htmltools, gagolews/stringi, tidymodels/broom, cran/car, tidyverse/dplyr, davidgohel/flextable, yihui/knitr, r-lib/lifecycle, davidgohel/officer, Merck/r2rtf, rstudio/rmarkdown, therneau/survival, r-lib/testthat, tidyverse/tibble, tidyverse/tidyr, r-lib/withr, r-lib/xml2", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Collate": "'00tabletrees.R' 'Viewer.R' 'argument_conventions.R' 'as_html.R' 'utils.R' 'colby_constructors.R' 'compare_rtables.R' 'format_rcell.R' 'indent.R' 'make_subset_expr.R' 'custom_split_funs.R' 'default_split_funs.R' 'make_split_fun.R' 'summary.R' 'package.R' 'tree_accessors.R' 'tt_afun_utils.R' 'tt_as_df.R' 'tt_compare_tables.R' 'tt_compatibility.R' 'tt_dotabulation.R' 'tt_paginate.R' 'tt_pos_and_access.R' 'tt_showmethods.R' 'tt_sort.R' 'tt_test_afuns.R' 'tt_toString.R' 'tt_export.R' 'index_footnotes.R' 'tt_from_df.R' 'validate_table_struct.R' 'zzz_constants.R'", + "NeedsCompilation": "no", + "Author": "Gabriel Becker [aut] (Original creator of the package), Adrian Waddell [aut], Daniel Sabanés Bové [ctb], Maximilian Mordig [ctb], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Joe Zhu ", + "Repository": "RSPM" + }, + "rtables.officer": { + "Package": "rtables.officer", + "Version": "0.0.2", + "Source": "Repository", + "Title": "Exporting Tools for 'rtables'", + "Date": "2025-01-14", + "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"ctb\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"aut\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Designed to create and display complex tables with R, the 'rtables' R package allows cells in an 'rtables' object to contain any high-dimensional data structure, which can then be displayed with cell-specific formatting instructions. Additionally, the 'rtables.officer' package supports export formats related to the Microsoft Office software suite, including Microsoft Word ('docx') and Microsoft PowerPoint ('pptx').", + "License": "Apache License 2.0", + "URL": "https://github.com/insightsengineering/rtables.officer, https://insightsengineering.github.io/rtables.officer/", + "BugReports": "https://github.com/insightsengineering/rtables.officer/issues", + "Depends": [ + "formatters (>= 0.5.10)", + "magrittr (>= 1.5)", + "methods", + "R (>= 2.10)", + "rtables (>= 0.6.11)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "flextable (>= 0.9.6)", + "lifecycle (>= 0.2.0)", + "officer (>= 0.6.6)", + "stats", + "stringi (>= 1.6)" + ], + "Suggests": [ + "broom (>= 1.0.5)", + "car (>= 3.0-13)", + "dplyr (>= 1.0.5)", + "knitr (>= 1.42)", + "r2rtf (>= 0.3.2)", + "rmarkdown (>= 2.23)", + "survival (>= 3.3-1)", + "testthat (>= 3.0.4)", + "tibble (>= 3.2.1)", + "tidyr (>= 1.1.3)", + "withr (>= 2.0.0)", + "xml2 (>= 1.1.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/Needs/verdepcheck": "insightsengineering/formatters, insightsengineering/rtables, tidyverse/magrittr, mllg/checkmate, rstudio/htmltools, gagolews/stringi, tidymodels/broom, cran/car, tidyverse/dplyr, davidgohel/flextable, yihui/knitr, r-lib/lifecycle, davidgohel/officer, Merck/r2rtf, rstudio/rmarkdown, therneau/survival, r-lib/testthat, tidyverse/tibble, tidyverse/tidyr, r-lib/withr, r-lib/xml2", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.3.2", + "Collate": "'package.R' 'export_as_docx.R' 'as_flextable.R'", + "NeedsCompilation": "no", + "Author": "Gabriel Becker [ctb], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [aut], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Joe Zhu ", + "Repository": "CRAN" + }, + "sass": { + "Package": "sass", + "Version": "0.4.9", + "Source": "Repository", + "Type": "Package", + "Title": "Syntactically Awesome Style Sheets ('Sass')", + "Description": "An 'SCSS' compiler, powered by the 'LibSass' library. With this, R developers can use variables, inheritance, and functions to generate dynamic style sheets. The package uses the 'Sass CSS' extension language, which is stable, powerful, and CSS compatible.", + "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@rstudio.com\", \"aut\"), person(\"Timothy\", \"Mastny\", , \"tim.mastny@gmail.com\", \"aut\"), person(\"Richard\", \"Iannone\", , \"rich@rstudio.com\", \"aut\", comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Barret\", \"Schloerke\", , \"barret@rstudio.com\", \"aut\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Carson\", \"Sievert\", , \"carson@rstudio.com\", c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Christophe\", \"Dervieux\", , \"cderv@rstudio.com\", c(\"ctb\"), comment = c(ORCID = \"0000-0003-4474-2498\")), person(family = \"RStudio\", role = c(\"cph\", \"fnd\")), person(family = \"Sass Open Source Foundation\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Greter\", \"Marcel\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Mifsud\", \"Michael\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Hampton\", \"Catlin\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Natalie\", \"Weizenbaum\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Chris\", \"Eppstein\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Adams\", \"Joseph\", role = c(\"ctb\", \"cph\"), comment = \"json.cpp\"), person(\"Trifunovic\", \"Nemanja\", role = c(\"ctb\", \"cph\"), comment = \"utf8.h\") )", + "License": "MIT + file LICENSE", + "URL": "https://rstudio.github.io/sass/, https://github.com/rstudio/sass", + "BugReports": "https://github.com/rstudio/sass/issues", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "SystemRequirements": "GNU make", + "Imports": [ + "fs (>= 1.2.4)", + "rlang (>= 0.4.10)", + "htmltools (>= 0.5.1)", + "R6", + "rappdirs" + ], + "Suggests": [ + "testthat", + "knitr", + "rmarkdown", + "withr", + "shiny", + "curl" + ], + "VignetteBuilder": "knitr", + "Config/testthat/edition": "3", + "NeedsCompilation": "yes", + "Author": "Joe Cheng [aut], Timothy Mastny [aut], Richard Iannone [aut] (), Barret Schloerke [aut] (), Carson Sievert [aut, cre] (), Christophe Dervieux [ctb] (), RStudio [cph, fnd], Sass Open Source Foundation [ctb, cph] (LibSass library), Greter Marcel [ctb, cph] (LibSass library), Mifsud Michael [ctb, cph] (LibSass library), Hampton Catlin [ctb, cph] (LibSass library), Natalie Weizenbaum [ctb, cph] (LibSass library), Chris Eppstein [ctb, cph] (LibSass library), Adams Joseph [ctb, cph] (json.cpp), Trifunovic Nemanja [ctb, cph] (utf8.h)", + "Maintainer": "Carson Sievert ", + "Repository": "RSPM" + }, + "scales": { + "Package": "scales", + "Version": "1.3.0", + "Source": "Repository", + "Title": "Scale Functions for Visualization", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\")), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Dana\", \"Seidel\", role = \"aut\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Graphical scales map data to aesthetics, and provide methods for automatically determining breaks and labels for axes and legends.", + "License": "MIT + file LICENSE", + "URL": "https://scales.r-lib.org, https://github.com/r-lib/scales", + "BugReports": "https://github.com/r-lib/scales/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli", + "farver (>= 2.0.3)", + "glue", + "labeling", + "lifecycle", + "munsell (>= 0.5)", + "R6", + "RColorBrewer", + "rlang (>= 1.0.0)", + "viridisLite" + ], + "Suggests": [ + "bit64", + "covr", + "dichromat", + "ggplot2", + "hms (>= 0.5.0)", + "stringi", + "testthat (>= 3.0.0)" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyLoad": "yes", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut], Thomas Lin Pedersen [cre, aut] (), Dana Seidel [aut], Posit, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "RSPM" + }, + "shiny": { + "Package": "shiny", + "Version": "1.10.0", + "Source": "Repository", + "Type": "Package", + "Title": "Web Application Framework for R", + "Authors@R": "c( person(\"Winston\", \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@posit.co\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@posit.co\"), person(\"JJ\", \"Allaire\", role = \"aut\", email = \"jj@posit.co\"), person(\"Carson\", \"Sievert\", role = \"aut\", email = \"carson@posit.co\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Barret\", \"Schloerke\", role = \"aut\", email = \"barret@posit.co\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Yihui\", \"Xie\", role = \"aut\", email = \"yihui@posit.co\"), person(\"Jeff\", \"Allen\", role = \"aut\"), person(\"Jonathan\", \"McPherson\", role = \"aut\", email = \"jonathan@posit.co\"), person(\"Alan\", \"Dipert\", role = \"aut\"), person(\"Barbara\", \"Borges\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt\"), person(family = \"jQuery UI contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Prem Nawaz\", \"Khan\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Victor\", \"Tsaran\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Dennis\", \"Lembree\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Srinivasu\", \"Chakravarthula\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Cathy\", \"O'Connor\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(family = \"PayPal, Inc\", role = \"cph\", comment = \"Bootstrap accessibility plugin\"), person(\"Stefan\", \"Petre\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap-datepicker library\"), person(\"Andrew\", \"Rowls\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap-datepicker library\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js library\"), person(\"Salmen\", \"Bejaoui\", role = c(\"ctb\", \"cph\"), comment = \"selectize-plugin-a11y library\"), person(\"Denis\", \"Ineshin\", role = c(\"ctb\", \"cph\"), comment = \"ion.rangeSlider library\"), person(\"Sami\", \"Samhuri\", role = c(\"ctb\", \"cph\"), comment = \"Javascript strftime library\"), person(family = \"SpryMedia Limited\", role = c(\"ctb\", \"cph\"), comment = \"DataTables library\"), person(\"John\", \"Fraser\", role = c(\"ctb\", \"cph\"), comment = \"showdown.js library\"), person(\"John\", \"Gruber\", role = c(\"ctb\", \"cph\"), comment = \"showdown.js library\"), person(\"Ivan\", \"Sagalaev\", role = c(\"ctb\", \"cph\"), comment = \"highlight.js library\"), person(family = \"R Core Team\", role = c(\"ctb\", \"cph\"), comment = \"tar implementation from R\") )", + "Description": "Makes it incredibly easy to build interactive web applications with R. Automatic \"reactive\" binding between inputs and outputs and extensive prebuilt widgets make it possible to build beautiful, responsive, and powerful applications with minimal effort.", + "License": "GPL-3 | file LICENSE", + "Depends": [ + "R (>= 3.0.2)", + "methods" + ], + "Imports": [ + "utils", + "grDevices", + "httpuv (>= 1.5.2)", + "mime (>= 0.3)", + "jsonlite (>= 0.9.16)", + "xtable", + "fontawesome (>= 0.4.0)", + "htmltools (>= 0.5.4)", + "R6 (>= 2.0)", + "sourcetools", + "later (>= 1.0.0)", + "promises (>= 1.3.2)", + "tools", + "crayon", + "rlang (>= 0.4.10)", + "fastmap (>= 1.1.1)", + "withr", + "commonmark (>= 1.7)", + "glue (>= 1.3.2)", + "bslib (>= 0.6.0)", + "cachem (>= 1.1.0)", + "lifecycle (>= 0.2.0)" + ], + "Suggests": [ + "coro (>= 1.1.0)", + "datasets", + "DT", + "Cairo (>= 1.5-5)", + "testthat (>= 3.0.0)", + "knitr (>= 1.6)", + "markdown", + "rmarkdown", + "ggplot2", + "reactlog (>= 1.0.0)", + "magrittr", + "yaml", + "future", + "dygraphs", + "ragg", + "showtext", + "sass" + ], + "URL": "https://shiny.posit.co/, https://github.com/rstudio/shiny", + "BugReports": "https://github.com/rstudio/shiny/issues", + "Collate": "'globals.R' 'app-state.R' 'app_template.R' 'bind-cache.R' 'bind-event.R' 'bookmark-state-local.R' 'bookmark-state.R' 'bootstrap-deprecated.R' 'bootstrap-layout.R' 'conditions.R' 'map.R' 'utils.R' 'bootstrap.R' 'busy-indicators-spinners.R' 'busy-indicators.R' 'cache-utils.R' 'deprecated.R' 'devmode.R' 'diagnose.R' 'extended-task.R' 'fileupload.R' 'graph.R' 'reactives.R' 'reactive-domains.R' 'history.R' 'hooks.R' 'html-deps.R' 'image-interact-opts.R' 'image-interact.R' 'imageutils.R' 'input-action.R' 'input-checkbox.R' 'input-checkboxgroup.R' 'input-date.R' 'input-daterange.R' 'input-file.R' 'input-numeric.R' 'input-password.R' 'input-radiobuttons.R' 'input-select.R' 'input-slider.R' 'input-submit.R' 'input-text.R' 'input-textarea.R' 'input-utils.R' 'insert-tab.R' 'insert-ui.R' 'jqueryui.R' 'knitr.R' 'middleware-shiny.R' 'middleware.R' 'timer.R' 'shiny.R' 'mock-session.R' 'modal.R' 'modules.R' 'notifications.R' 'priorityqueue.R' 'progress.R' 'react.R' 'reexports.R' 'render-cached-plot.R' 'render-plot.R' 'render-table.R' 'run-url.R' 'runapp.R' 'serializers.R' 'server-input-handlers.R' 'server-resource-paths.R' 'server.R' 'shiny-options.R' 'shiny-package.R' 'shinyapp.R' 'shinyui.R' 'shinywrappers.R' 'showcase.R' 'snapshot.R' 'staticimports.R' 'tar.R' 'test-export.R' 'test-server.R' 'test.R' 'update-input.R' 'utils-lang.R' 'version_bs_date_picker.R' 'version_ion_range_slider.R' 'version_jquery.R' 'version_jqueryui.R' 'version_selectize.R' 'version_strftime.R' 'viewer.R'", + "RoxygenNote": "7.3.2", + "Encoding": "UTF-8", + "RdMacros": "lifecycle", + "Config/testthat/edition": "3", + "Config/Needs/check": "shinytest2", + "NeedsCompilation": "no", + "Author": "Winston Chang [aut, cre] (), Joe Cheng [aut], JJ Allaire [aut], Carson Sievert [aut] (), Barret Schloerke [aut] (), Yihui Xie [aut], Jeff Allen [aut], Jonathan McPherson [aut], Alan Dipert [aut], Barbara Borges [aut], Posit Software, PBC [cph, fnd], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt), jQuery UI contributors [ctb, cph] (jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Prem Nawaz Khan [ctb] (Bootstrap accessibility plugin), Victor Tsaran [ctb] (Bootstrap accessibility plugin), Dennis Lembree [ctb] (Bootstrap accessibility plugin), Srinivasu Chakravarthula [ctb] (Bootstrap accessibility plugin), Cathy O'Connor [ctb] (Bootstrap accessibility plugin), PayPal, Inc [cph] (Bootstrap accessibility plugin), Stefan Petre [ctb, cph] (Bootstrap-datepicker library), Andrew Rowls [ctb, cph] (Bootstrap-datepicker library), Brian Reavis [ctb, cph] (selectize.js library), Salmen Bejaoui [ctb, cph] (selectize-plugin-a11y library), Denis Ineshin [ctb, cph] (ion.rangeSlider library), Sami Samhuri [ctb, cph] (Javascript strftime library), SpryMedia Limited [ctb, cph] (DataTables library), John Fraser [ctb, cph] (showdown.js library), John Gruber [ctb, cph] (showdown.js library), Ivan Sagalaev [ctb, cph] (highlight.js library), R Core Team [ctb, cph] (tar implementation from R)", + "Maintainer": "Winston Chang ", + "Repository": "CRAN" + }, + "shinyWidgets": { + "Package": "shinyWidgets", + "Version": "0.8.7", + "Source": "Repository", + "Title": "Custom Inputs Widgets for Shiny", + "Authors@R": "c( person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"David\", \"Granjon\", role = \"aut\"), person(\"Ian\", \"Fellows\", role = \"ctb\", comment = \"Methods for mutating vertical tabs & updateMultiInput\"), person(\"Wil\", \"Davis\", role = \"ctb\", comment = \"numericRangeInput function\"), person(\"Spencer\", \"Matthews\", role = \"ctb\", comment = \"autoNumeric methods\"), person(family = \"JavaScript and CSS libraries authors\", role = c(\"ctb\", \"cph\"), comment = \"All authors are listed in LICENSE.md\") )", + "Description": "Collection of custom input controls and user interface components for 'Shiny' applications. Give your applications a unique and colorful style !", + "URL": "https://github.com/dreamRs/shinyWidgets, https://dreamrs.github.io/shinyWidgets/", + "BugReports": "https://github.com/dreamRs/shinyWidgets/issues", + "License": "GPL-3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.3.2", + "Depends": [ + "R (>= 3.1.0)" + ], + "Imports": [ + "bslib", + "sass", + "shiny (>= 1.6.0)", + "htmltools (>= 0.5.1)", + "jsonlite", + "grDevices", + "rlang" + ], + "Suggests": [ + "testthat", + "covr", + "ggplot2", + "DT", + "scales", + "shinydashboard", + "shinydashboardPlus" + ], + "NeedsCompilation": "no", + "Author": "Victor Perrier [aut, cre, cph], Fanny Meyer [aut], David Granjon [aut], Ian Fellows [ctb] (Methods for mutating vertical tabs & updateMultiInput), Wil Davis [ctb] (numericRangeInput function), Spencer Matthews [ctb] (autoNumeric methods), JavaScript and CSS libraries authors [ctb, cph] (All authors are listed in LICENSE.md)", + "Maintainer": "Victor Perrier ", + "Repository": "CRAN" + }, + "shinybusy": { + "Package": "shinybusy", + "Version": "0.3.3", + "Source": "Repository", + "Title": "Busy Indicators and Notifications for 'Shiny' Applications", + "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", + "Description": "Add indicators (spinner, progress bar, gif) in your 'shiny' applications to show the user that the server is busy. And other tools to let your users know something is happening (send notifications, reports, ...).", + "License": "GPL-3", + "Encoding": "UTF-8", + "Imports": [ + "htmltools", + "shiny", + "jsonlite", + "htmlwidgets" + ], + "RoxygenNote": "7.3.1", + "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", + "BugReports": "https://github.com/dreamRs/shinybusy/issues", + "Suggests": [ + "testthat", + "covr", + "knitr", + "rmarkdown" + ], + "VignetteBuilder": "knitr", + "NeedsCompilation": "no", + "Author": "Fanny Meyer [aut], Victor Perrier [aut, cre], Silex Technologies [fnd] (https://www.silex-ip.com)", + "Maintainer": "Victor Perrier ", + "Repository": "CRAN" + }, + "shinycssloaders": { + "Package": "shinycssloaders", + "Version": "1.1.0", + "Source": "Repository", + "Title": "Add Loading Animations to a 'shiny' Output While It's Recalculating", + "Authors@R": "c( person(\"Dean\",\"Attali\",email=\"daattali@gmail.com\",role=c(\"aut\",\"cre\"), comment = c(\"Maintainer/developer of shinycssloaders since 2019\", ORCID=\"0000-0002-5645-3493\")), person(\"Andras\",\"Sali\",email=\"andras.sali@alphacruncher.hu\",role=c(\"aut\"),comment=\"Original creator of shinycssloaders package\"), person(\"Luke\",\"Hass\",role=c(\"ctb\",\"cph\"),comment=\"Author of included CSS loader code\") )", + "Description": "When a 'Shiny' output (such as a plot, table, map, etc.) is recalculating, it remains visible but gets greyed out. Using 'shinycssloaders', you can add a loading animation (\"spinner\") to outputs instead. By wrapping a 'Shiny' output in 'withSpinner()', a spinner will automatically appear while the output is recalculating. You can also manually show and hide the spinner, or add a full-page spinner to cover the entire page. See the demo online at .", + "License": "MIT + file LICENSE", + "URL": "https://github.com/daattali/shinycssloaders, https://daattali.com/shiny/shinycssloaders-demo/", + "BugReports": "https://github.com/daattali/shinycssloaders/issues", + "Depends": [ + "R (>= 3.1)" + ], + "Imports": [ + "digest", + "glue", + "grDevices", + "htmltools (>= 0.3.5)", + "shiny" + ], + "Suggests": [ + "knitr", + "shinydisconnect", + "shinyjs" + ], + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Dean Attali [aut, cre] (Maintainer/developer of shinycssloaders since 2019, ), Andras Sali [aut] (Original creator of shinycssloaders package), Luke Hass [ctb, cph] (Author of included CSS loader code)", + "Maintainer": "Dean Attali ", + "Repository": "CRAN" + }, + "shinyjs": { + "Package": "shinyjs", + "Version": "2.1.0", + "Source": "Repository", + "Title": "Easily Improve the User Experience of Your Shiny Apps in Seconds", + "Authors@R": "person(\"Dean\", \"Attali\", email = \"daattali@gmail.com\", role = c(\"aut\", \"cre\"), comment= c(ORCID=\"0000-0002-5645-3493\"))", + "Description": "Perform common useful JavaScript operations in Shiny apps that will greatly improve your apps without having to know any JavaScript. Examples include: hiding an element, disabling an input, resetting an input back to its original value, delaying code execution by a few seconds, and many more useful functions for both the end user and the developer. 'shinyjs' can also be used to easily call your own custom JavaScript functions from R.", + "URL": "https://deanattali.com/shinyjs/", + "BugReports": "https://github.com/daattali/shinyjs/issues", + "Depends": [ + "R (>= 3.1.0)" + ], + "Imports": [ + "digest (>= 0.6.8)", + "jsonlite", + "shiny (>= 1.0.0)" + ], + "Suggests": [ + "htmltools (>= 0.2.9)", + "knitr (>= 1.7)", + "rmarkdown", + "shinyAce", + "shinydisconnect", + "testthat (>= 0.9.1)" + ], + "License": "MIT + file LICENSE", + "VignetteBuilder": "knitr", + "RoxygenNote": "7.1.1", + "Encoding": "UTF-8", + "NeedsCompilation": "no", + "Author": "Dean Attali [aut, cre] ()", + "Maintainer": "Dean Attali ", + "Repository": "RSPM" + }, + "sourcetools": { + "Package": "sourcetools", + "Version": "0.1.7-1", + "Source": "Repository", + "Type": "Package", + "Title": "Tools for Reading, Tokenizing and Parsing R Code", + "Author": "Kevin Ushey", + "Maintainer": "Kevin Ushey ", + "Description": "Tools for the reading and tokenization of R code. The 'sourcetools' package provides both an R and C++ interface for the tokenization of R code, and helpers for interacting with the tokenized representation of R code.", + "License": "MIT + file LICENSE", + "Depends": [ + "R (>= 3.0.2)" + ], + "Suggests": [ + "testthat" + ], + "RoxygenNote": "5.0.1", + "BugReports": "https://github.com/kevinushey/sourcetools/issues", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "Repository": "RSPM" + }, + "stringi": { + "Package": "stringi", + "Version": "1.8.4", + "Source": "Repository", + "Date": "2024-05-06", + "Title": "Fast and Portable Character String Processing Facilities", + "Description": "A collection of character string/text/natural language processing tools for pattern searching (e.g., with 'Java'-like regular expressions or the 'Unicode' collation algorithm), random string generation, case mapping, string transliteration, concatenation, sorting, padding, wrapping, Unicode normalisation, date-time formatting and parsing, and many more. They are fast, consistent, convenient, and - thanks to 'ICU' (International Components for Unicode) - portable across all locales and platforms. Documentation about 'stringi' is provided via its website at and the paper by Gagolewski (2022, ).", + "URL": "https://stringi.gagolewski.com/, https://github.com/gagolews/stringi, https://icu.unicode.org/", + "BugReports": "https://github.com/gagolews/stringi/issues", + "SystemRequirements": "ICU4C (>= 61, optional)", + "Type": "Package", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "tools", + "utils", + "stats" + ], + "Biarch": "TRUE", + "License": "file LICENSE", + "Author": "Marek Gagolewski [aut, cre, cph] (), Bartek Tartanus [ctb], and others (stringi source code); Unicode, Inc. and others (ICU4C source code, Unicode Character Database)", + "Maintainer": "Marek Gagolewski ", + "RoxygenNote": "7.2.3", + "Encoding": "UTF-8", + "NeedsCompilation": "yes", + "License_is_FOSS": "yes", + "Repository": "RSPM" + }, + "stringr": { + "Package": "stringr", + "Version": "1.5.1", + "Source": "Repository", + "Title": "Simple, Consistent Wrappers for Common String Operations", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A consistent, simple and easy to use set of wrappers around the fantastic 'stringi' package. All function and argument names (and positions) are consistent, all functions deal with \"NA\"'s and zero length vectors in the same way, and the output from one function is easy to feed into the input of another.", + "License": "MIT + file LICENSE", + "URL": "https://stringr.tidyverse.org, https://github.com/tidyverse/stringr", + "BugReports": "https://github.com/tidyverse/stringr/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli", + "glue (>= 1.6.1)", + "lifecycle (>= 1.0.3)", + "magrittr", + "rlang (>= 1.0.0)", + "stringi (>= 1.5.3)", + "vctrs (>= 0.4.0)" + ], + "Suggests": [ + "covr", + "dplyr", + "gt", + "htmltools", + "htmlwidgets", + "knitr", + "rmarkdown", + "testthat (>= 3.0.0)", + "tibble" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Hadley Wickham [aut, cre, cph], Posit Software, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "styler": { + "Package": "styler", + "Version": "1.10.3", + "Source": "Repository", + "Type": "Package", + "Title": "Non-Invasive Pretty Printing of R Code", + "Authors@R": "c(person(given = \"Kirill\", family = \"Müller\", role = \"aut\", email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Lorenz\", family = \"Walthert\", role = c(\"cre\", \"aut\"), email = \"lorenz.walthert@icloud.com\"), person(given = \"Indrajeet\", family = \"Patil\", role = \"ctb\", email = \"patilindrajeet.science@gmail.com\", comment = c(ORCID = \"0000-0003-1995-6531\", Twitter = \"@patilindrajeets\")))", + "Description": "Pretty-prints R code without changing the user's formatting intent.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/styler, https://styler.r-lib.org", + "BugReports": "https://github.com/r-lib/styler/issues", + "Depends": [ + "R (>= 3.6.0)" + ], + "Imports": [ + "cli (>= 3.1.1)", + "magrittr (>= 2.0.0)", + "purrr (>= 0.2.3)", + "R.cache (>= 0.15.0)", + "rlang (>= 1.0.0)", + "rprojroot (>= 1.1)", + "tools", + "vctrs (>= 0.4.1)", + "withr (>= 2.3.0)" + ], + "Suggests": [ + "data.tree (>= 0.1.6)", + "digest", + "here", + "knitr", + "prettycode", + "rmarkdown", + "roxygen2", + "rstudioapi (>= 0.7)", + "tibble (>= 1.4.2)", + "testthat (>= 3.0.0)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.1", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Collate": "'addins.R' 'communicate.R' 'compat-dplyr.R' 'compat-tidyr.R' 'detect-alignment-utils.R' 'detect-alignment.R' 'environments.R' 'expr-is.R' 'indent.R' 'initialize.R' 'io.R' 'nest.R' 'nested-to-tree.R' 'parse.R' 'reindent.R' 'token-define.R' 'relevel.R' 'roxygen-examples-add-remove.R' 'roxygen-examples-find.R' 'roxygen-examples-parse.R' 'roxygen-examples.R' 'rules-indention.R' 'rules-line-breaks.R' 'rules-spaces.R' 'rules-tokens.R' 'serialize.R' 'set-assert-args.R' 'style-guides.R' 'styler-package.R' 'stylerignore.R' 'testing-mocks.R' 'testing-public-api.R' 'ui-caching.R' 'testing.R' 'token-create.R' 'transform-block.R' 'transform-code.R' 'transform-files.R' 'ui-styling.R' 'unindent.R' 'utils-cache.R' 'utils-files.R' 'utils-navigate-nest.R' 'utils-strings.R' 'utils.R' 'vertical.R' 'visit.R' 'zzz.R'", + "NeedsCompilation": "no", + "Author": "Kirill Müller [aut] (), Lorenz Walthert [cre, aut], Indrajeet Patil [ctb] (, @patilindrajeets)", + "Maintainer": "Lorenz Walthert ", + "Repository": "CRAN" + }, + "sys": { + "Package": "sys", + "Version": "3.4.3", + "Source": "Repository", + "Type": "Package", + "Title": "Powerful and Reliable Tools for Running System Commands in R", + "Authors@R": "c(person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = \"ctb\"))", + "Description": "Drop-in replacements for the base system2() function with fine control and consistent behavior across platforms. Supports clean interruption, timeout, background tasks, and streaming STDIN / STDOUT / STDERR over binary or text connections. Arguments on Windows automatically get encoded and quoted to work on different locales.", + "License": "MIT + file LICENSE", + "URL": "https://jeroen.r-universe.dev/sys", + "BugReports": "https://github.com/jeroen/sys/issues", + "Encoding": "UTF-8", + "RoxygenNote": "7.1.1", + "Suggests": [ + "unix (>= 1.4)", + "spelling", + "testthat" + ], + "Language": "en-US", + "NeedsCompilation": "yes", + "Author": "Jeroen Ooms [aut, cre] (), Gábor Csárdi [ctb]", + "Maintainer": "Jeroen Ooms ", + "Repository": "RSPM" + }, + "systemfonts": { + "Package": "systemfonts", + "Version": "1.2.1", + "Source": "Repository", + "Type": "Package", + "Title": "System Native Font Finding", + "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Jeroen\", \"Ooms\", , \"jeroen@berkeley.edu\", role = \"aut\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Devon\", \"Govett\", role = \"aut\", comment = \"Author of font-manager\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides system native access to the font catalogue. As font handling varies between systems it is difficult to correctly locate installed fonts across different operating systems. The 'systemfonts' package provides bindings to the native libraries on Windows, macOS and Linux for finding font files that can then be used further by e.g. graphic devices. The main use is intended to be from compiled code but 'systemfonts' also provides access from R.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/systemfonts, https://systemfonts.r-lib.org", + "BugReports": "https://github.com/r-lib/systemfonts/issues", + "Depends": [ + "R (>= 3.2.0)" + ], + "Suggests": [ + "covr", + "farver", + "graphics", + "knitr", + "rmarkdown", + "testthat (>= 2.1.0)" + ], + "LinkingTo": [ + "cpp11 (>= 0.2.1)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "SystemRequirements": "fontconfig, freetype2", + "Config/Needs/website": "tidyverse/tidytemplate", + "Imports": [ + "grid", + "jsonlite", + "lifecycle", + "tools", + "utils" + ], + "Config/build/compilation-database": "true", + "NeedsCompilation": "yes", + "Author": "Thomas Lin Pedersen [aut, cre] (), Jeroen Ooms [aut] (), Devon Govett [aut] (Author of font-manager), Posit, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "CRAN" + }, + "teal": { + "Package": "teal", + "Version": "0.15.2.9131", + "Source": "Repository", + "Type": "Package", + "Title": "Exploratory Web Apps for Analyzing Clinical Trials Data", + "Date": "2025-02-12", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\"), person(\"Vedha\", \"Viyash\", , \"vedha.viyash@roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"Tadeusz\", \"Lewandowski\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")), person(\"Maximilian\", \"Mordig\", role = \"ctb\") )", + "Description": "A 'shiny' based interactive exploration framework for analyzing clinical trials data. 'teal' currently provides a dynamic filtering facility and different data viewers. 'teal' 'shiny' applications are built using standard 'shiny' modules.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal/, https://github.com/insightsengineering/teal/", + "BugReports": "https://github.com/insightsengineering/teal/issues", + "Depends": [ + "R (>= 4.1)", + "shiny (>= 1.8.1)", + "teal.data (>= 0.7.0)", + "teal.slice (>= 0.6.0)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "cli", + "htmltools", + "jsonlite", + "lifecycle (>= 0.2.0)", + "logger (>= 0.2.0)", + "methods", + "rlang (>= 1.0.0)", + "shinyjs", + "stats", + "teal.code (>= 0.6.0)", + "teal.logger (>= 0.3.1)", + "teal.reporter (>= 0.4.0)", + "teal.widgets (>= 0.4.3)", + "tools", + "utils" + ], + "Suggests": [ + "bslib", + "ggplot2 (>= 3.4.0)", + "knitr (>= 1.42)", + "mirai (>= 1.1.1)", + "MultiAssayExperiment", + "R6", + "renv (>= 1.0.11)", + "rmarkdown (>= 2.23)", + "roxy.shinylive", + "rvest (>= 1.0.0)", + "shinytest2", + "shinyvalidate", + "testthat (>= 3.2.0)", + "withr (>= 2.1.0)", + "yaml (>= 1.1.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "rstudio/shiny, insightsengineering/teal.data, insightsengineering/teal.slice, mllg/checkmate, jeroen/jsonlite, r-lib/lifecycle, daroczig/logger, shikokuchuo/mirai, r-lib/cli, shikokuchuo/nanonext, rstudio/renv, r-lib/rlang, daattali/shinyjs, insightsengineering/teal.code, insightsengineering/teal.logger, insightsengineering/teal.reporter, insightsengineering/teal.widgets, rstudio/bslib, yihui/knitr, bioc::MultiAssayExperiment, r-lib/R6, rstudio/rmarkdown, tidyverse/rvest, rstudio/shinytest2, rstudio/shinyvalidate, r-lib/testthat, r-lib/withr, yaml=vubiostat/r-yaml, rstudio/htmltools, bioc::matrixStats, insightsengineering/roxy.shinylive", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE, packages = c(\"roxy.shinylive\"))", + "RoxygenNote": "7.3.2", + "Collate": "'TealAppDriver.R' 'checkmate.R' 'dummy_functions.R' 'include_css_js.R' 'modules.R' 'init.R' 'landing_popup_module.R' 'module_bookmark_manager.R' 'module_data_summary.R' 'module_filter_data.R' 'module_filter_manager.R' 'module_init_data.R' 'module_nested_tabs.R' 'module_session_info.R' 'module_snapshot_manager.R' 'module_teal.R' 'module_teal_data.R' 'module_teal_lockfile.R' 'module_teal_with_splash.R' 'module_transform_data.R' 'reporter_previewer_module.R' 'show_rcode_modal.R' 'tdata.R' 'teal.R' 'teal_data_module.R' 'teal_data_module-eval_code.R' 'teal_data_module-within.R' 'teal_data_utils.R' 'teal_modifiers.R' 'teal_reporter.R' 'teal_slices-store.R' 'teal_slices.R' 'teal_transform_module.R' 'utils.R' 'validate_inputs.R' 'validations.R' 'zzz.R'", + "Config/pak/sysreqs": "libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev make libharfbuzz-dev libicu-dev libjpeg-dev libpng-dev libtiff-dev libxml2-dev libssl-dev zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal", + "RemoteRef": "HEAD", + "RemoteSha": "c75f39ed4f4eb989059e7a22aace4a8cfb020bc6", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre] (), Pawel Rucki [aut], Aleksander Chlebowski [aut] (), Andre Verissimo [aut] (), Kartikeya Kirar [aut], Vedha Viyash [aut], Marcin Kosinski [aut], Adrian Waddell [aut], Chendi Liao [rev], Dony Unardi [rev], Nikolas Burkoff [aut], Mahmoud Hallal [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Tadeusz Lewandowski [aut], F. Hoffmann-La Roche AG [cph, fnd], Maximilian Mordig [ctb]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.code": { + "Package": "teal.code", + "Version": "0.6.0.9002", + "Source": "Repository", + "Type": "Package", + "Title": "Code Storage and Execution Class for 'teal' Applications", + "Date": "2025-02-04", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", , \"nikolas.burkoff@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", , \"maciej.nasinski@contractors.roche.com\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", , \"konrad.pagacz@contractors.roche.com\", role = \"aut\"), person(\"Junlue\", \"Zhao\", , \"zhaoj88@gene.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Introduction of 'qenv' S4 class, that facilitates code execution and reproducibility in 'teal' applications.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal.code/, https://github.com/insightsengineering/teal.code", + "BugReports": "https://github.com/insightsengineering/teal.code/issues", + "Depends": [ + "methods", + "R (>= 4.0)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "cli (>= 3.4.0)", + "grDevices", + "lifecycle (>= 0.2.0)", + "rlang (>= 1.1.0)", + "stats", + "utils" + ], + "Suggests": [ + "knitr (>= 1.42)", + "rmarkdown (>= 2.23)", + "shiny (>= 1.6.0)", + "testthat (>= 3.1.8)", + "withr (>= 2.0.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "mllg/checkmate, r-lib/cli, r-lib/lifecycle, r-lib/rlang, r-lib/cli, yihui/knitr, rstudio/rmarkdown, rstudio/shiny, r-lib/testthat, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Collate": "'qenv-c.R' 'qenv-class.R' 'qenv-errors.R' 'qenv-concat.R' 'qenv-constructor.R' 'qenv-eval_code.R' 'qenv-extract.R' 'qenv-get_code.R' 'qenv-get_env.R' 'qenv-get_messages.r' 'qenv-get_var.R' 'qenv-get_warnings.R' 'qenv-join.R' 'qenv-length.R' 'qenv-show.R' 'qenv-within.R' 'teal.code-package.R' 'utils-get_code_dependency.R' 'utils.R'", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.code", + "RemoteRef": "HEAD", + "RemoteSha": "b336941dcc830a9b01fc8e206831cc4367599161", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre], Aleksander Chlebowski [aut], Marcin Kosinski [aut], Pawel Rucki [aut], Nikolas Burkoff [aut], Mahmoud Hallal [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.data": { + "Package": "teal.data", + "Version": "0.7.0.9001", + "Source": "Repository", + "Type": "Package", + "Title": "Data Model for 'teal' Applications", + "Date": "2025-01-31", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides a 'teal_data' class as a unified data model for 'teal' applications focusing on reproducibility and relational data.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal.data/, https://github.com/insightsengineering/teal.data/", + "BugReports": "https://github.com/insightsengineering/teal.data/issues", + "Depends": [ + "R (>= 4.0)", + "teal.code (>= 0.6.0)" + ], + "Imports": [ + "checkmate (>= 2.1.0)", + "lifecycle (>= 0.2.0)", + "methods", + "rlang (>= 1.1.0)", + "stats", + "utils" + ], + "Suggests": [ + "knitr (>= 1.42)", + "rmarkdown (>= 2.23)", + "testthat (>= 3.2.2)", + "withr (>= 2.0.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "insightsengineering/teal.code, mllg/checkmate, r-lib/lifecycle, r-lib/rlang, yihui/knitr, rstudio/rmarkdown, r-lib/testthat, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "LazyData": "true", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Collate": "'cdisc_data.R' 'data.R' 'formatters_var_labels.R' 'deprecated.R' 'dummy_function.R' 'join_key.R' 'join_keys-c.R' 'join_keys-extract.R' 'join_keys-names.R' 'join_keys-parents.R' 'join_keys-print.R' 'join_keys-utils.R' 'join_keys.R' 'teal.data.R' 'teal_data-class.R' 'teal_data-constructor.R' 'teal_data-extract.R' 'teal_data-get_code.R' 'teal_data-names.R' 'teal_data-show.R' 'testhat-helpers.R' 'topological_sort.R' 'verify.R' 'zzz.R'", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.data", + "RemoteRef": "HEAD", + "RemoteSha": "9100800ce0572092f6f2e0288d099e6b77ab160c", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre] (), Aleksander Chlebowski [aut] (), Marcin Kosinski [aut], Andre Verissimo [aut] (), Pawel Rucki [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.logger": { + "Package": "teal.logger", + "Version": "0.3.1.9001", + "Source": "Repository", + "Title": "Logging Setup for the 'teal' Family of Packages", + "Date": "2025-02-06", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Utilizing the 'logger' framework to record events within a package, specific to 'teal' family of packages. Supports logging namespaces, hierarchical logging, various log destinations, vectorization, and more.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal.logger/, https://github.com/insightsengineering/teal.logger/", + "BugReports": "https://github.com/insightsengineering/teal.logger/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "glue (>= 1.0.0)", + "lifecycle (>= 0.2.0)", + "logger (>= 0.3.0)", + "methods", + "shiny (>= 1.6.0)", + "utils", + "withr (>= 2.1.0)" + ], + "Suggests": [ + "knitr (>= 1.42)", + "rmarkdown (>= 2.23)", + "testthat (>= 3.1.7)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "tidyverse/glue, r-lib/lifecycle, daroczig/logger, rstudio/shiny, r-lib/withr, yihui/knitr, rstudio/rmarkdown, r-lib/testthat", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Config/pak/sysreqs": "make zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.logger", + "RemoteRef": "HEAD", + "RemoteSha": "99657d4725f47966d9f7502f7d266947228011d6", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre], Konrad Pagacz [aut], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.reporter": { + "Package": "teal.reporter", + "Version": "0.4.0.9003", + "Source": "Repository", + "Title": "Reporting Tools for 'shiny' Modules", + "Date": "2025-01-31", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\", comment = c(ORCID = \"0009-0005-1258-4757\")), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Prebuilt 'shiny' modules containing tools for the generation of 'rmarkdown' reports, supporting reproducible research and analysis.", + "License": "Apache License 2.0", + "URL": "https://github.com/insightsengineering/teal.reporter, https://insightsengineering.github.io/teal.reporter/", + "BugReports": "https://github.com/insightsengineering/teal.reporter/issues", + "Imports": [ + "bslib", + "checkmate (>= 2.1.0)", + "flextable (>= 0.9.2)", + "grid", + "htmltools (>= 0.5.4)", + "knitr (>= 1.42)", + "lifecycle (>= 0.2.0)", + "R6", + "rlistings (>= 0.2.10)", + "rmarkdown (>= 2.23)", + "rtables (>= 0.6.11)", + "rtables.officer (>= 0.0.2)", + "shiny (>= 1.6.0)", + "shinybusy (>= 0.3.2)", + "shinyWidgets (>= 0.5.1)", + "yaml (>= 1.1.0)", + "zip (>= 1.1.0)" + ], + "Suggests": [ + "DT (>= 0.13)", + "formatR (>= 1.5)", + "formatters (>= 0.5.10)", + "ggplot2 (>= 3.4.3)", + "lattice (>= 0.18-4)", + "png", + "testthat (>= 3.2.2)", + "tinytex", + "withr (>= 2.0.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "rstudio/bslib, mllg/checkmate, davidgohel/flextable, rstudio/htmltools, yihui/knitr, r-lib/lifecycle, r-lib/R6, insightsengineering/rlistings, rstudio/rmarkdown, insightsengineering/rtables, insightsengineering/rtables.officer, rstudio/shiny, dreamRs/shinybusy, dreamRs/shinyWidgets, yaml=vubiostat/r-yaml, r-lib/zip, rstudio/DT, yihui/formatR, insightsengineering/formatters, tidyverse/ggplot2, deepayan/lattice, cran/png, r-lib/testthat, rstudio/tinytex, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Config/pak/sysreqs": "libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev make libharfbuzz-dev libicu-dev libjpeg-dev libpng-dev libtiff-dev libxml2-dev libssl-dev zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.reporter", + "RemoteRef": "HEAD", + "RemoteSha": "b19bdd307fe24c9678a984beb57bc6e9e5c1643f", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre] (), Kartikeya Kirar [aut] (), Marcin Kosinski [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Mahmoud Hallal [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.slice": { + "Package": "teal.slice", + "Version": "0.6.0.9000", + "Source": "Repository", + "Type": "Package", + "Title": "Filter Module for 'teal' Applications", + "Date": "2025-02-04", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"Andrew\", \"Bates\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Data filtering module for 'teal' applications. Allows for interactive filtering of data stored in 'data.frame' and 'MultiAssayExperiment' objects. Also displays filtered and unfiltered observation counts.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal.slice/, https://github.com/insightsengineering/teal.slice/", + "BugReports": "https://github.com/insightsengineering/teal.slice/issues", + "Depends": [ + "R (>= 4.0)" + ], + "Imports": [ + "bslib (>= 0.4.0)", + "checkmate (>= 2.1.0)", + "dplyr (>= 1.0.5)", + "grDevices", + "htmltools (>= 0.5.4)", + "jsonlite", + "lifecycle (>= 0.2.0)", + "logger (>= 0.3.0)", + "methods", + "plotly (>= 4.9.2.2)", + "R6 (>= 2.2.0)", + "rlang (>= 1.0.0)", + "shiny (>= 1.6.0)", + "shinycssloaders (>= 1.0.0)", + "shinyjs", + "shinyWidgets (>= 0.6.2)", + "teal.data (>= 0.7.0)", + "teal.logger (>= 0.3.1)", + "teal.widgets (>= 0.4.3)", + "utils" + ], + "Suggests": [ + "knitr (>= 1.42)", + "MultiAssayExperiment", + "rmarkdown (>= 2.23)", + "SummarizedExperiment", + "testthat (>= 3.2.2)", + "withr (>= 3.0.2)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "RdMacros": "lifecycle", + "Config/Needs/verdepcheck": "rstudio/shiny, rstudio/bslib, mllg/checkmate, tidyverse/dplyr, rstudio/htmltools, jeroen/jsonlite, r-lib/lifecycle, daroczig/logger, plotly/plotly, r-lib/R6, daattali/shinycssloaders, daattali/shinyjs, dreamRs/shinyWidgets, insightsengineering/teal.data, insightsengineering/teal.logger, insightsengineering/teal.widgets, yihui/knitr, bioc::MultiAssayExperiment, bioc::SummarizedExperiment, rstudio/rmarkdown, r-lib/testthat, r-lib/withr, bioc::matrixStats", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Config/pak/sysreqs": "make libicu-dev libssl-dev zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.slice", + "RemoteRef": "HEAD", + "RemoteSha": "7f261e0e59a95c29dd511ef64099c53c9617baf4", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre] (), Pawel Rucki [aut], Aleksander Chlebowski [aut] (), Andre Verissimo [aut] (), Kartikeya Kirar [aut], Marcin Kosinski [aut], Chendi Liao [rev], Dony Unardi [rev], Andrew Bates [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "teal.widgets": { + "Package": "teal.widgets", + "Version": "0.4.3.9000", + "Source": "Repository", + "Title": "'shiny' Widgets for 'teal' Applications", + "Date": "2025-01-31", + "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", + "Description": "Collection of 'shiny' widgets to support 'teal' applications. Enables the manipulation of application layout and plot or table settings.", + "License": "Apache License 2.0", + "URL": "https://insightsengineering.github.io/teal.widgets/, https://github.com/insightsengineering/teal.widgets", + "BugReports": "https://github.com/insightsengineering/teal.widgets/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "bslib", + "checkmate (>= 2.1.0)", + "ggplot2 (>= 3.4.3)", + "graphics", + "grDevices", + "htmltools (>= 0.5.4)", + "lifecycle (>= 0.2.0)", + "methods", + "rtables (>= 0.6.6)", + "shiny (>= 1.6.0)", + "shinyjs", + "shinyWidgets (>= 0.5.1)", + "styler (>= 1.2.0)" + ], + "Suggests": [ + "DT", + "knitr (>= 1.42)", + "lattice (>= 0.18-4)", + "magrittr (>= 1.5)", + "png", + "rmarkdown (>= 2.23)", + "rvest (>= 1.0.3)", + "shinytest2 (>= 0.2.0)", + "shinyvalidate", + "testthat (>= 3.1.5)", + "withr (>= 2.1.0)" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/Needs/verdepcheck": "rstudio/bslib, mllg/checkmate, tidyverse/ggplot2, rstudio/htmltools, r-lib/lifecycle, insightsengineering/rtables, rstudio/shiny, daattali/shinyjs, dreamRs/shinyWidgets, r-lib/styler, rstudio/DT, yihui/knitr, deepayan/lattice, tidyverse/magrittr, cran/png, tidyverse/rvest, rstudio/rmarkdown, rstudio/shinytest2, rstudio/shinyvalidate, r-lib/testthat, r-lib/withr", + "Config/Needs/website": "insightsengineering/nesttemplate", + "Encoding": "UTF-8", + "Language": "en-US", + "Roxygen": "list(markdown = TRUE)", + "RoxygenNote": "7.3.2", + "Config/pak/sysreqs": "make libicu-dev zlib1g-dev", + "Repository": "https://pharmaverse.r-universe.dev", + "RemoteUrl": "https://github.com/insightsengineering/teal.widgets", + "RemoteRef": "HEAD", + "RemoteSha": "ec4a5eed3915e4fa905a45e28b38ca13e78d09ac", + "NeedsCompilation": "no", + "Author": "Dawid Kaledkowski [aut, cre], Pawel Rucki [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], F. Hoffmann-La Roche AG [cph, fnd]", + "Maintainer": "Dawid Kaledkowski " + }, + "textshaping": { + "Package": "textshaping", + "Version": "1.0.0", + "Source": "Repository", + "Title": "Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping", + "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides access to the text shaping functionality in the 'HarfBuzz' library and the bidirectional algorithm in the 'Fribidi' library. 'textshaping' is a low-level utility package mainly for graphic devices that expands upon the font tool-set provided by the 'systemfonts' package.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/textshaping", + "BugReports": "https://github.com/r-lib/textshaping/issues", + "Depends": [ + "R (>= 3.2.0)" + ], + "Imports": [ + "lifecycle", + "stats", + "stringi", + "systemfonts (>= 1.1.0)", + "utils" + ], + "Suggests": [ + "covr", + "grDevices", + "grid", + "knitr", + "rmarkdown", + "testthat (>= 3.0.0)" + ], + "LinkingTo": [ + "cpp11 (>= 0.2.1)", + "systemfonts (>= 1.0.0)" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "SystemRequirements": "freetype2, harfbuzz, fribidi", + "Config/build/compilation-database": "true", + "Config/testthat/edition": "3", + "NeedsCompilation": "yes", + "Author": "Thomas Lin Pedersen [cre, aut] (), Posit, PBC [cph, fnd]", + "Maintainer": "Thomas Lin Pedersen ", + "Repository": "CRAN" + }, + "tibble": { + "Package": "tibble", + "Version": "3.2.1", + "Source": "Repository", + "Title": "Simple Data Frames", + "Authors@R": "c(person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Hadley\", family = \"Wickham\", role = \"aut\", email = \"hadley@rstudio.com\"), person(given = \"Romain\", family = \"Francois\", role = \"ctb\", email = \"romain@r-enthusiasts.com\"), person(given = \"Jennifer\", family = \"Bryan\", role = \"ctb\", email = \"jenny@rstudio.com\"), person(given = \"RStudio\", role = c(\"cph\", \"fnd\")))", + "Description": "Provides a 'tbl_df' class (the 'tibble') with stricter checking and better formatting than the traditional data frame.", + "License": "MIT + file LICENSE", + "URL": "https://tibble.tidyverse.org/, https://github.com/tidyverse/tibble", + "BugReports": "https://github.com/tidyverse/tibble/issues", + "Depends": [ + "R (>= 3.4.0)" + ], + "Imports": [ + "fansi (>= 0.4.0)", + "lifecycle (>= 1.0.0)", + "magrittr", + "methods", + "pillar (>= 1.8.1)", + "pkgconfig", + "rlang (>= 1.0.2)", + "utils", + "vctrs (>= 0.4.2)" + ], + "Suggests": [ + "bench", + "bit64", + "blob", + "brio", + "callr", + "cli", + "covr", + "crayon (>= 1.3.4)", + "DiagrammeR", + "dplyr", + "evaluate", + "formattable", + "ggplot2", + "here", + "hms", + "htmltools", + "knitr", + "lubridate", + "mockr", + "nycflights13", + "pkgbuild", + "pkgload", + "purrr", + "rmarkdown", + "stringi", + "testthat (>= 3.0.2)", + "tidyr", + "withr" + ], + "VignetteBuilder": "knitr", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "true", + "Config/testthat/start-first": "vignette-formats, as_tibble, add, invariants", + "Config/autostyle/scope": "line_breaks", + "Config/autostyle/strict": "true", + "Config/autostyle/rmd": "false", + "Config/Needs/website": "tidyverse/tidytemplate", + "NeedsCompilation": "yes", + "Author": "Kirill Müller [aut, cre] (), Hadley Wickham [aut], Romain Francois [ctb], Jennifer Bryan [ctb], RStudio [cph, fnd]", + "Maintainer": "Kirill Müller ", + "Repository": "RSPM" + }, + "tidyr": { + "Package": "tidyr", + "Version": "1.3.1", + "Source": "Repository", + "Title": "Tidy Messy Data", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = \"aut\"), person(\"Maximilian\", \"Girlich\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevin@posit.co\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Tools to help to create tidy data, where each column is a variable, each row is an observation, and each cell contains a single value. 'tidyr' contains tools for changing the shape (pivoting) and hierarchy (nesting and 'unnesting') of a dataset, turning deeply nested lists into rectangular data frames ('rectangling'), and extracting values out of string columns. It also includes tools for working with missing values (both implicit and explicit).", + "License": "MIT + file LICENSE", + "URL": "https://tidyr.tidyverse.org, https://github.com/tidyverse/tidyr", + "BugReports": "https://github.com/tidyverse/tidyr/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "cli (>= 3.4.1)", + "dplyr (>= 1.0.10)", + "glue", + "lifecycle (>= 1.0.3)", + "magrittr", + "purrr (>= 1.0.1)", + "rlang (>= 1.1.1)", + "stringr (>= 1.5.0)", + "tibble (>= 2.1.1)", + "tidyselect (>= 1.2.0)", + "utils", + "vctrs (>= 0.5.2)" + ], + "Suggests": [ + "covr", + "data.table", + "knitr", + "readr", + "repurrrsive (>= 1.1.0)", + "rmarkdown", + "testthat (>= 3.0.0)" + ], + "LinkingTo": [ + "cpp11 (>= 0.4.0)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "LazyData": "true", + "RoxygenNote": "7.3.0", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre], Davis Vaughan [aut], Maximilian Girlich [aut], Kevin Ushey [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "tidyselect": { + "Package": "tidyselect", + "Version": "1.2.1", + "Source": "Repository", + "Title": "Select from a Set of Strings", + "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A backend for the selecting functions of the 'tidyverse'. It makes it easy to implement select-like functions in your own packages in a way that is consistent with other 'tidyverse' interfaces for selection.", + "License": "MIT + file LICENSE", + "URL": "https://tidyselect.r-lib.org, https://github.com/r-lib/tidyselect", + "BugReports": "https://github.com/r-lib/tidyselect/issues", + "Depends": [ + "R (>= 3.4)" + ], + "Imports": [ + "cli (>= 3.3.0)", + "glue (>= 1.3.0)", + "lifecycle (>= 1.0.3)", + "rlang (>= 1.0.4)", + "vctrs (>= 0.5.2)", + "withr" + ], + "Suggests": [ + "covr", + "crayon", + "dplyr", + "knitr", + "magrittr", + "rmarkdown", + "stringr", + "testthat (>= 3.1.1)", + "tibble (>= 2.1.3)" + ], + "VignetteBuilder": "knitr", + "ByteCompile": "true", + "Config/testthat/edition": "3", + "Config/Needs/website": "tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.0.9000", + "NeedsCompilation": "yes", + "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut], Posit Software, PBC [cph, fnd]", + "Maintainer": "Lionel Henry ", + "Repository": "RSPM" + }, + "tinytex": { + "Package": "tinytex", + "Version": "0.54", + "Source": "Repository", + "Type": "Package", + "Title": "Helper Functions to Install and Maintain TeX Live, and Compile LaTeX Documents", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\", \"cph\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Christophe\", \"Dervieux\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Devon\", \"Ryan\", role = \"ctb\", email = \"dpryan79@gmail.com\", comment = c(ORCID = \"0000-0002-8549-0971\")), person(\"Ethan\", \"Heinzen\", role = \"ctb\"), person(\"Fernando\", \"Cagua\", role = \"ctb\"), person() )", + "Description": "Helper functions to install and maintain the 'LaTeX' distribution named 'TinyTeX' (), a lightweight, cross-platform, portable, and easy-to-maintain version of 'TeX Live'. This package also contains helper functions to compile 'LaTeX' documents, and install missing 'LaTeX' packages automatically.", + "Imports": [ + "xfun (>= 0.48)" + ], + "Suggests": [ + "testit", + "rstudioapi" + ], + "License": "MIT + file LICENSE", + "URL": "https://github.com/rstudio/tinytex", + "BugReports": "https://github.com/rstudio/tinytex/issues", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "NeedsCompilation": "no", + "Author": "Yihui Xie [aut, cre, cph] (), Posit Software, PBC [cph, fnd], Christophe Dervieux [ctb] (), Devon Ryan [ctb] (), Ethan Heinzen [ctb], Fernando Cagua [ctb]", + "Maintainer": "Yihui Xie ", + "Repository": "CRAN" + }, + "tzdb": { + "Package": "tzdb", + "Version": "0.4.0", + "Source": "Repository", + "Title": "Time Zone Database Information", + "Authors@R": "c( person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = c(\"aut\", \"cre\")), person(\"Howard\", \"Hinnant\", role = \"cph\", comment = \"Author of the included date library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Provides an up-to-date copy of the Internet Assigned Numbers Authority (IANA) Time Zone Database. It is updated periodically to reflect changes made by political bodies to time zone boundaries, UTC offsets, and daylight saving time rules. Additionally, this package provides a C++ interface for working with the 'date' library. 'date' provides comprehensive support for working with dates and date-times, which this package exposes to make it easier for other R packages to utilize. Headers are provided for calendar specific calculations, along with a limited interface for time zone manipulations.", + "License": "MIT + file LICENSE", + "URL": "https://tzdb.r-lib.org, https://github.com/r-lib/tzdb", + "BugReports": "https://github.com/r-lib/tzdb/issues", + "Depends": [ + "R (>= 3.5.0)" + ], + "Suggests": [ + "covr", + "testthat (>= 3.0.0)" + ], + "LinkingTo": [ + "cpp11 (>= 0.4.2)" + ], + "Biarch": "yes", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Davis Vaughan [aut, cre], Howard Hinnant [cph] (Author of the included date library), Posit Software, PBC [cph, fnd]", + "Maintainer": "Davis Vaughan ", + "Repository": "RSPM" + }, + "utf8": { + "Package": "utf8", + "Version": "1.2.4", + "Source": "Repository", + "Title": "Unicode Text Processing", + "Authors@R": "c(person(given = c(\"Patrick\", \"O.\"), family = \"Perry\", role = c(\"aut\", \"cph\")), person(given = \"Kirill\", family = \"M\\u00fcller\", role = \"cre\", email = \"kirill@cynkra.com\"), person(given = \"Unicode, Inc.\", role = c(\"cph\", \"dtc\"), comment = \"Unicode Character Database\"))", + "Description": "Process and print 'UTF-8' encoded international text (Unicode). Input, validate, normalize, encode, format, and display.", + "License": "Apache License (== 2.0) | file LICENSE", + "URL": "https://ptrckprry.com/r-utf8/, https://github.com/patperry/r-utf8", + "BugReports": "https://github.com/patperry/r-utf8/issues", + "Depends": [ + "R (>= 2.10)" + ], + "Suggests": [ + "cli", + "covr", + "knitr", + "rlang", + "rmarkdown", + "testthat (>= 3.0.0)", + "withr" + ], + "VignetteBuilder": "knitr, rmarkdown", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Patrick O. Perry [aut, cph], Kirill Müller [cre], Unicode, Inc. [cph, dtc] (Unicode Character Database)", + "Maintainer": "Kirill Müller ", + "Repository": "RSPM" + }, + "uuid": { + "Package": "uuid", + "Version": "1.2-1", + "Source": "Repository", + "Title": "Tools for Generating and Handling of UUIDs", + "Author": "Simon Urbanek [aut, cre, cph] (https://urbanek.org, ), Theodore Ts'o [aut, cph] (libuuid)", + "Maintainer": "Simon Urbanek ", + "Authors@R": "c(person(\"Simon\", \"Urbanek\", role=c(\"aut\",\"cre\",\"cph\"), email=\"Simon.Urbanek@r-project.org\", comment=c(\"https://urbanek.org\", ORCID=\"0000-0003-2297-1732\")), person(\"Theodore\",\"Ts'o\", email=\"tytso@thunk.org\", role=c(\"aut\",\"cph\"), comment=\"libuuid\"))", + "Depends": [ + "R (>= 2.9.0)" + ], + "Description": "Tools for generating and handling of UUIDs (Universally Unique Identifiers).", + "License": "MIT + file LICENSE", + "URL": "https://www.rforge.net/uuid", + "BugReports": "https://github.com/s-u/uuid/issues", + "NeedsCompilation": "yes", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "vctrs": { + "Package": "vctrs", + "Version": "0.6.5", + "Source": "Repository", + "Title": "Vector Helpers", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = \"aut\"), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = c(\"aut\", \"cre\")), person(\"data.table team\", role = \"cph\", comment = \"Radix sort based on data.table's forder() and their contribution to R's order()\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Defines new notions of prototype and size that are used to provide tools for consistent and well-founded type-coercion and size-recycling, and are in turn connected to ideas of type- and size-stability useful for analysing function interfaces.", + "License": "MIT + file LICENSE", + "URL": "https://vctrs.r-lib.org/, https://github.com/r-lib/vctrs", + "BugReports": "https://github.com/r-lib/vctrs/issues", + "Depends": [ + "R (>= 3.5.0)" + ], + "Imports": [ + "cli (>= 3.4.0)", + "glue", + "lifecycle (>= 1.0.3)", + "rlang (>= 1.1.0)" + ], + "Suggests": [ + "bit64", + "covr", + "crayon", + "dplyr (>= 0.8.5)", + "generics", + "knitr", + "pillar (>= 1.4.4)", + "pkgdown (>= 2.0.1)", + "rmarkdown", + "testthat (>= 3.0.0)", + "tibble (>= 3.1.3)", + "waldo (>= 0.2.0)", + "withr", + "xml2", + "zeallot" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "Language": "en-GB", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut], Lionel Henry [aut], Davis Vaughan [aut, cre], data.table team [cph] (Radix sort based on data.table's forder() and their contribution to R's order()), Posit Software, PBC [cph, fnd]", + "Maintainer": "Davis Vaughan ", + "Repository": "RSPM" + }, + "viridisLite": { + "Package": "viridisLite", + "Version": "0.4.2", + "Source": "Repository", + "Type": "Package", + "Title": "Colorblind-Friendly Color Maps (Lite Version)", + "Date": "2023-05-02", + "Authors@R": "c( person(\"Simon\", \"Garnier\", email = \"garnier@njit.edu\", role = c(\"aut\", \"cre\")), person(\"Noam\", \"Ross\", email = \"noam.ross@gmail.com\", role = c(\"ctb\", \"cph\")), person(\"Bob\", \"Rudis\", email = \"bob@rud.is\", role = c(\"ctb\", \"cph\")), person(\"Marco\", \"Sciaini\", email = \"sciaini.marco@gmail.com\", role = c(\"ctb\", \"cph\")), person(\"Antônio Pedro\", \"Camargo\", role = c(\"ctb\", \"cph\")), person(\"Cédric\", \"Scherer\", email = \"scherer@izw-berlin.de\", role = c(\"ctb\", \"cph\")) )", + "Maintainer": "Simon Garnier ", + "Description": "Color maps designed to improve graph readability for readers with common forms of color blindness and/or color vision deficiency. The color maps are also perceptually-uniform, both in regular form and also when converted to black-and-white for printing. This is the 'lite' version of the 'viridis' package that also contains 'ggplot2' bindings for discrete and continuous color and fill scales and can be found at .", + "License": "MIT + file LICENSE", + "Encoding": "UTF-8", + "Depends": [ + "R (>= 2.10)" + ], + "Suggests": [ + "hexbin (>= 1.27.0)", + "ggplot2 (>= 1.0.1)", + "testthat", + "covr" + ], + "URL": "https://sjmgarnier.github.io/viridisLite/, https://github.com/sjmgarnier/viridisLite/", + "BugReports": "https://github.com/sjmgarnier/viridisLite/issues/", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "no", + "Author": "Simon Garnier [aut, cre], Noam Ross [ctb, cph], Bob Rudis [ctb, cph], Marco Sciaini [ctb, cph], Antônio Pedro Camargo [ctb, cph], Cédric Scherer [ctb, cph]", + "Repository": "CRAN" + }, + "vroom": { + "Package": "vroom", + "Version": "1.6.5", + "Source": "Repository", + "Title": "Read and Write Rectangular Text Data Quickly", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Shelby\", \"Bearrows\", role = \"ctb\"), person(\"https://github.com/mandreyel/\", role = \"cph\", comment = \"mio library\"), person(\"Jukka\", \"Jylänki\", role = \"cph\", comment = \"grisu3 implementation\"), person(\"Mikkel\", \"Jørgensen\", role = \"cph\", comment = \"grisu3 implementation\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "The goal of 'vroom' is to read and write data (like 'csv', 'tsv' and 'fwf') quickly. When reading it uses a quick initial indexing step, then reads the values lazily , so only the data you actually use needs to be read. The writer formats the data in parallel and writes to disk asynchronously from formatting.", + "License": "MIT + file LICENSE", + "URL": "https://vroom.r-lib.org, https://github.com/tidyverse/vroom", + "BugReports": "https://github.com/tidyverse/vroom/issues", + "Depends": [ + "R (>= 3.6)" + ], + "Imports": [ + "bit64", + "cli (>= 3.2.0)", + "crayon", + "glue", + "hms", + "lifecycle (>= 1.0.3)", + "methods", + "rlang (>= 0.4.2)", + "stats", + "tibble (>= 2.0.0)", + "tidyselect", + "tzdb (>= 0.1.1)", + "vctrs (>= 0.2.0)", + "withr" + ], + "Suggests": [ + "archive", + "bench (>= 1.1.0)", + "covr", + "curl", + "dplyr", + "forcats", + "fs", + "ggplot2", + "knitr", + "patchwork", + "prettyunits", + "purrr", + "rmarkdown", + "rstudioapi", + "scales", + "spelling", + "testthat (>= 2.1.0)", + "tidyr", + "utils", + "waldo", + "xml2" + ], + "LinkingTo": [ + "cpp11 (>= 0.2.0)", + "progress (>= 1.2.1)", + "tzdb (>= 0.1.1)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "nycflights13, tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Config/testthat/parallel": "false", + "Copyright": "file COPYRIGHTS", + "Encoding": "UTF-8", + "Language": "en-US", + "RoxygenNote": "7.2.3.9000", + "NeedsCompilation": "yes", + "Author": "Jim Hester [aut] (), Hadley Wickham [aut] (), Jennifer Bryan [aut, cre] (), Shelby Bearrows [ctb], https://github.com/mandreyel/ [cph] (mio library), Jukka Jylänki [cph] (grisu3 implementation), Mikkel Jørgensen [cph] (grisu3 implementation), Posit Software, PBC [cph, fnd]", + "Maintainer": "Jennifer Bryan ", + "Repository": "RSPM" + }, + "withr": { + "Package": "withr", + "Version": "3.0.2", + "Source": "Repository", + "Title": "Run Code 'With' Temporarily Modified Global State", + "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Kirill\", \"Müller\", , \"krlmlr+r@mailbox.org\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevinushey@gmail.com\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Jennifer\", \"Bryan\", role = \"ctb\"), person(\"Richard\", \"Cotton\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "A set of functions to run code 'with' safely and temporarily modified global state. Many of these functions were originally a part of the 'devtools' package, this provides a simple package with limited dependencies to provide access to these functions.", + "License": "MIT + file LICENSE", + "URL": "https://withr.r-lib.org, https://github.com/r-lib/withr#readme", + "BugReports": "https://github.com/r-lib/withr/issues", + "Depends": [ + "R (>= 3.6.0)" + ], + "Imports": [ + "graphics", + "grDevices" + ], + "Suggests": [ + "callr", + "DBI", + "knitr", + "methods", + "rlang", + "rmarkdown (>= 2.12)", + "RSQLite", + "testthat (>= 3.0.0)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "Collate": "'aaa.R' 'collate.R' 'connection.R' 'db.R' 'defer-exit.R' 'standalone-defer.R' 'defer.R' 'devices.R' 'local_.R' 'with_.R' 'dir.R' 'env.R' 'file.R' 'language.R' 'libpaths.R' 'locale.R' 'makevars.R' 'namespace.R' 'options.R' 'par.R' 'path.R' 'rng.R' 'seed.R' 'wrap.R' 'sink.R' 'tempfile.R' 'timezone.R' 'torture.R' 'utils.R' 'with.R'", + "NeedsCompilation": "no", + "Author": "Jim Hester [aut], Lionel Henry [aut, cre], Kirill Müller [aut], Kevin Ushey [aut], Hadley Wickham [aut], Winston Chang [aut], Jennifer Bryan [ctb], Richard Cotton [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Lionel Henry ", + "Repository": "CRAN" + }, + "xfun": { + "Package": "xfun", + "Version": "0.50", + "Source": "Repository", + "Type": "Package", + "Title": "Supporting Functions for Packages Maintained by 'Yihui Xie'", + "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\", \"cph\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Wush\", \"Wu\", role = \"ctb\"), person(\"Daijiang\", \"Li\", role = \"ctb\"), person(\"Xianying\", \"Tan\", role = \"ctb\"), person(\"Salim\", \"Brüggemann\", role = \"ctb\", email = \"salim-b@pm.me\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Christophe\", \"Dervieux\", role = \"ctb\"), person() )", + "Description": "Miscellaneous functions commonly used in other packages maintained by 'Yihui Xie'.", + "Depends": [ + "R (>= 3.2.0)" + ], + "Imports": [ + "grDevices", + "stats", + "tools" + ], + "Suggests": [ + "testit", + "parallel", + "codetools", + "methods", + "rstudioapi", + "tinytex (>= 0.30)", + "mime", + "litedown (>= 0.4)", + "commonmark", + "knitr (>= 1.47)", + "remotes", + "pak", + "rhub", + "renv", + "curl", + "xml2", + "jsonlite", + "magick", + "yaml", + "qs", + "rmarkdown" + ], + "License": "MIT + file LICENSE", + "URL": "https://github.com/yihui/xfun", + "BugReports": "https://github.com/yihui/xfun/issues", + "Encoding": "UTF-8", + "RoxygenNote": "7.3.2", + "VignetteBuilder": "litedown", + "NeedsCompilation": "yes", + "Author": "Yihui Xie [aut, cre, cph] (), Wush Wu [ctb], Daijiang Li [ctb], Xianying Tan [ctb], Salim Brüggemann [ctb] (), Christophe Dervieux [ctb]", + "Maintainer": "Yihui Xie ", + "Repository": "CRAN" + }, + "xml2": { + "Package": "xml2", + "Version": "1.3.6", + "Source": "Repository", + "Title": "Parse XML", + "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"R Foundation\", role = \"ctb\", comment = \"Copy of R-project homepage cached as example\") )", + "Description": "Work with XML files using a simple, consistent interface. Built on top of the 'libxml2' C library.", + "License": "MIT + file LICENSE", + "URL": "https://xml2.r-lib.org/, https://github.com/r-lib/xml2", + "BugReports": "https://github.com/r-lib/xml2/issues", + "Depends": [ + "R (>= 3.6.0)" + ], + "Imports": [ + "cli", + "methods", + "rlang (>= 1.1.0)" + ], + "Suggests": [ + "covr", + "curl", + "httr", + "knitr", + "magrittr", + "mockery", + "rmarkdown", + "testthat (>= 3.0.0)" + ], + "VignetteBuilder": "knitr", + "Config/Needs/website": "tidyverse/tidytemplate", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "SystemRequirements": "libxml2: libxml2-dev (deb), libxml2-devel (rpm)", + "Collate": "'S4.R' 'as_list.R' 'xml_parse.R' 'as_xml_document.R' 'classes.R' 'format.R' 'import-standalone-obj-type.R' 'import-standalone-purrr.R' 'import-standalone-types-check.R' 'init.R' 'nodeset_apply.R' 'paths.R' 'utils.R' 'xml2-package.R' 'xml_attr.R' 'xml_children.R' 'xml_document.R' 'xml_find.R' 'xml_missing.R' 'xml_modify.R' 'xml_name.R' 'xml_namespaces.R' 'xml_node.R' 'xml_nodeset.R' 'xml_path.R' 'xml_schema.R' 'xml_serialize.R' 'xml_structure.R' 'xml_text.R' 'xml_type.R' 'xml_url.R' 'xml_write.R' 'zzz.R'", + "Config/testthat/edition": "3", + "NeedsCompilation": "yes", + "Author": "Hadley Wickham [aut, cre], Jim Hester [aut], Jeroen Ooms [aut], Posit Software, PBC [cph, fnd], R Foundation [ctb] (Copy of R-project homepage cached as example)", + "Maintainer": "Hadley Wickham ", + "Repository": "RSPM" + }, + "xtable": { + "Package": "xtable", + "Version": "1.8-4", + "Source": "Repository", + "Date": "2019-04-08", + "Title": "Export Tables to LaTeX or HTML", + "Authors@R": "c(person(\"David B.\", \"Dahl\", role=\"aut\"), person(\"David\", \"Scott\", role=c(\"aut\",\"cre\"), email=\"d.scott@auckland.ac.nz\"), person(\"Charles\", \"Roosen\", role=\"aut\"), person(\"Arni\", \"Magnusson\", role=\"aut\"), person(\"Jonathan\", \"Swinton\", role=\"aut\"), person(\"Ajay\", \"Shah\", role=\"ctb\"), person(\"Arne\", \"Henningsen\", role=\"ctb\"), person(\"Benno\", \"Puetz\", role=\"ctb\"), person(\"Bernhard\", \"Pfaff\", role=\"ctb\"), person(\"Claudio\", \"Agostinelli\", role=\"ctb\"), person(\"Claudius\", \"Loehnert\", role=\"ctb\"), person(\"David\", \"Mitchell\", role=\"ctb\"), person(\"David\", \"Whiting\", role=\"ctb\"), person(\"Fernando da\", \"Rosa\", role=\"ctb\"), person(\"Guido\", \"Gay\", role=\"ctb\"), person(\"Guido\", \"Schulz\", role=\"ctb\"), person(\"Ian\", \"Fellows\", role=\"ctb\"), person(\"Jeff\", \"Laake\", role=\"ctb\"), person(\"John\", \"Walker\", role=\"ctb\"), person(\"Jun\", \"Yan\", role=\"ctb\"), person(\"Liviu\", \"Andronic\", role=\"ctb\"), person(\"Markus\", \"Loecher\", role=\"ctb\"), person(\"Martin\", \"Gubri\", role=\"ctb\"), person(\"Matthieu\", \"Stigler\", role=\"ctb\"), person(\"Robert\", \"Castelo\", role=\"ctb\"), person(\"Seth\", \"Falcon\", role=\"ctb\"), person(\"Stefan\", \"Edwards\", role=\"ctb\"), person(\"Sven\", \"Garbade\", role=\"ctb\"), person(\"Uwe\", \"Ligges\", role=\"ctb\"))", + "Maintainer": "David Scott ", + "Imports": [ + "stats", + "utils" + ], + "Suggests": [ + "knitr", + "plm", + "zoo", + "survival" + ], + "VignetteBuilder": "knitr", + "Description": "Coerce data to LaTeX and HTML tables.", + "URL": "http://xtable.r-forge.r-project.org/", + "Depends": [ + "R (>= 2.10.0)" + ], + "License": "GPL (>= 2)", + "Repository": "RSPM", + "NeedsCompilation": "no", + "Author": "David B. Dahl [aut], David Scott [aut, cre], Charles Roosen [aut], Arni Magnusson [aut], Jonathan Swinton [aut], Ajay Shah [ctb], Arne Henningsen [ctb], Benno Puetz [ctb], Bernhard Pfaff [ctb], Claudio Agostinelli [ctb], Claudius Loehnert [ctb], David Mitchell [ctb], David Whiting [ctb], Fernando da Rosa [ctb], Guido Gay [ctb], Guido Schulz [ctb], Ian Fellows [ctb], Jeff Laake [ctb], John Walker [ctb], Jun Yan [ctb], Liviu Andronic [ctb], Markus Loecher [ctb], Martin Gubri [ctb], Matthieu Stigler [ctb], Robert Castelo [ctb], Seth Falcon [ctb], Stefan Edwards [ctb], Sven Garbade [ctb], Uwe Ligges [ctb]", + "Encoding": "UTF-8" + }, + "yaml": { + "Package": "yaml", + "Version": "2.3.10", + "Source": "Repository", + "Type": "Package", + "Title": "Methods to Convert R Data to YAML and Back", + "Date": "2024-07-22", + "Suggests": [ + "RUnit" + ], + "Author": "Shawn P Garbett [aut], Jeremy Stephens [aut, cre], Kirill Simonov [aut], Yihui Xie [ctb], Zhuoer Dong [ctb], Hadley Wickham [ctb], Jeffrey Horner [ctb], reikoch [ctb], Will Beasley [ctb], Brendan O'Connor [ctb], Gregory R. Warnes [ctb], Michael Quinn [ctb], Zhian N. Kamvar [ctb], Charlie Gao [ctb]", + "Maintainer": "Shawn Garbett ", + "License": "BSD_3_clause + file LICENSE", + "Description": "Implements the 'libyaml' 'YAML' 1.1 parser and emitter () for R.", + "URL": "https://github.com/vubiostat/r-yaml/", + "BugReports": "https://github.com/vubiostat/r-yaml/issues", + "NeedsCompilation": "yes", + "Repository": "RSPM", + "Encoding": "UTF-8" + }, + "zip": { + "Package": "zip", + "Version": "2.3.2", + "Source": "Repository", + "Title": "Cross-Platform 'zip' Compression", + "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Kuba\", \"Podgórski\", role = \"ctb\"), person(\"Rich\", \"Geldreich\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", + "Description": "Cross-Platform 'zip' Compression Library. A replacement for the 'zip' function, that does not require any additional external tools on any platform.", + "License": "MIT + file LICENSE", + "URL": "https://github.com/r-lib/zip, https://r-lib.github.io/zip/", + "BugReports": "https://github.com/r-lib/zip/issues", + "Suggests": [ + "covr", + "pillar", + "processx", + "R6", + "testthat", + "withr" + ], + "Config/Needs/website": "tidyverse/tidytemplate", + "Config/testthat/edition": "3", + "Encoding": "UTF-8", + "RoxygenNote": "7.2.3", + "NeedsCompilation": "yes", + "Author": "Gábor Csárdi [aut, cre], Kuba Podgórski [ctb], Rich Geldreich [ctb], Posit Software, PBC [cph, fnd]", + "Maintainer": "Gábor Csárdi ", + "Repository": "CRAN" + } + } +} From 0cd5adc2caead82ec56b169c72f9ff8e931366c3 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 5 Mar 2025 07:08:00 +0000 Subject: [PATCH 045/158] recent --- R/tm_a_spiderplot_mdr.R | 19 ++-- R/tm_data_table.R | 16 ++-- R/tm_g_spiderplot.R | 14 +-- R/tm_g_swimlane.R | 187 ++++++++++------------------------------ R/tm_g_waterfall.R | 8 +- R/tm_swimlane_mdr.R | 146 +++++++++++++++++++++++++++++++ R/tm_t_reactable.R | 117 ++++++++++++++++++++++++- R/utils.R | 34 ++++++++ inst/poc_crf2.R | 4 +- 9 files changed, 362 insertions(+), 183 deletions(-) create mode 100644 R/tm_swimlane_mdr.R diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index e7e481c6f..4d4338ce5 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -130,11 +130,19 @@ srv_a_spiderplot_mdr <- function(id, within( plotly_selected_q(), dataname = str2lang(dataname), + time_var = str2lang(time_var), subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + subject_var_char = subject_var, event_var = str2lang(event_var), recent_resp_event = "latest_response_assessment", # todo: whattodo? resp_cols = resp_cols, expr = { + brushed_subjects <- dplyr::filter( + dataname, + time_var %in% plotly_brushed_time, + value_var %in% plotly_brushed_value + )[[subject_var_char]] recent_resp <- dplyr::filter( dataname, event_var %in% recent_resp_event, @@ -239,14 +247,3 @@ srv_a_spiderplot_mdr <- function(id, }) } - - - - -.with_tooltips <- function(...) { - args <- list(...) - lapply(args, function(col) { - col$header <- tags$span(col$name, title = col$name) - return(col) - }) -} diff --git a/R/tm_data_table.R b/R/tm_data_table.R index e103aecd8..437540a11 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -316,14 +316,14 @@ ui_dataset_table <- function(id, choices, selected) { # Server function for the data_table module srv_dataset_table <- function(id, - data, - dataname, - if_filtered, - if_distinct, - dt_args, - dt_options, - server_rendering, - filter_panel_api) { + data, + dataname, + if_filtered, + if_distinct, + dt_args, + dt_options, + server_rendering, + filter_panel_api) { moduleServer(id, function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names")) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index b28595d63..2364a0ee1 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -111,20 +111,10 @@ srv_g_spiderplot <- function(id, time_vals = plotly_selected()$x, value_vals = plotly_selected()$y, expr = { - brushed_subjects <- dplyr::filter( - dataname, time_var %in% time_vals, value_var %in% value_vals - )[[subject_var]] + plotly_brushed_time <- time_vals + plotly_brushed_value <- value_vals } ) }) }) } - - -.with_tooltips <- function(...) { - args <- list(...) - lapply(args, function(col) { - col$header <- tags$span(col$name, title = col$name) - return(col) - }) -} diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 9d41e19f1..37cbddbdf 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -4,7 +4,7 @@ tm_g_swimlane <- function(label = "Swimlane", subject_var, value_var, event_var, - value_var_color, + value_var_color = character(0), value_var_symbol, plot_height = 700) { module( @@ -27,51 +27,31 @@ tm_g_swimlane <- function(label = "Swimlane", ui_g_swimlane <- function(id, height) { ns <- NS(id) - tagList( - fluidRow( - class = "simple-card", - h4("Swim Lane - Duration of Tx"), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), - plotly::plotlyOutput(ns("plot"), height = "100%") - ), - fluidRow( - column( - 6, - class = "simple-card", - tagList( - h4("Multiple Myeloma Response"), - ui_t_reactable(ns("mm_response")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Study Tx Listing"), - ui_t_reactable(ns("tx_listing")) - ) - ) - ) + div( + class = "simple-card", + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), + plotly::plotlyOutput(ns("plot"), height = "100%") ) } srv_g_swimlane <- function(id, - data, - dataname, - time_var, - subject_var, - value_var, - event_var, - value_var_color, - value_var_symbol, - filter_panel_api, - plot_height = 600) { + data, + dataname, + time_var, + subject_var, + value_var, + event_var, + value_var_color, + value_var_symbol, + filter_panel_api) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ req(data()) - adjusted_colors <- .adjust_colors( - x = unique(data()[[dataname]][[value_var]]), - predefined = value_var_color + adjusted_colors <- .color_palette_discrete( + levels = unique(data()[[dataname]][[value_var]]), + color = value_var_color ) + subject_var_label <- c(attr(data()[[dataname]][[subject_var]], "label"), "Subject")[1] + time_var_label <- c(attr(data()[[dataname]][[time_var]], "label"), "Study Day")[1] data() |> within( dataname = str2lang(dataname), @@ -80,28 +60,27 @@ srv_g_swimlane <- function(id, subject_var = str2lang(subject_var), value_var = str2lang(value_var), event_var = str2lang(event_var), + subject_var_label = sprintf("%s:", subject_var_label), + time_var_label = sprintf("%s:", time_var_label), colors = adjusted_colors, symbols = value_var_symbol, height = input$plot_height, filtered_events = c("disposition","response_assessment", "study_drug_administration"), - xaxis_label = "Study Day", - yaxis_label = "Subject", - { + subject_axis_label = subject_var_label, + time_axis_label = time_var_label, + expr = { dataname <- dataname |> mutate(subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), time_var, .fun = max)) |> group_by(subject_var, time_var) |> mutate( tooltip = paste( - "Subject:", subject_var, - "
Study Day:", time_var, - paste( - unique( - sprintf("
%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) - ), - collapse = "" - ) - ) - ) + unique(c( + paste(subject_var_label, subject_var), + paste(time_var_label, time_var), + sprintf("%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) + )), + collapse = "
" + )) p <- dataname |> @@ -127,7 +106,7 @@ srv_g_swimlane <- function(id, showlegend = FALSE ) |> plotly::layout( - xaxis = list(title = xaxis_label), yaxis = list(title = yaxis_label) + xaxis = list(title = time_axis_label), yaxis = list(title = subject_axis_label) ) |> plotly::layout(dragmode = "select") |> plotly::config(displaylogo = FALSE) @@ -135,11 +114,18 @@ srv_g_swimlane <- function(id, ) }) - output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + output$plot <- plotly::renderPlotly({ + plotly_q()$p |> + plotly::event_register("plotly_selected") |> + plotly::event_register("plotly_deselect") # todo: deselect doesn't work + }) - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) + plotly_selected <- reactive({ + plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work + plotly::event_data("plotly_selected", source = "swimlane") + }) - plotly_selected_q <- reactive({ + reactive({ req(plotly_selected()) within( plotly_q(), @@ -148,97 +134,14 @@ srv_g_swimlane <- function(id, subject_var = subject_var, value_var = str2lang(value_var), time_vals = plotly_selected()$x, - value_vals = plotly_selected()$y, - expr = { - brushed_subjects <- dplyr::filter( - dataname, time_var %in% time_vals, value_var %in% value_vals - )[[subject_var]] - } - ) - }) - - mm_response_vars <- c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" - ) - - tx_listing_vars <- c( - "site_name", "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "txnam", - "txrec", "txrecrs", "txd_study_day", "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", - "txdlyrs", "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", "txrmod", - "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", "txetm", "txetmu", "txtm", "txtmu", - "txed_study_day", "infrt", "infrtu", "tximod", "txirmod", "tximae" - ) - - mm_response_q <- reactive({ - within( - plotly_selected_q(), - dataname = str2lang(dataname), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - time_vals = plotly_selected()$x, subject_vals = plotly_selected()$y, - col_defs = mm_response_vars, expr = { - mm_response <- dataname |> - filter(time_var %in% time_vals, subject_var %in% subject_vals) |> - select(all_of(col_defs)) + plotly_brushed_time <- time_vals + plotly_brushed_subject <- subject_vals } ) - }) - - tx_listing_q <- reactive({ - within( - plotly_selected_q(), - dataname = str2lang(dataname), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - time_vals = plotly_selected()$x, - subject_vals = plotly_selected()$y, - col_defs = tx_listing_vars, - expr = { - tx_listing <- dataname |> - filter(time_var %in% time_vals, subject_var %in% subject_vals) |> - select(all_of(col_defs)) - } - ) - - }) - - mm_reactable_q <- srv_t_reactable("mm_response", data = mm_response_q, dataname = "mm_response", selection = NULL) - tx_reactable_q <- srv_t_reactable("tx_listing", data = tx_listing_q, dataname = "tx_listing", selection = NULL) - + }) } -.adjust_colors <- function(x, predefined) { - p <- predefined[names(predefined) %in% x] - p_rgb_num <- col2rgb(p) - p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) - p <- setNames(p_hex, names(p)) - missing_x <- setdiff(x, names(p)) - N <- length(x) - n <- length(p) - m <- N - n - adjusted_colors <- if (m & n) { - current_space <- rgb2hsv(col2rgb(p)) - optimal_color_space <- colorspace::qualitative_hcl(N) - color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) - optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] - furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) - missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] - missing_colors <- setNames(missing_colors, missing_x) - p <- c(p, missing_colors) - } else if (n) { - # todo: generate color palette - hsv( - h = seq(0, by = 1/N, length.out = N + 1), - s = 1, - v = 1 - ) - } else { - p - } -} - diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index cac455bab..d3c106d32 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,8 +1,8 @@ tm_g_waterfall <- function(label = "Waterfall", time_var, subject_var, value_var, event_var, plot_height = 700) { - time_var$dataname <- "ADRS" - subject_var$dataname <- "ADRS" - value_var$dataname <- "ADRS" - event_var$dataname <- "ADRS" + time_var$dataname <- "ADTR" + subject_var$dataname <- "ADTR" + value_var$dataname <- "ADTR" + event_var$dataname <- "ADTR" module( label = label, ui = ui_g_waterfall, diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R new file mode 100644 index 000000000..440dad248 --- /dev/null +++ b/R/tm_swimlane_mdr.R @@ -0,0 +1,146 @@ +tm_g_swimlane_mdr <- function(label = "Swimlane", + dataname, + time_var, + subject_var, + value_var, + event_var, + subtable_labels = c("Multiple Myeloma Response", "Study Tx Listing"), + subtable_cols = list( + c( + "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", + "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" + ), + c( + "site_name", "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "txnam", + "txrec", "txrecrs", "txd_study_day", "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", + "txdlyrs", "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", "txrmod", + "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", "txetm", "txetmu", "txtm", "txtmu", + "txed_study_day", "infrt", "infrtu", "tximod", "txirmod", "tximae" + ) + ), + value_var_color = c( + "DEATH" = "black", + "WITHDRAWAL BY SUBJECT" = "grey", + "PD (Progressive Disease)" = "red", + "SD (Stable Disease)" = "darkorchid4", + "MR (Minimal/Minor Response)" = "sienna4", + "PR (Partial Response)" = "maroon", + "VGPR (Very Good Partial Response)" = "chartreuse4", + "CR (Complete Response)" = "#3a41fc", + "SCR (Stringent Complete Response)" = "midnightblue", + "X Administration Injection" = "goldenrod", + "Y Administration Infusion" = "deepskyblue3", + "Z Administration Infusion" = "darkorchid" + ), + # possible markers https://plotly.com/python/marker-style/ + value_var_symbol = c( + "DEATH" = "circle", + "WITHDRAWAL BY SUBJECT" = "square", + "PD (Progressive Disease)" = "circle", + "SD (Stable Disease)" = "square-open", + "MR (Minimal/Minor Response)" = "star-open", + "PR (Partial Response)" = "star-open", + "VGPR (Very Good Partial Response)" = "star-open", + "CR (Complete Response)" = "star-open", + "SCR (Stringent Complete Response)" = "star-open", + "X Administration Injection" = "line-ns", + "Y Administration Infusion" = "line-ns", + "Z Administration Infusion" = "line-ns" + ), + plot_height = 700) { + checkmate::assert_character(subtable_labels) + checkmate::assert_list(subtable_cols) + checkmate::assert_character(value_var_color) + module( + label = label, + ui = ui_g_swimlane_mdr, + server = srv_g_swimlane_mdr, + datanames = dataname, + ui_args = list(height = plot_height), + server_args = list( + dataname = dataname, + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var, + value_var_color = value_var_color, + value_var_symbol = value_var_symbol, + subtable_labels = subtable_labels, + subtable_cols = subtable_cols, + plot_height = plot_height + ) + ) +} + +ui_g_swimlane_mdr <- function(id, height) { + ns <- NS(id) + tagList( + fluidRow( + class = "simple-card", + h4("Swim Lane - Duration of Tx"), + ui_g_swimlane(ns("plot"), height = height) + ), + fluidRow( + class = "simple-card", + ui_t_reactables(ns("subtables")) + ) + + ) +} +srv_g_swimlane_mdr <- function(id, + data, + dataname, + time_var, + subject_var, + value_var, + event_var, + value_var_color, + value_var_symbol, + subtable_labels, + subtable_cols, + filter_panel_api, + plot_height = 600) { + moduleServer(id, function(input, output, session) { + plotly_selected_q <- srv_g_swimlane( + "plot", + data = data, + dataname = dataname, + time_var = time_var, + subject_var = subject_var, + value_var = value_var, + event_var = event_var, + value_var_color = value_var_color, + value_var_symbol = value_var_symbol, + filter_panel_api = filter_panel_api + ) + + subtable_names <- gsub("[[:space:][:punct:]]+", "_", x = tolower(subtable_labels)) + subtables_q <- reactive({ + req(plotly_selected_q()) + calls <- lapply(seq_along(subtable_names), function(i) { + substitute( + list( + dataname = str2lang(dataname), + subtable_name = str2lang(subtable_names[i]), + subtable_label = subtable_labels[i], + time_var = str2lang(time_var), + subject_var = str2lang(subject_var), + col_defs = subtable_cols[[i]] + ), + expr = { + subtable_name <- dataname |> + dplyr::filter( + time_var %in% plotly_brushed_time, + subject_var %in% plotly_brushed_subject + ) |> + dplyr::select(dplyr::all_of(col_defs)) + attr(subtable_name, "label") <- subtable_label + } + ) + }) + teal.code::eval_code(plotly_selected_q(), as.expression(calls)) + }) + + srv_t_reactables("subtables", data = subtables_q, datanames = subtable_names) + }) +} diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 2b0f941fd..a05cd1d14 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,17 +1,124 @@ #' @param ... () additional [reactable()] arguments #' @export -tm_t_reactables <- function(label = "Table", datanames, transformators = list(), decorators = list(), ...) { +tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), transformators = list(), decorators = list(), ...) { module( label = label, ui = ui_t_reactable, srv = srv_t_reactable, ui_args = list(decorators = decorators), - srv_args = c(list(datanames = datanames, decorators = decorators), rlang::list2(...)), - datanames = datanames, + srv_args = c( + list(datanames = datanames, columns = columns, decorators = decorators), + rlang::list2(...) + ), + datanames = subtables, transformers = transformers ) } +ui_t_reactables <- function(id) { + ns <- NS(id) + div( + class = "simple-card", + uiOutput(ns("subtables")) + ) +} + +srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, ...) { + moduleServer(id, function(input, output, session) { + + all_datanames_r <- reactive({ + req(data()) + names(Filter(is.data.frame, as.list(data()))) + }) + + datanames_r <- reactive({ + req(all_datanames_r()) + df_datanames <- all_datanames_r() + if (identical(datanames, "all")) { + df_datanames + } else { + intersect(datanames, df_datanames) + } + }) |> bindEvent(all_datanames_r()) + + columns_r <- reactive({ + req(datanames_r()) + sapply(datanames_r(), function(dataname) { + if (length(columns[[dataname]])) { + columns()[[dataname]] + } else { + colnames(isolate(data())[[dataname]]) + } + }) + }) |> bindEvent(datanames_r()) + + datalabels_r <- reactive({ + req(datanames_r()) + sapply(datanames_r(), function(dataname) { + datalabel <- attr(isolate(data())[[dataname]], "label") + if (length(datalabel)) datalabel else dataname + }) + }) |> bindEvent(datanames_r()) + + # todo: re-render only if datanames changes + output$subtables <- renderUI({ + if (length(datanames_r()) == 0) return(NULL) + isolate({ + do.call( + tabsetPanel, + c( + list(id = session$ns("reactables")), + lapply( + datanames_r(), + function(dataname) { + tabPanel( + title = datalabels_r()[dataname], + ui_t_reactable(session$ns(dataname)) + ) + } + ) + ) + ) + }) + }) |> bindCache(datanames_r()) + + called_datanames <- reactiveVal() + observeEvent(datanames_r(), { + lapply( + setdiff(datanames_r(), called_datanames()), # call module only once per dataname + function(dataname) srv_t_reactable(dataname, data = data, dataname = dataname, filter_panel_api = filter_panel_api, ...) + ) + called_datanames(union(called_datanames(), datanames_r())) + }) + + + # lapply( + # seq_along(subtables), + # function(i) { + # table_q <- reactive({ + # within( + # plotly_selected_q(), + # dataname = str2lang(dataname), + # subtable_name = subtable_names[i], + # time_var = str2lang(time_var), + # subject_var = str2lang(subject_var), + # col_defs = subtables[[i]], + # expr = { + # subtable_name <- dataname |> + # dplyr::filter( + # time_var %in% plotly_brushed_time, + # subject_var %in% plotly_brushed_subject + # ) |> + # dplyr::select(dplyr::all_of(col_defs)) + # } + # ) + # }) + # srv_t_reactable(subtable_names[i], data = table_q, dataname = subtable_names[i], selection = NULL) + # } + # ) + }) +} + ui_t_reactable <- function(id) { ns <- NS(id) div( @@ -128,4 +235,6 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. } } - +.name_to_id <- function(name) { + gsub("[[:space:][:punct:]]+", "_", x = tolower(name)) +} diff --git a/R/utils.R b/R/utils.R index 1166de42e..a6a48cbf5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -428,3 +428,37 @@ normalize_decorators <- function(decorators) { decorators } } + + +#' Color palette discrete +#' +#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by +#' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels +#' as the rest will be filled automatically. +#' @param levels (`character`) values of possible variable levels +#' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`. +#' @return `character` with hex colors named by `levels`. +.color_palette_discrete <- function(levels, color) { + p <- color[names(color) %in% levels] + p_rgb_num <- col2rgb(p) + p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) + p <- setNames(p_hex, names(p)) + missing_levels <- setdiff(levels, names(p)) + N <- length(levels) + n <- length(p) + m <- N - n + if (m & n) { + current_space <- rgb2hsv(col2rgb(p)) + optimal_color_space <- colorspace::qualitative_hcl(N) + color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) + optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] + furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) + missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] + p <- c(p, setNames(missing_colors, missing_levels)) + } else if (n) { + colorspace::qualitative_hcl(N) + } else { + p + } +} + diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R index 412cb07fb..4560e5ce6 100644 --- a/inst/poc_crf2.R +++ b/inst/poc_crf2.R @@ -2,7 +2,7 @@ library(teal) library(DT) library(labelled) library(reactable) -#pkgload::load_all("teal.modules.general") +pkgload::load_all("teal.modules.general") # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data with_tooltips <- function(...) { @@ -17,7 +17,7 @@ data <- within(teal_data(), { library(dplyr) library(arrow) library(forcats) - data_path <- "/ocean/harbour/CDT70436/GO43979/CSRInterim_roak_upver/dev/data/other/mdr_spotfire/" + data_path <- "PATH/TO/THE/DATA" swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> filter(!is.na(event_result), !is.na(event_study_day)) |> From 1596f2d171b5e631b6a9012924944e74aa4ce8a6 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 5 Mar 2025 03:24:17 -0500 Subject: [PATCH 046/158] update the app code --- inst/poc_crf2.R | 95 +++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 84 insertions(+), 11 deletions(-) diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R index 4560e5ce6..3b74c614b 100644 --- a/inst/poc_crf2.R +++ b/inst/poc_crf2.R @@ -126,6 +126,40 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { summarise(study_day = max(event_study_day)) |> bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) + adverse_events <- swimlane_ds |> + filter(event_type == "adverse_event") |> + select(subject, event_study_day, event_result, aenum, aeraw, icrsgr, ecrsgr, igrnci, egrnci, aeod_study_day, aerd_study_day) |> + mutate( + initial_grade = coalesce(icrsgr, igrnci), + extreme_grade = coalesce(ecrsgr, egrnci), + initial_label = case_when( + !is.na(icrsgr) ~ "Initial ASTCT Grade", + !is.na(igrnci) ~ "Initial NCI CTCAE Grade", + TRUE ~ "Initial Grade" + ), + extreme_label = case_when( + !is.na(ecrsgr) ~ "Most Extreme ASTCT Grade", + !is.na(egrnci) ~ "Most Extreme NCI CTCAE Grade", + TRUE ~ "Most Extreme Grade" + ) + ) |> + mutate( + tooltip = sprintf( + "Subject: %s
Study Day: %d
AENUM: %d
Event of Interest: %s
Primary Adverse Event: %s
Onset Study Day: %d
End Date Study Day: %d
%s: %d
%s: %d", + subject, + event_study_day, + aenum, + event_result, + aeraw, + aeod_study_day, + aerd_study_day, + initial_label, + initial_grade, + extreme_label, + extreme_grade + ) + ) + p <- plotly::plot_ly( source = "swimlane", colors = c( @@ -140,7 +174,13 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { "SCR (Stringent Complete Response)" = "midnightblue", "X Administration Injection" = "goldenrod", "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid" + "Z Administration Infusion" = "darkorchid", + "Cytokine Release Syndrome" = "#f5a733", + "Cytokine Release Syndrome Start" = "#fccf79", + "Cytokine Release Syndrome End" = "#f59505", + "Infection" = "pink", + "Infection Start" = "#f2ced3", + "Infection End" = "#d65668" ), symbols = c( "DEATH" = "circle", @@ -182,6 +222,41 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { line = list(width = 1, color = "grey"), showlegend = FALSE ) |> + plotly::add_segments( + data = adverse_events, + x = ~aeod_study_day, + xend = ~aerd_study_day, + y = ~subject, + yend = ~subject, + color = ~event_result, + line = list(width = 2), + showlegend = TRUE, + name = ~event_result, + legendgroup = ~event_result, + hoverinfo = "none" + ) |> + plotly::add_markers( + data = adverse_events |> filter(event_study_day == aeod_study_day), + x = ~aeod_study_day, + y = ~subject, + text = ~tooltip, + hoverinfo = "text", + color = ~ paste0(event_result, " Start"), + showlegend = TRUE, + legendgroup = ~event_result, + marker = list(size = 6, symbol = "arrow-down") + ) |> + plotly::add_markers( + data = adverse_events |> filter(event_study_day == aerd_study_day), + x = ~aerd_study_day, + y = ~subject, + text = ~tooltip, + hoverinfo = "text", + color = ~ paste0(event_result, " End"), + showlegend = TRUE, + legendgroup = ~event_result, + marker = list(size = 6, symbol = "arrow-down") + ) |> plotly::layout( xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") ) |> @@ -205,11 +280,8 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { swimlane_ds <- data()[["swimlane_ds"]] col_defs <- with_tooltips( subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name", width = 250), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name", width = 250), - source_system_url_link = colDef( - name = "Source System URL Link", + raise_query = colDef( + name = "Raise Query", cell = function(value) { if (!is.na(value) && !is.null(value) && value != "") { htmltools::tags$a(href = value, target = "_blank", "Link") @@ -218,16 +290,17 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { } } ), + visit_name = colDef(name = "Visit Name"), rspdn = colDef(name = "Assessment Performed"), rspd = colDef(name = "Response Date"), rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response", width = 250), + orsp = colDef(name = "Response"), bma = colDef(name = "Best Marrow Aspirate"), bmb = colDef(name = "Best Marrow Biopsy"), comnts = colDef(name = "Comments") ) mm_response <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> + filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y, event_type == "response_assessment") |> select(all_of(names(col_defs))) if (nrow(mm_response) == 0) { return() @@ -394,6 +467,7 @@ tm_spider <- function(label = "Spiderplot", plot_height = 600) { y_title <- selected_event spiderplot_ds_filtered <- spiderplot_ds |> filter(event_type == selected_event) + ticksuffix <- ifelse(grepl("Change from baseline", selected_event), "%", "") p <- plotly::plot_ly(source = "spiderplot", height = height) |> plotly::add_markers( @@ -407,8 +481,8 @@ tm_spider <- function(label = "Spiderplot", plot_height = 600) { ) |> plotly::layout( xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), - yaxis = list(title = ~y_title), - title = ~ paste0(y_title, " Over Time") + yaxis = list(title = ~y_title, ticksuffix = ticksuffix, separatethousands = TRUE, exponentformat = "none"), + title = ~ paste0(paste(strwrap(y_title, width = 50), collapse = "
"), " Over Time") ) |> plotly::layout(dragmode = "select") |> plotly::config(displaylogo = FALSE) @@ -689,4 +763,3 @@ app <- init( ) shinyApp(app$ui, app$server) - From bb0917c1ebb596acf4507a8c9780c4c38986df22 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 5 Mar 2025 16:46:49 +0100 Subject: [PATCH 047/158] WIP waterfall --- R/tm_g_waterfall.R | 219 +++++++++++++++++++++++++++++++-------------- 1 file changed, 152 insertions(+), 67 deletions(-) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index d3c106d32..0548454e4 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,19 +1,28 @@ -tm_g_waterfall <- function(label = "Waterfall", time_var, subject_var, value_var, event_var, plot_height = 700) { - time_var$dataname <- "ADTR" - subject_var$dataname <- "ADTR" - value_var$dataname <- "ADTR" - event_var$dataname <- "ADTR" +tm_g_waterfall <- function(label = "Waterfall", + plot_dataname, + table_datanames, + subject_var, + value_var, + color_var = NULL, + bar_colors = list(), + value_arbitrary_hlines = c(0.2, -0.3), + plot_title = "Waterfall plot", + plot_height = 700) { module( label = label, ui = ui_g_waterfall, server = srv_g_waterfall, - datanames = "all", + datanames = union(plot_dataname, table_datanames), ui_args = list(height = plot_height), server_args = list( - time_var = time_var, + plot_dataname = plot_dataname, + table_datanames = table_datanames, subject_var = subject_var, value_var = value_var, - event_var = event_var + color_var = color_var, + bar_colors = bar_colors, + value_arbitrary_hlines = value_arbitrary_hlines, + plot_title = plot_title ) ) } @@ -25,64 +34,69 @@ ui_g_waterfall <- function(id, height) { class = "simple-card", div( class = "row", - column( - width = 4, - selectInput(ns("select_event"), "Select Y Axis (to remove)", NULL) - ), - column( - width = 4, - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) - ), - column( - width = 4, - sliderInput(ns("color_by"), "Plot Height (px)", 400, 1200, height) - ) + column(width = 6, uiOutput(ns("color_by_output"))), + column(width = 6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) ), - h4("Waterfall"), plotly::plotlyOutput(ns("plot"), height = "100%") ), fluidRow( - h4("All lesions"), - ui_t_reactable(ns("all_lesions")) - + uiOutput(ns("tables")) ) ) } -srv_g_waterfall <- function(id, - data, - dataname, - time_var, - subject_var, - value_var, - event_var, - filter_panel_api, - plot_height = 600) { +srv_g_waterfall <- function(id, + data, + plot_dataname, + table_datanames, + subject_var, + value_var, + color_var, + bar_colors, + filter_panel_api, + value_arbitrary_hlines, + plot_title, + plot_height = 600) { moduleServer(id, function(input, output, session) { - event_levels <- reactive({ - req(data()) - unique(data()[[event_var$dataname]][[event_var$selected]]) - }) - observeEvent(event_levels(), { - updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) + output$color_by_output <- renderUI({ + selectInput(session$ns("color_by"), label = "Color by:", choices = color_var$choices, selected = color_var$selected) }) - + if (length(color_var$choices) > 1) { + shinyjs::show("color_by") + } else { + shinyjs::hide("color_by") + } plotly_q <- reactive({ + req(data(), input$color_by) + adjusted_colors <- .color_palette_discrete( + levels = unique(data()[[plot_dataname]][[input$color_by]]), + color = bar_colors[[input$color_by]] + ) + + subject_var_label <- c( + attr(data()[[plot_dataname]][[subject_var]], "label"), + subject_var + )[1] + + value_var_label <- c( + attr(data()[[plot_dataname]][[value_var]], "label"), + value_var + )[1] + data() |> within( - dataname = str2lang(time_var$dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", time_var$dataname)), - time_var = str2lang(time_var$selected), - subject_var = str2lang(subject_var$selected), - value_var = str2lang(value_var$selected), - event_var = str2lang(event_var$selected), - selected_event = input$select_event, + dataname = str2lang(plot_dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", plot_dataname)), + subject_var = str2lang(subject_var), + value_var = str2lang(value_var), + color_var = str2lang(input$color_by), + colors = adjusted_colors, + value_arbitrary_hlines = value_arbitrary_hlines, + subject_var_label = subject_var_label, + value_var_label = value_var_label, + title = paste0(value_var_label, " (Waterfall plot)"), height = input$plot_height, - xaxis_label = attr(data()[[subject_var$dataname]][[subject_var$selected]], "label"), - yaxis_label = input$select_event, - title = paste0(input$select_event, " Over Time"), expr = { p <- dataname |> - dplyr::filter(event_var %in% selected_event) |> dplyr::mutate( subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE) ) |> @@ -91,23 +105,94 @@ srv_g_waterfall <- function(id, source = "waterfall", height = height ) |> - plotly::add_bars( - x = ~subject_var_ordered, y = ~value_var, - showlegend = FALSE - ) |> - plotly::layout( - xaxis = list(title = xaxis_label), yaxis = list(title = yaxis_label) - ) |> - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) - }, - height = input$plot_height - ) + plotly::add_bars( + x = ~subject_var_ordered, + y = ~value_var, + color = ~color_var, + colors = colors, + text = ~ paste( + subject_var_label, ":", subject_var, + value_var_label, ":", value_var, "
" + ), + hoverinfo = "text" + ) |> + plotly::layout( + shapes = lapply(value_arbitrary_hlines, function(y) { + list( + type = "line", + x0 = 0, + x1 = 1, + xref = "paper", + y0 = y, + y1 = y, + line = list(color = "black", dash = "dot") + ) + }), + title = title, + xaxis = list(title = subject_var_label, tickangle = -45), + yaxis = list(title = value_var_label), + legend = list(title = list(text = "Color by:")), + barmode = "relative", + dragmode = "select" + ) |> + plotly::config(displaylogo = FALSE) + }, + height = input$plot_height + ) }) - + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) - + plotly_selected_q <- reactive({ + req(plotly_selected()) + within( + plotly_q(), + subject_vals = plotly_selected()$x, + value_vals = plotly_selected()$y, + expr = { + # todo: this should use the join keys instead. Probably need to filter visualization data.frame and use its column + plotly_brushed_subjects <- subject_vals + plotly_brushed_value <- value_vals + } + ) + }) + + tables_selected_q <- reactive({ + req(plotly_selected_q()) + teal.code::eval_code( + plotly_selected_q(), + code = as.expression( + lapply( + table_datanames, + function(dataname) { + substitute( + expr = dataname_brushed <- dplyr::filter(dataname, subject_var %in% plotly_brushed_subjects), + env = list( + dataname_brushed = str2lang(sprintf("%s_brushed", dataname)), + dataname = str2lang(dataname), + subject_var = str2lang(subject_var) + ) + ) + } + ) + ) + ) + }) + + output$tables <- renderUI({ + if (length(table_datanames) > 1) { + ui_t_reactables(session$ns("subtables")) + } else if (length(table_datanames) == 1) { + ui_t_reactable(session$ns("subtables")) + } + }) + + + if (length(table_datanames) > 1) { + srv_t_reactables("subtables", data = tables_selected_q, datanames = sprintf("%s_brushed", table_datanames)) + } else if (length(table_datanames) == 1) { + srv_t_reactable("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames)) + } }) -} \ No newline at end of file +} From ef300f5b64e7df53404824906362e9ffe2ec4441 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 6 Mar 2025 07:48:35 +0000 Subject: [PATCH 048/158] update --- R/tm_g_waterfall.R | 16 ++----------- R/tm_t_reactable.R | 60 +++++++++++++++++++++++++++++----------------- 2 files changed, 40 insertions(+), 36 deletions(-) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 0548454e4..0bb8ca74e 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -180,19 +180,7 @@ srv_g_waterfall <- function(id, ) }) - output$tables <- renderUI({ - if (length(table_datanames) > 1) { - ui_t_reactables(session$ns("subtables")) - } else if (length(table_datanames) == 1) { - ui_t_reactable(session$ns("subtables")) - } - }) - - - if (length(table_datanames) > 1) { - srv_t_reactables("subtables", data = tables_selected_q, datanames = sprintf("%s_brushed", table_datanames)) - } else if (length(table_datanames) == 1) { - srv_t_reactable("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames)) - } + output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) + srv_t_reactables("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames)) }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index a05cd1d14..f7851b38a 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,13 +1,13 @@ #' @param ... () additional [reactable()] arguments #' @export -tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), transformators = list(), decorators = list(), ...) { +tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), layout = "grid", transformators = list(), decorators = list(), ...) { module( label = label, ui = ui_t_reactable, srv = srv_t_reactable, ui_args = list(decorators = decorators), srv_args = c( - list(datanames = datanames, columns = columns, decorators = decorators), + list(datanames = datanames, columns = columns, layout = layout, decorators = decorators), rlang::list2(...) ), datanames = subtables, @@ -17,15 +17,11 @@ tm_t_reactables <- function(label = "Table", datanames = "all", columns = list() ui_t_reactables <- function(id) { ns <- NS(id) - div( - class = "simple-card", - uiOutput(ns("subtables")) - ) + uiOutput(ns("subtables"), container = fluidRow) } -srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, ...) { +srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, layout = "grid", ...) { moduleServer(id, function(input, output, session) { - all_datanames_r <- reactive({ req(data()) names(Filter(is.data.frame, as.list(data()))) @@ -63,23 +59,43 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec # todo: re-render only if datanames changes output$subtables <- renderUI({ if (length(datanames_r()) == 0) return(NULL) - isolate({ - do.call( - tabsetPanel, - c( - list(id = session$ns("reactables")), - lapply( - datanames_r(), - function(dataname) { - tabPanel( - title = datalabels_r()[dataname], - ui_t_reactable(session$ns(dataname)) + + if (layout == "grid") { + tagList( + lapply( + datanames_r(), + function(dataname) { + column( + width = if (length(datanames_r()) == 1) 12 else 6, + div( + class = "simple-card", + h4(datalabels_r()[dataname]), + ui_t_reactable(session$ns(dataname)) ) - } - ) + ) + } ) ) - }) + } else if (layout == "tabs") { + isolate({ + do.call( + tabsetPanel, + c( + list(id = session$ns("reactables")), + lapply( + datanames_r(), + function(dataname) { + tabPanel( + title = datalabels_r()[dataname], + ui_t_reactable(session$ns(dataname)) + ) + } + ) + ) + ) + }) + } + }) |> bindCache(datanames_r()) called_datanames <- reactiveVal() From 3536699fbcde2ed10f8ebfba79d9f5eb58df1e31 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 6 Mar 2025 07:53:47 +0000 Subject: [PATCH 049/158] namespace fix --- NAMESPACE | 7 ++++++- R/tm_a_spiderplot_mdr.R | 1 + R/tm_g_spiderplot.R | 1 + R/tm_g_swimlane.R | 1 + R/tm_g_waterfall.R | 1 + R/tm_swimlane_mdr.R | 1 + R/tm_t_reactable.R | 1 - man/dot-color_palette_discrete.Rd | 21 +++++++++++++++++++++ man/dot-make_reactable_columns_call.Rd | 24 ++++++++++++++++++++++++ man/tm_a_pca.Rd | 12 +----------- man/tm_a_regression.Rd | 12 +----------- man/tm_data_table.Rd | 7 +------ man/tm_front_page.Rd | 7 +------ man/tm_g_association.Rd | 7 +------ man/tm_g_bivariate.Rd | 7 +------ man/tm_g_distribution.Rd | 12 +----------- man/tm_g_response.Rd | 7 +------ man/tm_g_scatterplot.Rd | 12 +----------- man/tm_g_scatterplotmatrix.Rd | 12 +----------- man/tm_missing_data.Rd | 12 +----------- man/tm_outliers.Rd | 12 +----------- man/tm_t_crosstable.Rd | 12 +----------- man/tm_variable_browser.Rd | 12 +----------- 23 files changed, 70 insertions(+), 131 deletions(-) create mode 100644 man/dot-color_palette_discrete.Rd create mode 100644 man/dot-make_reactable_columns_call.Rd diff --git a/NAMESPACE b/NAMESPACE index bff1753a2..1c5bcba30 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,6 +12,7 @@ export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) export(tm_a_regression) +export(tm_a_spiderplot_mdr) export(tm_data_table) export(tm_file_viewer) export(tm_front_page) @@ -21,10 +22,14 @@ export(tm_g_distribution) export(tm_g_response) export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) +export(tm_g_spiderplot) +export(tm_g_swimlane) +export(tm_g_swimlane_mdr) +export(tm_g_waterfall) export(tm_missing_data) export(tm_outliers) -export(tm_p_swimlane2) export(tm_t_crosstable) +export(tm_t_reactables) export(tm_variable_browser) import(ggmosaic) import(ggplot2) diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index 4d4338ce5..7627adc00 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -1,3 +1,4 @@ +#' @export tm_a_spiderplot_mdr <- function(label = "Spiderplot", dataname, time_var, diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 2364a0ee1..42a69859c 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -1,3 +1,4 @@ +#' @export tm_g_spiderplot <- function(label = "Spiderplot", time_var, subject_var, diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 37cbddbdf..2405b8f34 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -1,3 +1,4 @@ +#' @export tm_g_swimlane <- function(label = "Swimlane", dataname, time_var, diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 0bb8ca74e..80b240214 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,3 +1,4 @@ +#' @export tm_g_waterfall <- function(label = "Waterfall", plot_dataname, table_datanames, diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R index 440dad248..70e31f944 100644 --- a/R/tm_swimlane_mdr.R +++ b/R/tm_swimlane_mdr.R @@ -1,3 +1,4 @@ +#' @export tm_g_swimlane_mdr <- function(label = "Swimlane", dataname, time_var, diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index f7851b38a..db4ff7ef6 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,4 +1,3 @@ -#' @param ... () additional [reactable()] arguments #' @export tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), layout = "grid", transformators = list(), decorators = list(), ...) { module( diff --git a/man/dot-color_palette_discrete.Rd b/man/dot-color_palette_discrete.Rd new file mode 100644 index 000000000..ce42d0d3a --- /dev/null +++ b/man/dot-color_palette_discrete.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{.color_palette_discrete} +\alias{.color_palette_discrete} +\title{Color palette discrete} +\usage{ +.color_palette_discrete(levels, color) +} +\arguments{ +\item{levels}{(\code{character}) values of possible variable levels} + +\item{color}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by \code{levels}.} +} +\value{ +\code{character} with hex colors named by \code{levels}. +} +\description{ +To specify custom discrete colors to \code{plotly} or \code{ggplot} elements one needs to specify a vector named by +levels of variable used for coloring. This function allows to specify only some or none of the colors/levels +as the rest will be filled automatically. +} diff --git a/man/dot-make_reactable_columns_call.Rd b/man/dot-make_reactable_columns_call.Rd new file mode 100644 index 000000000..22b11063e --- /dev/null +++ b/man/dot-make_reactable_columns_call.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_t_reactable.R +\name{.make_reactable_columns_call} +\alias{.make_reactable_columns_call} +\title{Makes \code{reactable::colDef} call containing: +name = \if{html}{\out{}} +cell = \if{html}{\out{}} +Arguments of \code{\link[reactable:colDef]{reactable::colDef()}} are specified only if necessary} +\usage{ +.make_reactable_columns_call(dataset) +} +\arguments{ +\item{dataset}{(\code{data.frame})} +} +\value{ +named list of \code{colDef} calls +} +\description{ +Makes \code{reactable::colDef} call containing: +name = \if{html}{\out{}} +cell = \if{html}{\out{}} +Arguments of \code{\link[reactable:colDef]{reactable::colDef()}} are specified only if necessary +} +\keyword{internal} diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 5a1d7fdb6..d6d8a3f10 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -74,7 +74,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -194,15 +194,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlY4AygCCjNUtonG6fYPDpKJKAL5dSmioYyp57BX+GboAvJtBuBt8QiKju0fCYuvdlbqkMIlQiagEqRs3ugpgAAoAwv2fB2u7xiOz2jzCpGYGkSolQcAIV3ewIy0HgoM+EyGYmmALeSNEcBEGlBBKJpBhcIReKRugI+SItAIYlBWhYtCg9BEiTpDKZokRNKRKVBKWAwAxAyxI0+AF0ZaUqWAALKCRj8GQAj5gfqiURQYSkTUYxj0KAQL5EVBGsBYNBwT5dQU3OSAp2VUnw8j8UGKlVqjV4LU6vUGh2ut0wA20SJ6XYOFzU53hmkmWjUciMUEAOUcABlc4nHc6Nl0urQTLp2CoM+pNDobLZytdRIUIKx+uh2EsACT1Uo9gmMHSdOZKMCzGVAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkoGlUAQsn9kboFGAAApeQYEsFIvGJGGZNLRUjMDRpUSoOAERF4ym5B56YEEqajMm4jmiOAiDQwkVi47M1nsjl4gglJYEMQwrQsWhQegiE5K2gqzZC+V1TLU3LAYB8kYCsAvF5VNkEgBCAFksABpLAARjJ+LAgwA4q48H7nAB5AI+ACaBP6xuRcnJ8bqktZ5H4MMdYFdHu9vr5QdjSeTMCOtDiPPsTlcFI5iaNyJMtGo5EYMIAco5RgLa3U4wm-v1+rQTLp2CpW+pNDobLYakjRGUIKxBuh2GhUAASFpVDebkWMHR9WZKMAzF5AA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2+ye4VIzA0SVEqDgBGuHxBmWg8DBX0mwzEM0B72RojgIg0YMJxNIsPhiPxyN0BAKRFoBDEYK0LFoUHoIiS9MZzNESNpyNSYNSwGAmMG2NGXwAurKytSwABZQSMfgyQGfMADUSiKDCUhazGMehQCDfIioY1gLBoOBfbpC25yIHOqpkhHkfhgpWq9WavDa3X6w2Ot3umCG2hRPR7BwuGkuiO0ky0ajkRhggByjgAMnmk06XZtut1aCZdOwVJn1JodDZbBUbqIihBWAN0OxlgASBplXuExg6LrzJRgOayoA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -210,7 +201,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY3QKMAABW8QzJsMxJKSyKy6RipGYGnSolQcAIGJJ9Ly7z0ULJizGNOJfNEcBEGmRUplV053N5fJJBFKmwIYmRWhYtCg9BE1w1tC1BwlqvqWUZeWAwBFozFYG+32qPLJACEALJYADSWAAjDTSWAhgBxVx4EPOADygV8AE0yQNLVi5LTU-V5dzyPxke6wN6-YHgyKI8mM5mYJdaPEhfYnK46Xz0xasSZaNRyIxkQA5RxjMXN+optOggYDWgmXTsFTd9SaHQ2Wy1TGicoQVhDdDsf4AEla1X3UsYOn6KyUYGW3yAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 266473299..5e8703be1 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -98,7 +98,7 @@ argument in \code{teal.widgets::optionalSliderInputValMinMax}. }} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -219,15 +219,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJUInVEtWiolYQp+fn1FD0cH7rCmBYcHuYieJD+WzObweqBIoj06xSiTCpGYGkSolQcAIrze5xS0HgBz+ozBSxxulhIg0BwpmNIaIxWNJZN0Hy+P10fwAyt9abotCxaJ8RIgSRDmQR8kRaAQxISwIJUEEANZwUXM840jRwfhyhXK1V4JlkmDCTSROG6ABiAEEADKc5zg9WVEy0ULag4OFxG85dMlyJ04u4PUQdA4IpEounozHYsl42AWomDNXMzWkak81Exxlisms75y7mUjP8xiC+h7EWGvM4iVSmX7dZlisiRL16UnFLAYDJsZgAC6A9KjMIJAIYI5YDs1UC8DIfzkAZ9b3THt+Y4sqfVJuoZpEnqcjpX51d7p16xt9tctcqfpx97vSy6XVoJl07BU5Cj2jgNls5RnKIhQQKw1roOwMwACT1KU0GwowOidBMShgOMA5AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkoGkGhIGqJRFYIIjkcjqFB6HBqDCFGAsHBsWI8SQqWCkUScagSKI9MDMmloqRmBo0qJUHACISicjMg8uboqVNRky-hLdJyRBoYarRcdhaLxcq6iSyRTgVSAuStbotCxaKSRIhFSz9QQSksCGJKWAAEIAWSwAGksABGB365GajRwfgen3+oMh0Owo60OIygBig1GAWczITploUUjMIcLiVEv6yrkOYlWJxol6MJ5fIF2pFYtLRKlsBlcpGCrw7bD5vVwPDLd1A6JhvJHrNatIluttrE9v7juVztd7uBVsYNvoIhOLtobqeuWAwB70zALxeVTbYEGAHFXHhZWAswANJlvrCDLwvuRKwnQc50LE0H2feNQxgJMUyLJxs2AuoTHzMDdHTTNXDXZFyzLUtcP6fpaBMXR2BUchm20OAbFsGokVEMoIFYQZ0HYNBUAAEhaKp2I4zlGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2qSS4VIzA0SVEqDgBDe7wuqWg8EO-zG4OWuN0cJEGkOlKxpHRmOxZPJuk+31+un+AGUfnTdFoWLQviJEKTISyCAUiLQCGIiWBBKhggBrOBilkXWkaOD8eWKlVqvDM8kwYSaKLw3QAMQAggAZLnOCEaqomWhhHWHBwuY0XbrkuTO3H3R6iTqHRHI1H0jFYnHk-GwS3Eobqlla0g03lo2NM8Xktk-eU8qmZgWMIX0faio353GS6Wyg4bcuVkRJBsy06pYDAFPjMAAXUHZSZhBIBHBnLAdhqQXgZH+ckDvveGc9f3HFjTGtN1HNIi9Tidq4ubo9uo2todrjrVX9uIf9+W3W6tBMunYKnI0e0cBstgVOcohFBArA2ug7CzAAJA0ZQwXCjA6F0kxKGAEyDkAA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -235,7 +226,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIZk0tFSMwNGlRKg4AQyeTMZk3vzdPSFqN2SDZbo+SINEitVLLhKpTKNXVKdTaZD6QEafrdFoWLQqSJEGrOSaCCUNgQxHSwAAhACyWAA0lgAIyuk2YvUaOD8X2BkPhyNR5EXWhxRUAMUGowCzg5qdMtCicaRDhc6tl-Q1ckLsvxhNEvSRguFooNkulVfJ8tgiuVI1VeB70ZtOshMc7RtH5LNNN91u1pDtDqdYhdI7dGo9Xp9kPtjEd9BEV09tG9H1ywGAg8WYC+Xyq3bAgwA4q48EqwPmABrs78sEGLxPzkOtZzHZcy0tV8PxTKMYHTTNyycAsILqEwS2g3QczzVxt0xGtqyrIj+n6WgTF0dgVHIDttDgGxbBqDFRDKCBWEGdB2DQVAABIWiqHjeL5RgdD6ZYlDAJYviAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index a23d3d170..e5084fbf8 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -57,7 +57,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -126,13 +126,8 @@ if (interactive()) { \if{html}{\out{}} } \item{example-2}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYBlcmlwvQRIjkcitCxaFBsWI0qI4CINHB+DC6KJSOwpuNgQRfmAAnZHD4AJp+HwKPC6AWOAKOABCACk+QKqgLRZLpYK5X47M5FbKwIMAOKuJXs5wADQFcjkYKReP4xxYEmhwLpDIIaE0JBhAqZ9mJIm8TqsEGNfzq-UDSn6tBMunYKnIzEsOhsthqSNEZQgrEG6HYaFQABIWlUs9nyYwdH1ZkowDMXkA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjAMrk0uF6CJ0ZjMVoWLQoASxGlRHARBo4PwkXRRKR2AtxpCCMCwAE7I4fABNPw+BR4XSixwBRwAIQAUsLRVVRVK5Qqxcq-HZnGqlWBBgBxVzqnnOAAaorkchhGOJ-EuLAkiMhzNZBDQmhISNF7PsFJE3ndVggFpBdX6YaU-VoJl07BU5GYlh0NlsNQxojKEFYg3Q7DQqAAJC0qvmCzTGDo+sslGAll8gA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 048a794df..36a288b5a 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -46,7 +46,7 @@ argument. }} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -99,13 +99,8 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXUY4AEdBWiz2CDFSYmoiRkUIDIBBABEAZQAZH0y6pvTdT1JGdjbGlIUweC8kwdsIulFSdkHqwTjywd0AXl1BgDlnertdLhhBgbAk-1EiQUYCOCXVwdFWMli4TQJdUbBKgF9KgCsiFX8ANZwViiRJhcbGfhwExQYSkfwEfi0UQEfy-f5AkHAaDwUFJOQAXTcZCg9BE-gAjC0khgTMx4OwAJIQExEFa6AgzMDVA5rMAAITGKTscAAHqR2ZzZrzBoL3pUvGS4P4AEzUsK0+lwdgAAwAwkRqIIYFUKTrJVy9TKwLUhbp9YbjVUVebVpyAKwYd0pABsGB9chSDqNJt0AGZXRyuTy8Hy5XIFaTyWH1V5NbBtczWRbBq5Y4MAGJ2kXinNgADi1oAEmNKkpFeSVKh5i1JtMOoM7Em9BTrrtu5TcB2wF2lboVX2G8qVUOqnzRyJw5OB2GlHXoOgWioYjM50l2UlZxk+EIRKJ2SfhGJdxkMqQYP46SR4agoFIb7eMo8oFDGP5yKWbofp+GSDIyMCoOUXhkLoKisowMCeFYEB9mBEoEFAVQSGyjxZBgBwdCBfIAPJxDIsEsuUiGaCQqFgHqmG6Nhui4XA+FgIRt6Bpxd7dueqxTv4TbzEeIE-kiNHQAEXgSPxuhVnYACyjTRvwEnIdw8lKc05S6KI8QQKw-ayUxOEyHo+hMAAfEKPGmEQRCkBAjliGWAAadHIrsjymPkUz2Y5znkNaACasHnmRelwMQED8AFTkubZc6fvpRCRP4ww-mE7IOC4nGVBk3Fzt+v7sjJogACSxBSXL1LAqCLtU6B0BhklJRkrIuYwZVvpVqDRs1tCtch8UyEl660CYujsCo5DMJYOg2LYaRzvpKisE1-VoKgFV5Ck20VaIMg6BUSgfEoYAfASQA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG3dPbyNdAHdaUgALFXYgqFxdECVdXUY4AEdBWiz2CDFSYmoiRkUIDIBBABEAZQAZH10-DCTEREY6pvTdT1JGdh7GlIUweC8k8dsIulFSdnHqwTjy8d0AXl1xgDlnertWuFhxsbAk-1EiQUYCOA3t8dFWMli4TQJdabBKgF9KgArIgqfwAazgrFEiTCs2M-DgJigwlI-gI-FoogI-mBoIhUOA0Hg0KScgAum4yFB6CJ-ABGFpJDAmZjwdgASQgJiIW10BCWYGqZx2YAAQjMUnY4AAPUi8-nLYXjcW-SpeGlwfwAJkZYWZrLg7AABgBhIjUQQwKp0o3ygUmpVgWoS3Sm82Wqpa23bfkAVgwvpSADYMEG5Ck3RarboAMzevkCoV4EUquRq6m0mO6rz62CGzncu3jVzJ8YAMRdUtlRbAAHFHQAJGaVJTq2kqVCrFrzRZ9cZ2DN6OmPVqD+m4PtgAca3RakdtzVaidVEXTkSx+djmNKFvQdAtFQxJYrpK8pLLjJ8IQiUS8q-CMTHjIZUgwfwskio1BQKRP58Zd4oARRh-HIasfT-f8MnGdkYFQcovDIXQVG5RgYE8KwIBHGC5QIKAqgkHl3iyDAzj6KCRQAeTiGRkK5cp0M0EhsLAE18N0QjdGIuBSLAcjn3DfiX0HW9tgXfwO1WC8oKAjEmOgAIvAkUTdAbOwAFlGkTfg5Mw7hVI05pyl0UR4ggVhR2UjiiJkPR9CYAA+CUhNMIgiFICB3LEGsAA0WMxVp3lMfIFlc9zPPIR0AE1kNvGiTLgYgIH4MKPK8mZ+MqDJKlsAAfJyVyvWgTFYfxAOAzgf1EAASWI6QFepYFQddqnQOg8Pk5tdHyvoipK983PIIYlJq1BEza2gOsw1KZGbSlit0dgVCG9RNB0GxbDSFdTJUVhWrGtBUGqvIUkO6rRBkHQKiUP4lDAP4ySAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 2a574f9ea..6833eec2f 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -59,7 +59,7 @@ List names should match the following: \code{c("default", "Bivariate1", "Bivaria For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -187,13 +187,8 @@ if (interactive()) { \if{html}{\out{}} } \item{example-2}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkoKJREQCLQwlYIIjkciGiYYZk0tFSMwNGlRKg4ARiSTkZkHnpgQowFNRtywUjWbpRHARBoYSKxccGUyWUK6tQoPRRTDuQFRUzSLotCx8fQRIh+X95boCCUlgQxDCdYw9SITubaJbNsaTSCoMBgNzedyXi8BW7kcy1c4ABr83TcrCDLyuPCRsBeADyjgAcg4AJoR71YACy2bAAQcgzsgwAjAWi9HSwAmAt+Ox2ABifPj3IAQrmsABpLB1sD9QNyANuyWauD8VVgaOxo2C+UmWhRCcwpuDUYBVzzkmD1nD111G3Q4GU6m06WM4Pbtm5DlTn14A-Isfi4Evi+yp8kxXK6hT9VStqupKlChqPteJJmhaVrAjadpwA60EuhBrKZJ63ojK2fojoGwaFmGBYznGVTcsmaaZgWgx5pWxalhWbaFrRgz9iRYANs2rasZ2PZ9tyu4mvuKF1O+K5cmA3G9ixX7IjARy0HEnL2E4zg4QuS6iboa4bluAlPvxui7v0-S0OS7AqOQ57aHANi2DUSKiGUECsIM6DsGgqAACQtFU7keSKjA6H0sxKGAMwvEAA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEjMmloqRmBo0qJUHACBTKZjMm89JCFGAFqMBTCMVzdKI4CINEjJdLLqz2ZzxXVqFB6FKkQKAlL2aRdFoWCT6CJECKQSrdAQShsCGIkYbGMaRFcbbQ7fsLZaoVBgMABUKBV8vqLvZiOdrnAANEW6AVYQZeVx4ONgLwAeUcADkHABNWMBrAAWQLYACDkGdkGAEZS+WE1WAEylvx2OwAMWFKYFACEi1gANJYZtgfphuSh71yvVwfhasAJpPmsUqky0KKzpHtwajAKuFeUsdcideuqOxGQukMpkKtkRg-c3K8+eBvCnzHTmWQz+3pXvylqhq1Dzjq8oGka6oImab4PpS1q2vakKOs6cCughnqwVymR+gGIxdsGk5hhGZbRqWi7JlUAoZtmealoMxZ1hWVa1t2ZZMYMI6UWArYdl2XF9oOw4CkelonphdQ-pu-JgAJQ6cf+mIwBctBxHy9hOM4hGruuUm6Nuu77qJ74iboR79P0tA0uwKjkDe2hwDYtg1BiohlBArCDOg7BoKgAAkLRVD5vmSowOh9MsShgEsXxAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 599a05777..6827af17b 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -104,7 +104,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -258,13 +258,8 @@ if (interactive()) { \if{html}{\out{}} } \item{example-2}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgbpSDA0hI0vRtCxaGE4L8BnVdFEYZk0tFSMwNGlRKg4ARMdjsZkHnpgQowFNRoywVjqaI4CINDDOdzjmSKVTqdjqFB6FyYYyAlyKaRdFpUeKRIhWX8RboCCUlgQxDDFYw0fQRCdtbRdU9csBgIzmYyXi85GyNXU+XK4PwpUyAOKuPDqkUmWhRD0wgBig1GAVc7Ox-WpToDrDxuQJUSJ6gF5MpAbqtNg9N0tpGLP9sddsp5wLdJMFOfLovFkoZYBl-IVSuNcFVZZdmrNFv1nZNWp1Yi24WtxemYAdiYbFf5oZb0YAGmqF7oYEdaHFCxGo85nS6gyHPcCD9Hc7p43Hj3VGEQCmkDrr5cD8YTiVmhdf8-AvTtXsRRrd9dFA0ls2FDUxQlagvTbOUO0NZVuw3PtR3NPVgQNI0RwHcdMinJkS3tR17xAytyHPIsmSwABZdCT2DZddEvGMNVvOp52pboX3UOAwM-dNv0g38G3-Qtp1LCjFyQ6sqLE+s+1g5taMQnlcNQntZOxTDBxw4c4FNMdLUnG0SJnOddLkjRWMZLwAHlHAAOQcABNJiNVPVj2OvLibz+fp+loExdHYFRyG-bQMTkWwaixUQyggVhBnQdg0FQAASFoqkyrLOUYHQ+lmJQwBmF4gA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rookjMmloqRmBo0qJUHACHiCQTMm89JCFGAFqM2TD8QzRHARBokXyBZdqbT6QyCdQoPR+Ui2QF+bTSLotFiZSJEFyQZLdAQShsCGIkWrGNj6CIrgbaEaPrlgMA2Ry2V8vnJubq6sLlXB+PL2QBxVx4HWSky0KK+pEAMUGowCrh5BP6DPdodYxNypKi5PUoppdNDdSZsBZuidI05IaTXqVgsh3spYsLNalMrlrLAipFqvVFrgWurnr11ttJr7lv1hrEB3CDorizArrTrdrIqjnYTAA1tavdDALrQ4mXY-HnB7PeHI37IaeE0XdCnkxe6owiAU0mcjSrISSyRT83FB8S3gf1nSHSVGx-XQoKpAsJV1aVZWof1u2VXszQ1Add2HKcbWNSFTXNSdRxnTJ53ZSsXTdF9ILrcgb3LdksAAWRwy8Iw3XQ70TXUnzqFcGW6T91DgaC-xzAC4KA1sQLLBcq1otd0IbejpJbYckI7Ji0MFIisMHJSCTwsdCInOArWnO050dSjF2XIzlI0Li2S8AB5RwADkHAATXY3Ury4niH34x8QX6fpaBMXR2BUcgAO0XE5FsGp8VEMoIFYQZ0HYNBUAAEhaKo8vyvlGB0PpliUMAli+IA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 5abf2c7b6..66ce1c672 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -66,7 +66,7 @@ with text placed before the output to put the output into context. For example a into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -189,15 +189,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLpSEGrUuvxQpFC6cAAesKgiSlc3BsZc1AD6b1A2r2utyMugA7rRSAALFTsP6REBKXS6HyhD7IxihJQAX0UECUaFQaJUEL8ECRf3KcMRuj4QhEonKdGapKRSNIMG+El+oVIGPogk01mprMuPO+WhYlKB3wevPUpG+olQcAILJFrL+0Hg5X8KNEEWF6tEcBEGnKxtNCqVKvYEoxUHoIm+BEhRFoBDEQz1-jkkX8AAVYtwMAAZCgSKE+w1I3Ei2O6XG42gmXTsFTkZiWHQ2WwIsm6UTQiCsUbodgEgAk3kileNjB0jFxWKUYCxAF0gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6B6BFR3rHxSSkuGVk53nkBRCbkoqRF0aUJyQ6VupnZnrVwfmAAsgCCAMrjrSVxHRVpPdX9PoP+TEREMNMxs+VdaUoAxLoAwgAiAJLjJ7r8UKRQunAAHrCoIkp3DwbGXNQA+l8oDZPvdHkZdAB3WikAAWKnYQMiICUul0ozO4wAMj9shjsUoAL6KCAAKyIKn+AGs4KxRIiwbYIfw4CYoMJSP8CPxQgR-uTKTS6cBoPB6UC5ABdJRKLQsUQARlxBFhFIIYn+ojgIg0cH4fggaLljFoUHoIi5qto6vFYOAwH8+Kx-klksiBCGoywwyK-hOAHlHAA5BwATV9YHGzgAGv45HJcKjdFqdeR+OUg44sc6ICSlGhULiVDCDWigeUkUm+EIRKJytXhGJS2jdKQYP8JIDQqQTfRBJprEmW7du-9jRWwf8Xj31JzRKg4B6h8PbmDRXpko7Mc68MvhynF6RygeNJqF0vDSvhyq1WJysbTea4Jbb7aHvatwSwK73Z6AOKuHguj+AAQsMWAANJYAqcYJnuK4nmm5SgeBUEwbul5XmiMAcrQ7wbroABioxYlGiaYVhJi0M8erlMRpGuBRw4klecFMcmM4PGOLATlx07MKe86Ls2V5AuuyFgE6ETwWiVHUOQjDlHJClnsJMktsadbJJpCrkVhLY4fJeEiHsqTqSxK5sVeEiMEQgioNxinJECU7PDOgnniJK5ibABGfjuemUbQ8kyEpwUqUJF76Ua8r3vKunqdhuH4aZLjmfBFlohZJIkrQJi6OwKgKbO2iDPGugopeojwhArCjOg7AFgAJN4kTNVqjA6IwJKEkoYCEpKQA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDo1CJYdvqpImiqHAEi0dHKdDwFwpg1bU-4yWb0qojgIg0F1B4Puj2e7DONSg9BEiQI+SItAIYj6v0aPzkpR+AAU4EEeAAZCgSAr4w7LNpHBm6NptWgmXTsFTkZiWHQ2WzlIGiQoQVgAQXQ7E6ABJBLRSjLQYwdIw2s0lGBmgBdIA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -205,7 +196,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTcILRZRAEY2ghLxgjE00TgRDTh+dlqujujFoUHoIk2r1o73OuWAwAUYD6zURl0uVQIAKRWAAsoiqoivAB5RwAOQcAE18bpEQFnAANRFyOS4QFfH7kfi6AC8ulJjmaKIgwyUaFQbRUxQBEDqmR5IVyrJluj4QhEonlquEYmldTqpBgaQkGR2pBB9EEmmsgL1IVNaWB8syaWiZvUG1EqDgmJttoV4VOel5iOR+N9tvZ3tI8sjGk+Xp9yr9epebzE8uBoPBcEhadh4XhIaaKLAaIxWPqAHFXHgaWAAEI4rAAaSwDyZLPDftjnPliMbLbbYaTyZV61ocSDugAYvVmnSlaO9SZaFE-vLZ-PXCPbcNk52d7pRG7wg6WE7ci6om6457vbrR5lA32kcXh0uV9RyIx5Z-v-H7y7W1gQ1XkQIeRclzHL8JxEeUHBcIDdD3P0D2TCRGCIQRUDPH9eWdV1mFvBMH2TJ9YCnIt+jwJC-xkX9aC-GQAMTKCgXuDN7ggpC6hgcdJ3gpxtyXFDd19FDhmGWgTF0dgVG-d1tDgGxbBqZVRDKCBWHqdB2DFAASQRaCqAyvkYHRGGGAYlDAAZLiAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index a569d7dd3..7b8a9c752 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -84,7 +84,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -214,13 +214,8 @@ if (interactive()) { \if{html}{\out{}} } \item{example-2}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWT64bGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0CZVi9lqQ3N0AF5-uFcH8+EIRKIgboIcIxL8BnVdKQYGkJGkGqJUCRRHBEcjkdQoPQ4NQYQowFgxDiIHjdAAFHqkUSUsFIwlY2n04GZNLRUjMDRpbFwAgEwnIzIPPTAylTUZsv6S3R4kQaGFqsXHUXi5Uq3TE0nkuVgAJk7W6LQsWgkkSIJUcg0EEpLAhiGHWxi2+giE6u2jup65YDAeUjRVgF4vKp6sAAIQAslgANJYABMbN0lK8AHlHAA5BwATUpcjk7INyK1Gjg-ApCeTaczeH1KpgR1ocVlugAYoNRgFnJWq6ZaFE6zD+4PXE7Cf0VRW27oojC+QKhTrUGKJSrpbAe+Hpq259WLRrgTWtzvl4SjWSG+b1aQrTa7XAHSfR7oXW6PcCvR9P1f0DBFMlDI9I2jWNfjNZwAA0s0pLBBi8VwwHLEcqyvSdTRQtDHW-DtqE0bspwHIcsINExx1wvsKNnKsF0lZi6mY-p+loExdHYFRyE3bR8XLao-lEMoIFYQZ0HYNBUAAEhaKpZLkvFGB0PpZiUMAZheIA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQzJpaKkZgaNIEuAEUlkzGZN56SF0hajbkguW6YkiDRI7XSy5SmUazW6ClUmnKsABakG3RaFi0SkiRDq3mmgglDYEMRIh2MJ30ERXL20H0fXLAYAqkZqsBfL5VY1gABCAFksABpLAAJm5ujpXgA8o4AHIOACadLkch5psx+o0cH4tNTGezebwJs1MAutDiSt0ADFBqMAs46-XTLQos2kSOx653WT+pra93dFEkcLReLDahpbLNQrYIOY4su8uG7bdZDG-vDxuyebqa2bTrSPbHc64K7L1PdE9b1fUhf1A2DICwzRTIo3POMEyTYFrWcAANfM6SwQYvFcMAa0net7znK1MOwt0AN7ahNAHedR3HfDTRMGciOHWil3rVc5Q4uoOP6fpaBMXR2BUcg920Eka2qEFRDKCBWEGdB2DQVAABIWiqJTlOJRgdD6ZYlDAJYviAA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 7609aa5cf..ff8cedc54 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -97,7 +97,7 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -303,15 +303,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLpSEGrUuvxQpFC6cIWwqCJK84sGxlzUAPpbUDabC0tGugDutKQAFirsR5EgSrrZno1w7NOipMStjEUEDeAGEAPIAJh2unBEKUAF8gUo0KhoSobn5gXMztUnq9dHwhCJRNVCcIxJi3m9SDB9hJ9mEFuQOq1SJSqW9qFB6HBZsl-ABlAhMmTrIikGG3IhdMQRfEcwq4s77FYldSkBmoOAEdkct5HaDwar+WFyrF63SiXnaiXJK0iDSa7W6i26Lk8vm6QXWjS6LQsWjckSIM2uqkEKUyknJf2MQP0ET7CPSggUo7AYAmyH+AC6OciOv8xAsZX8glQi16-jkclw8td9ptcH4xuaJbw9YtMGEmnWemSADEAIIAGQFzjr5tdJlohWb1WHY9cU45QIttc7uiG2MWKuKzEdoi1hZXVINsH7XrApo7p7ejd9dp9GqPzs3HPdvNbAuffoDQbgENbzDN5kyjapY3jRMwNTURHjODMszhMA8wLPw23CPAr3LSs4GrDc7ypB9yBbfkwBwqAq2AkDu2oXsRAXUdx0nEDTFnedByY5cwzXPUCItf4iEYfZ6G3I49zVQ9jxdDlzyNMibxYhtfyfB0X2k98qU-T1vTUv84wAoClLDGCxAg-8EzgJNI1gmTXXTTNr2zFD800jlCzAAAFLkyFLMA7FYLU-LsdwFngXysKLEhMMiMsK0ovCwF4njjOUtSON0AA5RwRxHVKux7Wg+0Ypd8r1Gc51I3RF3HTTkqpfi9VEWgAC8rNEpVd1VA91LfQi5MvJDQzSm1qmIp0T1Y7Tv1-SDDOGkybLMmMLOgpa4IcoaXLQqL21i8j4qomsyo5YiMri3CFtdWj6MvGqJzctjKpK2rCPqt5Go5RgiEufYTHUWJOqgCSeomuz9TOQ1Bqc5CTstFT4bUsHHumsifz0ubLKMx7TOjfSoKs3H4MWRCYdzfNdA87yoAi-aAqCyL-NCmkKFIfC4fvZ8Muy3KOYJQris40rHoqjL7rqzdPvDFo-oB20d2B7r1WR-rIYvVtFM04ixufFWpu5L80dm1bAKugT1vMgzLOslM0wQxyb1Qyn0Op2mr3pxK6eZ8K2aSqWLTOqqebyx6bqKhiheYkX2Kq8W3sl+teKBIFaBMXR2BUZl1W0L4a10F4sVEe4IFYId0HYFEABJvEiKurUYHRAQRJQwHhHMgA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBISqDC0ogT+uLpetHCk1Ky6ALz2Ts62AGTpuu7Rvv6BzgAepMwRUd6x8UkpLhlZOd55hETURIKMqLQEANYyZdGVCckOtUoAxLoAwgAiAJIAypO6-FCkULpwhbCoIkorawbGXNQA+vtQNnur60a6AO60pAAWKuznkSBKutmejXDsEDEpGIrUYigg3wAgtN5gAZQ7ZaFwpQAX3BACsiCoTr1WKI3tdbLd+HATFBhKQTgR+KECCdMdjcaJgNB4PjznIALpKJRoVAIlSPPwQ5bXarvL66PhCESiarS4RiYXfb6kGAnCQnMKrcgdVqkZUq77UKD0ODUar+eYEHUyHZEUhTJ5YghiCKSo2FcXXE6bErqSmiVBwAiGo3fc6svTJfxI2HukXh3Sic0hx3JFMiDRa4Ohj1J3Qms0WmNgeapjS6LQsWimkSIBMFlUEZ1dMTVauMWv0ERU1uu9nXYDAWMw+NgTmcyJ5sCQgDirjwun8ACEALJYADSWAAjGVVxvtwAmfxyOS4fNJzNpuD8S2zheNptSim0HbR3QAMUhsPmzgviYFiYtCFLe1Tfr+riAUa4JJuel66EMoprL6xTMNmQYhmG4aRrAH6jsieAId816VhmFaBrm2FJkW5r3uWWaOp23b1k+TYti67bJMxdZwH2nGDmsw4EeOk7Tn4D6LpEB5bru+5gOusknmAZ4Ac+yYUWBpaKdue5EdB4YwK+77gT+f5qc+wGgXeyQQX+xG6LB4bwQZIJEIwJz0Eh5yof6GFUQ5uHwPecZseGpHphpjE5lhDnGqadGlgxaZVjWvENvp6kcW2crcWlPZ8dlA7UQW5zCbOY7+GJcXNhJ85ScuCmHnJS4yce8lYJCkwNf4WDOHOswAPIAHJ6U5TYuepEVabow2OLCsIWU2RnUJoJm2WZ-41VZM12VBE0IZN4W0AAXnxXneihfroZRsUGRG1xRiFlWZQWEXVBFMV5vdKq0SWjXJZWPEFRlS0FkVXGpV2vH8TlBJCSOFWEWJugzvV8k6S1qk1dNNmNejr3LcZIimZBYNJjteN7Q540qkdRqMEQdwnGSrqRT510Bl9JUPWsT2lqFhPhRRH0UdzNV-fRIvA6xQtJhDuVQyxhX9kqZWI4LKMzpjynSWAnXdR1-VDaNp7029ml43NC3k4ZxMfntttGpTpP2T9tPfOb3wgiz6ixJdUC+Td4s-UF+FI+OTtRSl5HRZh33qZLSXS-lstR97quKzLKsCfDUDlZrU6oxJOsdV1PX68bI1jV7wuMTN1uLTVK1rSTG1k9tIG7ZtNOHfmTnguCtAmLo7AqLqAbaP8Z66J8IqiC8ECsJC6DsHyAAk3iRBvKaMDoYKokoYAopyQA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDilEmFSMwNLdUHACG93ucUtB4Ad-qM4Ut8bpRD8ceD1tSRJjRNjcRTKbpPt9frp-gCaRpdFoWLQviJEOSEeyCJDoWIDkLGCL6CJEtKoTDRMUMsBgKTBv8ALoG0qswgkAhwnlgQSoIIAazg-zkcnh7PODNpcH4JLNFglbsqMGEmkienWADEAIIAGQBzldAZMtFCXoOUdjrkl7y6lJdbMqrGRGVRoXR6lIWJxeMphNgYatZLw+fd-LpVNbldZWfxnJ+Pr5jPBCqVYv9AbVsv262HorgqplGq1QR1erGYCNJsWvoteCtNvtjrAzoTbo9GlTf2ttqgDrHbqD1BDIjTMbjJ-ZSZT3ojr8zbpz+J5t2bQdIk9CFusKJohiFbMlWzaVLWxKXo277vGebYYZ21bsr23K8q2grCrO4pNt27wThq8rEcqc6UScCH4ikK5gI2G6MRRW4AAqfGQlr-HYrDYvxYB2NUgTwHxu7-MQfrSVeB5OhxuhAQG7aDheugAHKONG0ZofiD5PvW6Zvspn6aaZf7sgB2YGaItAAF5zuBRZBCWZZMiyOHvEh9arne+IYQcWFwV2al4f2hEzrRpEGRRC5ytONEqvRmrMbqrH6uuxq6Kask7qU-z7jeh7HspGGacV163mRalGbQoYvhm8XnBZ366FZjG2ecqn4owRDZIkJjqHAbZQaWMHYYxfk+qhjHBfSHZhT5PZfH2l4DrSRGKiRgWUml1G7bR87qicGUBTlm7-DxUBSUVolCYeD1iXAEkUKQTp9aeraaTpemtYGwaNc+P4teZyaWb+3XNt95xtMNo3jcW0HltN5EbHddZzdlrWLeptLoxF634YC0UpXAcXKYdyXHaliXpdqmVsblpq3fdVqCcJ8mve9UnlRjlSVR1-36cpDVNWDZmC6YkMdV1GM9ZUPUAV0XS0CYujsCojzltocA2LY5RnKIhQQKwkboOwMwACT1KUtvUowOidBMShgOMBpAA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -319,7 +310,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokjMmloqRmBo8ag4AQyeTMZk3npIfSFqMeSDZbpRDSpWzIVqROLRJLpeqNbpKdTaUqGdqNLotCxaFSRIg1XyzQQObQuYjIQ7GE76CIrl6fQdwsBgMqRqqwF8vlUTWBBgBxVx4XT0gBCAFksABpLAARh5mbAuYLWAATPS5HJeWbMfqdXB+HTk2m3Y26jALrQ4ordAAxQajALOBvdky0KKtpEjseud3k-oa+umuqsQW5YVRUXqS5GqUyjXy2CD6OLPAbpu23Wau8S4838kWmntgJ3+2O51wV3X5dZU9TkxCRf1A2DYDvTRTJI0vWN40TYEO3TKpszzQsSwzdDKxrMA60nRtmw0OdrQrTCu27XtqE0Ad51HcdCLNadZzbSEF3HF9dFXWV10A7pejSegt0hIURTFQ9jRPWUz3gdsVUojViPvZSnxNQDXypd9rU-A02XA39-yYjUoJ9MCfyDOAQxA-YuPJWCo2TGN6UQuzMSTVNULLcji1LHDCzwtCwCwQYvC8+ksGcFM-AAeQAOSwnjGz47sHz00jdDixxRlGYzZWo2iRHoxc8vJFiMo4pdkpvFLZVEWgAC8rOE7dwl3fdDSkrjZIvJyr1KtKdSRVSj3U1K3ytMtdKGgzLKMtzTNAv0LMg0MYNyOC+oQhNdA8ztsPLDDfPw2qiLvDLlX2gaez7Oj2IYic3PKtjhweriksxU7MUYIgCjSM4uXvMS9wktTpPs3IFXk5yALOvThsfUbwdlCaPy-WaXUUj01t9b8A1-azoI+DbHIUuMdqTHzArLEKwr84KotihLay+pTzperKcuu5FbqK+6SqemcKrejTuJqvLun+9Q4CBndxIPMHush89of6rjlIRvTFdFupUZ09GVr-LGTJx8z8cswmwwc+CXIp5Cqfp2nwoZ6L4sS1m6vZpFOdytyCv7PnXoFnXTCFl7KvemrTR4-p+loExdHYFRCQPbQ4BsWwagxUQyggVhBnQdg0FQAASFoqmLkutUYHQ+mWJQwCWL4gA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index a269c3ee3..ffa2ada65 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -38,7 +38,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -211,15 +211,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLpSEGrUuvyBULpwAB6wqCJK+aSFRrpc1AD6VVA2lQUGxgDutKQAFirszeEgSrq6xOakjFGiHXkFGCbM8H4QY2O0-AnjfmAAIq54uv4AYlhhx2AAknYX-s4AyndgAAq3R-4A4ucfYAByABlngAhQ7hfwAxzPACC7zkuFG6wkRB0jAg8DI2xM6lIREYq3W6wI7AATOEyboKQBGcm03Q0+nhBkk+GIwnUKD0ODUWaJYn+ACyJBYBF6rGeWDgqEE9DoBH8qUJrLW6w5EAkgigUga2JgtFiWJxeIJhJ2DIAzOFLbprdbqUyrUzlabdByuTztvywJ8ZDAoMp5b8ABLckQBiVEP0WUJgRXrZ3rVBEaUczQkT3sAAc1oAbAB2cI5gAM4QALAX6SX6QyqRWqQyixgc+EAJwJsYsOCFPnsc0AVgrfb7FqLDL7Rb7rep5oppZH5Kb4Wz7cy-FQGfNGFLC4rJIwNa34Ub1sbFMbFcbk90jYbW5X-Dg9FIGb3zIwdsPlMXX4-25-C7-PdfzjONRG4MQ5maRZljgE0Ni2RIqUQccERVMYJjINgGk2bYwJgcpYLZIldgOZ4zmeG5nkeZ43meb5nkBEEwUuSEYThVCXVEWgAC89ESFCiLGdxynUPikhcIiV1YLtGFwvFSHYPCCNJUci0QEkiw08IUN0YSORCbYHBcOQVx0CBBDEpSRHYL1RD9ahqGeeB+FoQQYGeDlGCkZ4SDobIFW0qs9NEwzkhXAh-RCBy4AQ3QrNg4kjOccITmhAEHhSQLwmCgzEiSlcvH9TRSDiRI0TxGB2B0qkiyrDTwqIURSF5XSIAqqqq0zOqixXVBGCIEwem2crGEqnStMrEClAAX1SAArIgVAaABrOBWFEQYClsWoFqW1b1pNXaIBWtbdgwqYZmec7pjEZ5NgCxEjpOjh-DAkRRGeN7bt+e7Yw43Qnv2s6iEmG6Pt+L7wfCL1fu2fxrtYbD+AVVJUiUNB11qFQehNZptiGRE+CEd7tiJ4QxDguoYAaCQGlECKghkcoiFIP0LuKSmxjdbk4bAB4GfIRhmefNnpmKMJBN0LQWFoTkScSOgms59ZmgaEophxOnUDgfk0JdeZqmgeBeeuy68ElwlRG5HXn0SK2RA0LWdeVl1udyRJ-Aea2NClmW5bERAJb1-Xxl6RaQha6Xpn9hpRXDinmmAYB4ZBzCzYAXXTlcQ-tm2YozfxOygZ4JDXZ4HyfB7g-1mBhE0AjQpcf6Q7GPEH3cWKkublvBuKfPElS9LXGrpULd0bOVYKNXig1x3RG13WW4N-1YDE17wKhsexkG6hBaxfVBadxel9dTkeY9vnvefKPZdlOBA-NkfTSjlqU9BxHfu7kO49oCPtml6gFlY5h1-gnAoSd17vX8JncEhBU5TA-sjP6W91i5w0P3HY-hSK-HIr8SivxqK-For8eivxGK-FBM8VivxYRVxProWuu9aANzyskFBE9LZX1wlfI+LtTRu15l7B218-Z31EA-L++sf5-0SDfGO0iwHVAgWASG0D07Q12IVMgPRxS-GIE1KGlw+oDR6CjSRnEr4YK9Fo4qujYH6Oas8Yxg1SB0JPow+uIhG7JRQa3Rg7cMFd18aYWgfdYqDwyuwsecZR56ymhAVItATC6HYCoQWOJtCwRMroEYKpRD9AgKwaE6B2AYwACTeHCOUq2jBUSpGmkoMA0105AA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CmlCkmgRw-ri6XrRwpNSsugC89k7OihAAxLoAwgAiAJIAypm6-IFQunAAHrCoIkolpGVGulzUAPr1UDZ1pQbGAO60pAAWKuwd4SBKuroAgtn5ADK9uoxzi1Oz2Vj5y6tb+UoAvqkAVkQqrQDWcKyiY6W2TfxwJlDCpK0E-LSiBK1nF2ut2A0Hgdw6cgAukolGhUMsVIM-BBph0EsVSrgNnwhCJROiccIxMjptNSDBWhJWr9AuRGDUiOTAoxaBUSaTptQoPQ4NR0f58gRaTIGaRdDBmaywhsOVoWLRuXj0XRRKR2RzUaVWpVSMwNNTUHACOqNZqGqC9Il-GsFtKUabSaJeUaxYknSJ9aJDcaZQ7OdzefywPlnRpdHKWYqxIg7X6OQQhucQvjEhGFfQRJ9E7Rk-cGsBgNb5rawJDIXIsfa47p3S64Px0T6wDMAOKuPC6fxYGaZdvhAXOAAa-grvr9MHetBqlqSLkr1emREYz3cDcSDjnY4dJlZ9fRADEZgt8q4qw7Un7R2eOR1tRVdeoPl6jSbTR0LUG5ttY3Gd9Q6eif50gaL5bqaXI8nyVrBqGYoUPwqDnGQogxngYEahGKa6E2AAKMzdgAsjkYSds2ABqBS5HYI7zguCZJmI6JytQghwFmDHgqUBZFt+paQuEuH4TMRHZCR1oUfkVE0dhfhgHhhFieRlHUWAchXguNawXu0G5AAcmRzh2LoxjOLp2S6AA8vuuh6dkjiZHYuQWbpP7VhO-5TiI6Ibqe1bqXGtZhm6sEgT614OhBgbQSGHpimmUYoa5cb0TmjGpvKUbsalnH5oWzb7P4Zb+dWgXkGuMnWm2ikzGRR7VdkACaNHoRy7maNO3nJLR1ZLiu2mzs43W-ru5WHsevlxhe55blN0xTakqS0CYujsCodKPtocA2LYkz2qIIwQKwMzoOwcIACTeOE51OowOiMKkhxKGAhyQkAA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQikiRhLUIL46gcAUkBhopNA8D04DH14LRUKiCSMu7pBWsaFLMvC4aRq034AyTOseu7tzdR82IiCc3Lxt0kNTGlboNu82ycCJC7tBu1NQTAMAANvXtd0ALoR32xuPlbvlmpMxZQFcEgDlcW47sdTuGjAwiaDBrmsSRsddGCW70X5LEuCXpemLQoQJwMoXhWxdcPoaMddKL4vMProjS7LdcK7AzEXc+33q10TXUMTMqSsTBtD3XJsmvTlsiBoHs83bDtqznio2+7oegaw4H8I7K9VPkrsNAM3PUGpvs3-7GMpMH49XZMUf3IDZ-A7XUumtN7kCrtpRCJxkInFQicdCJxMInGwicXCJx8InEIicV42cr551nrQQuAw3JT3vIA0iVseJWyXkbQ0xo6bmwZuQz2dtRB71Ic7F+bsgRMO9s-W+k134hx0hPb+EcfpDCStaTQpAGQnGIMVb6qx6qNTyJyLuZCQFN0GJMCRKVpE7SKiVK4SimqkGwSvXBBcRBFxrsQsujAK6aOCrYyoTVG5VxbhFWxHdFTePvF6ToXIuS0BMLodgKhiYgm0J+JSZROiiEKBAVgzx0DsAhgAEkELQUo6TNaMF+L1JQYAeoRyAA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -227,7 +218,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdy6pk0tFSMwNBjUHACGLxRLcg89EDaX1mhyBirdKIqYqWUDDSI5aIFUq9frdOTKdTNXSjRoeXyBWJELqubbdAQSksCGJobzCR6TgHaEGnrlgMAtU0dWAXi85JzfXUzca4PxodawPUAOKuPC6WlYepeEtVWkBZwADVpaZt+pgR1ocQ19icznTGaIjD2jBz0IcLj7vpMRJHQIAYvVmnWW9y5vrmz7uZLpbLjpbFcqVZl1TSC0MAt7J7RqNjoVPrzJ5fvl+L7VSTwEXSyKPxUEsyKIvTwZ9uVDKEgXzAAFeoKwAWV8DkywLAA1QI-DsJsJ1tf1A2DIFeWoQQ4AjHCY3COMEymZMXiqSDoPqOCfAQrUUICNCML9X4wCg2CmOQ1D0LAOR1wzA1PxnRC-AAOSQ5w7F0YxnEknxdAAeVnXQpJ8RwvDsPwVMki8Mzba8OxEUce2AuphNtLNXVNT9H2tDd9VfR1EI-c0WVDfl6EhQDMP1bCo1wt0w18oigujLYyPjU9KJTazfVs8hc3Azii2rRD6iQhdeMaABNDDLKRYzNE7czx2KuoByHcSx17KrTGnVLdHnRdXGcldgNXLqNx6uY5loExdHYFRsXUTQdBsWwai5UQyggVh6nQdg0FQAASQRaCqNb1sNRgdEYOZpiUMBpheIA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index d1c672c23..eb26df1f9 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -59,7 +59,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -164,15 +164,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEulIQatS6cKGwqCK6-FCkUEr9gwbGXNQA+iNQNsMDUGO6AO60pAAWKuwz0SBKurme3r6toqTE1ESM9fu6UPz8k9CiS2YWmtahtnsQBwehwFE3RE7FEnkm3BIEnYX2iJkuV3YIlKGxhtgAVLlzLQTOwAIzRDAABgArIS8QB2OTUgC6SwAcgBBW7-W4AXyUtx8tBeRl03NEtxg5xYvOMwoIos5v35QVEwDpfOK6ES7AF0Xuj2e9QOEtFCqWyp6HD1jFEGoeTygoh1ulN8uA-gIrGo-hpiuM1owJnUpER9uAjsILrdNNtAaDUhYoaWXp9Gn9IrNgf8UcYofqbJu0HQSxUaz8MpmNR2QoEwjENT4QhEokLf10pBgkxgPNEKgk0wWcxl9XqON0atUzEsOhs31uok2EFYjPQ7DQqAAJN4Negl2DGDprkoORAwGyaUA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsBKMtPzOAB6kzP64ul60cKTUrLoAvPZOzrYAZJm67rG+-ozUUBASUTHe8YkpaS6KEADEugDCACIAkgDKzbpwobCoIrr8UKRQSiNjBsZc1AD6k1A2E6NQ07oA7rSkABYq7IvRIEq6uZ7evhBipMTURIz1pwCCrZ0AMuuML+8nui9YnU+-06SgAvvUAFZEFRzADWcFYogOq1sRmGcBMUGEpDmBH4tFEBDmUJh8MRwGg8CRizkAF0lEo0Kh1iptn4IKdFjVDr8+EIRKIanzhGJ2adTqQYHMYATRCoJAtVssObp6vVaCZdOwVORmJYdDZbMcVaI9hBWE90OwmQASbzRW2iGQ6B5gpRgUG0oA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrquuAAesKgiuvxQpFBK4ZEGxlzUAPoxUDbREVBxugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQFbpQ-PyJ0KJZZhaa1gG25RCVlQHAosEi7KK1idwkEuyTpSbtHewiEBIF27YAVFXmtCbsAIylGAAMAKyPdwDsct8AulkAcgBBHpzHoAXzcM10DVowyM0MYsJ6MFaLDhxhRBDRkMqMNEwD+8OoaBCHDxpT6AyGXUqmLRBKyxPQ1A4dMYogp-UGUFENN0bPxwAUhFY1GFP0Jxh5GBM6lIBwFwCFIrFYAlfMVyqkLHFkt64llGgVqPZSuF2sYuq6YK6ShJWRUeXYPRSugAvGEMrhkQJhGJ3fzfSJRM6oZVSDBEjBYaIVBJkhl2KgWBRSAnItB4AHhQLhXyul0brp2CpyMxLDobFMeqJChBWID0OwSQASeoU9At1aMHSdJQQiBgME-IA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -180,7 +171,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dOAAPWFQRXX4oUiglGLiDYy5qAH1EqBsE2Khk3QB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGXzUjEzEREZhsdrdYawA-LmfFaUAX36AKyIVNIBrOFZRCtzbI2i4EyhhUjSCflpRAjT9w5Oz4Gh4c8ycgAum5oOh8ipiuxFpldABeaK5XCLPhCESieG6VHCMTQgZ1XSkGBpGCvUQqCQZXLZfH9fq0Ey6dgqcjMSw6Gy2Gr40RlCCsQbodhoVAAEhaVRFotEMh0fW2SjAWyBQA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index 68768f6e9..74437cb3d 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -50,7 +50,7 @@ with text placed before the output to put the output into context. For example a adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -198,15 +198,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ugDCAPIATHHV9RVNdcDACmCojLQwLKyJANZwrJ0AumONonAAjokiEOwQjETZ7LV1cooQAL7bAFZEKkMjosUZtlmHx8OsZ9cQJxydG52lL814up3dvf1PnS2bggWhYokaBHyRwIYkS0xEGjg-HYoJ6UHoIkSkOhYnOQXaHzq4zGpQI7E6AAVqFAyG9vmA7KxUHA6Z07Iw4IF4LSwFttko0KhGio8uSIJUUroALz+DK4Fp8IQicEyxXCXEtSqkGCJIiCUh0GRnTWVXR6g20GSJVHS3R0USkMWm52yoKJMKkZgaOHMskml2ummwPQywlvf0u+FwDS2qPe0S+p0Bl3U+hwPyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruJSBLArzAE1J5MIJAIrLAglQQWGgLk8vLFcqcfI-FtnRHY5ZeAjAZgwk0kRDugAYgBBAAyWecU5nppMtFCSNth5Prmnye2FZfLsnEYIgTgEiIPS-SQ2jK9qOuugbuqEnrqKQPrRkmFYpNA8CLp2nznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbYZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4mc7YdKhRLdiSbGcQJvEXpUm5YbQO62g4LhgZUb4Brppr6W+2zbLQJi6OwKjYdB2hwDYtjlOWoiFBArAHug7CChxgi0KUnnTIwOiMNsOxKGAOxjEAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdRkaWpQBfRQgAKyIVNIBrOFZRCtzbfP44EyhhUjSCflpRAjTB4bGJ4Gh4Scy5AF03CAWNNK0WUTSoflFqNoOxdgAxWmpyRnZ1hxcVVEaDiHEywGACjAnWaUJOJyq6wwl1IREYcgxShujFEbQIJSGBDEaVEcBEGjg-HY2NoUHoIhWBNoRKOuQhUJhcIRpnUy2xdweT0xECUILaKmK7FqIVyugAvDLwrhpXwhCJcQrVcI3tK6qQYGkiIJSHQZJNdXVdEaTbQZNcWPLdHRRKQpRBLR7FVA0tFSMwrqJUHACG7PZ7Mq9HRymrC8Baw6TyaRHYng8tA8HQ2HPdQ6WSo2AAmS07oaXSRIgocr3dmPfjCWJHWX6XBGQ3WeF2dCY1yqiGOQBxVx4XRQgBCAFksABpLAARihGOrtY9qYp-AL9SHVfj2ZgS1ocT0Cve9WaAWcy5XdRMtCilMdp-Prhrtb6b93civdbCcAkaOZbh7UYR1nVdXc6kyH0oj9XkSSDftX2zCNYGPUduy6OMkLDW9vhkR1cJ+eDMwgz1+SbW5vxXetmUbBUbmoQRWxolkpk7SEMNjeEqn5AASNdyH4L9SNXYt1woxjmKZVjwQ4zkwG40tbn4sTBOE7C9wPI9HQBF9r3fbMDI9IzdAMvo+loExdD+VR-U0HQbFsGoa1EMoIFYep0HYEFeMEWgqh80lGB0dEeiUMBuhOIA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm52y4JJcKkZgaOHMskml2ummwPQywnvf0u+FwDS2qPe0S+p0Bl3U+hwfyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruNSBLAbzAk1J5MIJAIrLAglQwRGQLk8vLFaqcfI-FtXRHY5ZeAjAZgwk0URDugAYgBBAAyWecU5nppMtDCSNth5PrmnyZ2FZfLsnEYIQTgEiIvS-yQ2jK9qOuugbumEnrqKQPrRkmFapNA8CLp2XznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbaZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4uc7adKhRLdiSbGcQJvEXlUm5YbQO62g4LhgVUb4Brppr6W+Ow7LQJi6OwKjYdB2hwDYtgVOWohFBArAHug7CChxgi0GUnkzIwOiMDsuxKGAuzjEAA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -214,7 +205,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3EpIe0VCV2HVQnldABeJURXCKvhCEREtXa4TfRX1UgwdJEQSkOgyebG+q6C1W2gyB4sVW6OiiUgKiD2v3qqDpGKkZj3USoOAEH3+-1ZL7u3nNJF4O0xqk00ju9ORzbhyPRmP+6jM6kJsCBak53SM5kiRDwzW+wt+klksTumssuBsttciI8hFJ-nVKO8gDirjwunhACEALJYADSWAAjPDcY3m37s7T+GWGhOG6nCzANrR4no1T8Gi1As5N1v6iZaNE6e7r7fXE3myMf8e5A+LbhHAEjYhy3Cuow7qet6x71FkQbRCGQqUhGo7foWcawJe06DgMKYYTGz4AjI7rEYCqH5nB-oih2TyAVurYcu2aqPNQgjdkxnILP2cJ4cmKLVCKAAkO7kPwAHUdula7nR7Gcey3EwnxfJgIJ1ZPKJMniZJhEnmeF7uqCX6Pr+hZmX6Fm6GZIwjLQJi6MCqihpoOg2LYtRNqI5QQKwDToOwkLCYItDVEFVKMDoOJDEoYCDFcQA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index c93e08a55..3f9aed2d5 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -53,7 +53,7 @@ The argument is merged with options variable \code{teal.basic_table_args} and de For more details see the vignette: \code{vignette("custom-basic-table-arguments", package = "teal.widgets")}} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (\code{list} of \code{teal_transform_module}, named \code{list} of \code{teal_transform_module}) optional, @@ -182,15 +182,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6UhBq1Lr8UEG6cAAesKgiSgVFRrpc1AD61VA2VYVQBsYA7rSkABYq7M0RIEq6ujCkBCyinRNTM2OmRIy67Fq6KroEfoSs1OG6-lpheEcoMIf+Uiz+crajEOPjk9OMosDAWgC633NQ4hM6lIK3Yrxmnx+3zS4wAvktwe9Pv5UIxaDAWKwGgBrOCsfy-OaiTwNEQQdgQRhELpghbve5KWFpABWRBUOLxoiG7VstVZ7NxrC5-IgHI4-kRpwiErpUvOqPRmLFdzSSjQqDmKl6fie+XaiT1QVwCIEwjEBr4QlCOuedRgDVIDQIVNEoiCITgNttumowTgeSS-gAwi7ZnZgpU8EtbSUDc0GqVSMwNA1RKg4Dto97mtB4AaZW8pVnbcSRBoDaWM460xmvd7nr76P782AAMr+qu6LQsWgRuCIcLF70EPpsgjmpLdtF9p2j2jjrnNZFgSUE74RTN7A5nY5y-ywK5gG6MFXG3X18aVjRwfgGzcEfaH493M8X54wYSaCp6JIOFyvt9dBWfgZBvA0-2cAC3xMWgSjApIADEAEEABlW1cc9vRhLCoOeeIknjRNk2rdNM0w20c1gH9zlXKNyOeK9SArDsUxrMjAJ9P0A3OdsyyYqdew9Ac6I4kcxwnLsexnMT5zEbkgmXWjfg3XYH23aUwBOQ8Dx3I84FuMB7lw+tGPg84tJEwCP2oL8RANZC0MgodbRguDb0Q1D0Oc3RsNtXyfKWNI0loEw1hUchiO0T17l0R5LwGCBWCQ9B2HVAASbwInS4lGB0Rg0nhCAwFhb4gA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsIykUPQiov64ul60cKTUrLoAvPZOzooQAMS6AMIAIgCSAMpZuvxQQbpwAB6wqCJKpeVGulzUAPoNUDb1ZVAGxgDutKQAFirsHREgSrq6AII5BQAyfbqM80tKAL5pAFZEKq0A1nCsouM9tk38cCZQwqStBPy0ogStewfHp8DQ8GcdcgAukolGhUCsVEM-BAZh1EiUerhpro+EJQvDUcIxNCZjNSDBWg8CIwiKJREEQnAcbiZtRgnBqPD-FkSWT7ME6nhkTTKvCOq0qqRmBpWqJUHACNSabCer89El-OtFuFudLRAyJaR4eqRCKxRKpdLafTGQqwAUNRpdFoWLQOXBECqYUbcQRhvsCGJ4TbGHbKY93bRPf8esBgIqFsqwIDARFRIJ6OqtUkzBZNNYAbops6XbjaPxeU0AIQ29Bxc5BCIqYYyIaiCLUIgSIPcdgARjkEUl-hyZTg4V0-gACgB5Ap5AAaGgHw7Hk+opH8cjSuZp7lIgkYEHYcpDQTkwHzlUBK9X2yROZdOs1cH4TLAWRHjgAcg4AJpO1co+60Wry5IuBeX5EIw1zuHeSQOIBqpGiYtCVLe8IAGKzIsBSuJeNKnlhQHSvEST8oKwoPPq3aYbiHRyveSqflelrJro156uKZFfnS9AMveFq6lqPp+iIjpcuRNJuh6XpJHx9oBmJe5QGGEYbNGsaMQmSbwqmlgZhcWYwS6R4rKWtQcBMugvBgtwaCBDZNi21DtsuulGuum7bruFZQAeR4no5uLnj5MxMeQEGDuazgTrRuYwD+f7Iah6G4bmcEIcFKFoRhubYbimWnmkaS0CYujsCo5DEdoVLLjpzqiKMECsLM6DsGCAAk3gRM16qMDojBpJsShgJsgJAA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIKlKJMKkZgaRKiVBwPquk0paDwBV0lEM6UPE2VcEiDQKxNBrUBoPG+Mms0Wq1MgDKlrTui0LFoTrgiBGIfjBHyOII8olZa+le1DdoTYJKXezOjIL2pWDg2GjLGMaZM3HYHmjG5sezJtTGjg-AVI4IQ1Zc8Wi6X62EmkieglDhc+4PbX4MjXCvPzkvS5MtFCd4lADEAIIAGQLrjjeN7mzOQn0qVgPQyL1Qh9M5-UDYNANDDJw1PJkWRdJC1hXUgU2LP0M0Qg9KlzS1IzAIsk1w1sK0NKsaywk160bZtS3LdtmK7MRCSCPsMIOYd+lHVlxlZadRlnOAFjAJYwPjHD3yZUTMOIqoj1oE8FW-P9H1rE0XzfddP1-f89N0YCgNdCz7nuWgTA6FRyF9TQdBsZYWlEQoIFYL90HYPkABJBFoUpAvBRgdEYe5nggMBHj2IA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -198,7 +189,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBmTS0VIzA0aVEqDgBDR6IhmVOeg++L6zXx33BHLqohxrNIgLFIkZzNZ7JFdUx2NxvLAAXFGl0WhYtFJcEQgopioIJXGBDEgJ1jD1KLgmzNtAt51ywGAfKaArAl0uVVEgnoYslHzMFk01gu1WNit0tH4VPyAEIdehqBxKrGICUZMVRFVqEQJE7uOwAIxyKps-E+MJwQW6fEABQA8gE-AANDT1putjvUUj4uTDGPoxhwUiCRgQdjcl3hOTAONRS7DkdDIUj3TSiVwfh4gnNxwAOQcAE0jcKYzB1rQ4jz7E5nBuR0RGMsx3uPg4XM+YyZaFEu6AgAYvUzQBK4l4cqu6IVtGuisNSuS0lE9LqBscpVlB6JcrA94ev05LYRC25ah8pEYSyWGbsqOL7hqMqStatoiIaRGbqa5qWh8zH6g6XFzlAboEV6Pp+gGQaAqGlgRgsUbESKS5tCmcTprkVQ7BgqwaK++aFsW1BlkO8EimOE5TjOeGCQuS4riZELrvZoqauQn4Nuqzjthem7Xv2t4iCBYEQb+ir-oBbmgeBkExjBEKxauwzDLQJi6OwKjkAymg6DYtg1MKohlBArD1Og7BoKgAAkgi0FU5UVWKjA6IwwwDEoYADJcQA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 28b64606a..9f439c157 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -51,7 +51,7 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} \item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("data-transform-as-shiny-module", package = "teal")}.} +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -113,15 +113,6 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ -<<<<<<< HEAD - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEulLhsrr8UKRQunAAHrCoIkoLSwbGXNQA+jtQNtuLy0a65aQFKuwnUSBKuro+tKJ7b4wfL7owpAILE+VwBQMYNQgr1KRHgUKuMLhfxMUFotzM1C+KLRBQxfwAwgB5ABMXyJxKUAF9FBAlGhUF8VGi-FD5hcmo8-nwhCJPilucIxCzXq9ioctCxaFB6CJDkwiKVRDJhSLXtRpXBMSl-AA1SXSkS6eWKmT+P6vGkWpQ02gmXTsFTkZiWHQ2WzPVmiO4QVgAQXQ7HpABJvFFg0rGDpGDTKUowJSALpAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAoksZwAjoNrv2CsKKoLADWdBBw-ri6XrRwpNSsugC89k7OtgBkGbruMb7+ABakMNQA7rT8UqSikdHecQnJqS6Z2bne+WAAVqIkdOS1MQ2JKQ4tSgDEugDCACIAkgDK07pwAB6wqCK6-FCkUEp0TCwcgSFhcIoQu-sGxlzUAPo3UDZKL3e65aQFKuwvURASl0ugAgrNFgAZT6McFQ4Fg2Z2OzOGHg5GuCAAXyuXSIKkewTgrFE-z2UFsRh2cBMUGEpEeBH4tFEBEeeIJRJJwGg8FJLzkAF0lEo0KhPipaKQ-BAQR8UgCEXwhCJRE1lcIxDKQSDio8tCxaFB6CJHkwiKVRDJtTqQdRjXBqE1-AA1Q3G7bmy0yfwIkFXf1KK60Ey6dgqcjMSw6Gy2IGy3SiX4QVig9DsMUAEm8USzVsYOkYVyxSjAWMFQA}{Open in Shinylive} - \if{html}{\out{}} -======= \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiFbowpAQsdVmt7YxNEJXZRPD9WYPDzSZQeflmflmT07PNAMIA8gBM9WvrSgC+ihBKaKj1KnnszSm6ALz+GbjNfEIidbdPwmIX-ZW6pDCJWhYtCg9BEiSYRGyohkXx+P2oILgfluCjAADUgSCRLoIVCZKjmpUDkSlAdaCZdOwVORmJYdDZbOVvqJChBWABBdDsY4AEkEtFKvOhjB0jAOuyUYF2AF0gA}{Open in Shinylive} \if{html}{\out{}} \if{html}{\out{}} @@ -129,7 +120,6 @@ if (interactive()) { \item{example-2}{ \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dOAAPWFQRXX4oUiglOiYWDlFUFgBrOgg4RQgYuINjLmoAfXyoGyVywt0Ad1pSAAsVdnLcXRAlXV0AQR8AgBka4oxyxERGPsGu3p87O2dhuG5R2KhxybmFpQBfXIArIhUS9LhWUVa12yNouBMoYVISgn5aUQISw+PT8+BoeAu5TkAF03NB0DUVA12DNqgBeaJrXAzPhCESiXQI1HCMQwiDdbqkGAlLQsWhQegiEpMIi1UQyPEEgnUClwaiY3QKMAANTJFKiNLpMi5M26uTFSlytBMunYKnIzEsOhstk6+N0omaEFYPXQ7DQqAAJIJaO0DYb6YwdIxcjslGAdsCgA}{Open in Shinylive} \if{html}{\out{}} ->>>>>>> main \if{html}{\out{}} } } From 3eb068acaca247aa6a20c6f2d9a564b05748889d Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 6 Mar 2025 13:08:54 +0000 Subject: [PATCH 050/158] swimlane with tabs --- R/tm_g_spiderplot.R | 24 +++++++++++------------- R/tm_g_waterfall.R | 11 ++++------- R/tm_swimlane_mdr.R | 11 +++-------- R/tm_t_reactable.R | 22 ++++++++++------------ 4 files changed, 28 insertions(+), 40 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 42a69859c..082cb8213 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -26,20 +26,18 @@ ui_g_spiderplot <- function(id, height) { ns <- NS(id) div( div( - class = "simple-card", - div( - class = "row", - column( - width = 6, - selectInput(ns("select_event"), "Select Y Axis", NULL) - ), - column( - width = 6, - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) - ) + class = "row", + column( + width = 6, + selectInput(ns("select_event"), "Select Y Axis", NULL) ), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) + column( + width = 6, + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + ) + ), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) } diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 80b240214..382d6bf02 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -31,18 +31,15 @@ tm_g_waterfall <- function(label = "Waterfall", ui_g_waterfall <- function(id, height) { ns <- NS(id) tagList( - fluidRow( + div( class = "simple-card", - div( - class = "row", + fluidRow( column(width = 6, uiOutput(ns("color_by_output"))), - column(width = 6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + column(width = 6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)), ), plotly::plotlyOutput(ns("plot"), height = "100%") ), - fluidRow( - uiOutput(ns("tables")) - ) + uiOutput(ns("tables")) ) } srv_g_waterfall <- function(id, diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R index 70e31f944..77842d05a 100644 --- a/R/tm_swimlane_mdr.R +++ b/R/tm_swimlane_mdr.R @@ -76,16 +76,11 @@ tm_g_swimlane_mdr <- function(label = "Swimlane", ui_g_swimlane_mdr <- function(id, height) { ns <- NS(id) tagList( - fluidRow( - class = "simple-card", + div( h4("Swim Lane - Duration of Tx"), ui_g_swimlane(ns("plot"), height = height) ), - fluidRow( - class = "simple-card", - ui_t_reactables(ns("subtables")) - ) - + ui_t_reactables(ns("subtables")) ) } srv_g_swimlane_mdr <- function(id, @@ -142,6 +137,6 @@ srv_g_swimlane_mdr <- function(id, teal.code::eval_code(plotly_selected_q(), as.expression(calls)) }) - srv_t_reactables("subtables", data = subtables_q, datanames = subtable_names) + srv_t_reactables("subtables", data = subtables_q, datanames = subtable_names, layout = "tabs") }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index db4ff7ef6..05fe43086 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -16,7 +16,10 @@ tm_t_reactables <- function(label = "Table", datanames = "all", columns = list() ui_t_reactables <- function(id) { ns <- NS(id) - uiOutput(ns("subtables"), container = fluidRow) + div( + class = "simple-card", + uiOutput(ns("subtables"), container = div, style = "display: flex;") + ) } srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, layout = "grid", ...) { @@ -64,13 +67,11 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec lapply( datanames_r(), function(dataname) { - column( - width = if (length(datanames_r()) == 1) 12 else 6, - div( - class = "simple-card", - h4(datalabels_r()[dataname]), - ui_t_reactable(session$ns(dataname)) - ) + div( + class = "simple-card", + style = if (length(datanames_r()) > 1) "width: 50%" else "width: 100%", + h4(datalabels_r()[dataname]), + ui_t_reactable(session$ns(dataname)) ) } ) @@ -136,10 +137,7 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec ui_t_reactable <- function(id) { ns <- NS(id) - div( - class = "simple-card", - reactable::reactableOutput(ns("table")) - ) + reactable::reactableOutput(ns("table")) } srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, ...) { From cfbabc2d91590615a4ce7100e44f77ad211bb902 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 6 Mar 2025 16:55:12 +0000 Subject: [PATCH 051/158] poc_onco_v1 --- R/tm_g_waterfall.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 382d6bf02..77b1a63c4 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -98,6 +98,7 @@ srv_g_waterfall <- function(id, dplyr::mutate( subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE) ) |> + dplyr::filter(!duplicated(subject_var)) |> # todo: one value for x, y: distinct or summarize(value = foo(value_var)) [foo: summarize_fun] plotly::plot_ly( source = "waterfall", From bea4996e2db5cba264373e4a13a668895ad837e1 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 11 Mar 2025 08:47:12 +0000 Subject: [PATCH 052/158] WIP --- R/tm_a_spiderplot_mdr.R | 2 +- R/tm_data_table.R | 19 +++++----- R/tm_g_waterfall.R | 2 +- R/tm_swimlane_mdr.R | 81 +++++++++++++++-------------------------- R/tm_t_reactable.R | 77 ++++++++++++++++++++++++++------------- R/utils.R | 2 +- inst/poc_crf2.R | 6 +-- 7 files changed, 96 insertions(+), 93 deletions(-) diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R index 7627adc00..6be6b7904 100644 --- a/R/tm_a_spiderplot_mdr.R +++ b/R/tm_a_spiderplot_mdr.R @@ -242,7 +242,7 @@ srv_a_spiderplot_mdr <- function(id, }) observeEvent(all_q(), { - "do nothing" + cat(teal.code::get_code(all_q())) }) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 437540a11..fd93bd213 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -155,7 +155,6 @@ tm_data_table <- function(label = "Data Table", # UI page module ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { ns <- NS(id) - tagList( include_css_files("custom"), teal.widgets::standard_layout( @@ -208,18 +207,17 @@ srv_data_table <- function(id, datanames_r <- reactive({ Filter( - function(name) { - is.data.frame(data()[[name]]) - }, + function(name) is.data.frame(data()[[name]]), if (identical(datanames, "all")) names(data()) else datanames ) }) - output$dataset_table <- renderUI({ + output$data_tables <- renderUI({ + req(datanames_r()) do.call( tabsetPanel, c( - list(id = session$ns("dataname_tab")), + list(id = session$ns("tabs_selected"), selected = datanames_r()[1]), lapply( datanames_r(), function(x) { @@ -258,12 +256,16 @@ srv_data_table <- function(id, ) ) ) - }) + }) |> + bindCache(datanames_r()) |> + bindEvent(datanames_r()) + # server should be run only once modules_run <- reactiveVal() - modules_to_run <- reactive(setdiff(datanames_r(), modules_run())) + modules_to_run <- reactive(setdiff(datanames_r(), isolate(modules_run()))) observeEvent(modules_to_run(), { + print(modules_to_run()) lapply( modules_to_run(), function(dataname) { @@ -288,7 +290,6 @@ srv_data_table <- function(id, # UI function for the data_table module ui_dataset_table <- function(id, choices, selected) { ns <- NS(id) - if (!is.null(selected)) { all_choices <- choices choices <- c(selected, setdiff(choices, selected)) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 77b1a63c4..69c4b3c15 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -180,6 +180,6 @@ srv_g_waterfall <- function(id, }) output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) - srv_t_reactables("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames)) + srv_t_reactables("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames), layout = "grid") }) } diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R index 77842d05a..d5125d99e 100644 --- a/R/tm_swimlane_mdr.R +++ b/R/tm_swimlane_mdr.R @@ -1,24 +1,11 @@ #' @export tm_g_swimlane_mdr <- function(label = "Swimlane", - dataname, + plot_dataname, time_var, subject_var, value_var, event_var, - subtable_labels = c("Multiple Myeloma Response", "Study Tx Listing"), - subtable_cols = list( - c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", - "rspdn", "rspd", "rspd_study_day", "orsp", "bma", "bmb", "comnts" - ), - c( - "site_name", "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "txnam", - "txrec", "txrecrs", "txd_study_day", "date_administered", "cydly", "cydlyrs", "cydlyae", "txdly", - "txdlyrs", "txdlyae", "txpdos", "txpdosu", "frqdv", "txrte", "txform", "txdmod", "txrmod", - "txdmae", "txad", "txadu", "txd", "txstm", "txstmu", "txed", "txetm", "txetmu", "txtm", "txtmu", - "txed_study_day", "infrt", "infrtu", "tximod", "txirmod", "tximae" - ) - ), + listing_datanames = character(0), value_var_color = c( "DEATH" = "black", "WITHDRAWAL BY SUBJECT" = "grey", @@ -49,25 +36,22 @@ tm_g_swimlane_mdr <- function(label = "Swimlane", "Z Administration Infusion" = "line-ns" ), plot_height = 700) { - checkmate::assert_character(subtable_labels) - checkmate::assert_list(subtable_cols) checkmate::assert_character(value_var_color) module( label = label, ui = ui_g_swimlane_mdr, server = srv_g_swimlane_mdr, - datanames = dataname, + datanames = union(plot_dataname, listing_datanames), ui_args = list(height = plot_height), server_args = list( - dataname = dataname, + plot_dataname = plot_dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, event_var = event_var, value_var_color = value_var_color, value_var_symbol = value_var_symbol, - subtable_labels = subtable_labels, - subtable_cols = subtable_cols, + listing_datanames = listing_datanames, plot_height = plot_height ) ) @@ -85,22 +69,21 @@ ui_g_swimlane_mdr <- function(id, height) { } srv_g_swimlane_mdr <- function(id, data, - dataname, + plot_dataname, time_var, subject_var, value_var, event_var, value_var_color, value_var_symbol, - subtable_labels, - subtable_cols, + listing_datanames, filter_panel_api, plot_height = 600) { moduleServer(id, function(input, output, session) { plotly_selected_q <- srv_g_swimlane( "plot", data = data, - dataname = dataname, + dataname = plot_dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, @@ -110,33 +93,27 @@ srv_g_swimlane_mdr <- function(id, filter_panel_api = filter_panel_api ) - subtable_names <- gsub("[[:space:][:punct:]]+", "_", x = tolower(subtable_labels)) - subtables_q <- reactive({ - req(plotly_selected_q()) - calls <- lapply(seq_along(subtable_names), function(i) { - substitute( - list( - dataname = str2lang(dataname), - subtable_name = str2lang(subtable_names[i]), - subtable_label = subtable_labels[i], - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - col_defs = subtable_cols[[i]] - ), - expr = { - subtable_name <- dataname |> - dplyr::filter( - time_var %in% plotly_brushed_time, - subject_var %in% plotly_brushed_subject - ) |> - dplyr::select(dplyr::all_of(col_defs)) - attr(subtable_name, "label") <- subtable_label - } - ) + if (length(listing_datanames)) { + listings_q <- reactive({ + req(plotly_selected_q()) + calls <- lapply(seq_along(listing_datanames), function(i) { + listing_name <- listing_names[i] + listing_label <- attr(plotly_selected_q()[[listing_name]], "label") + substitute( + list( + listing_name = str2lang(listing_name), + listing_selected = str2lang(sprintf("%s_selected", listing_name)), + listing_label = listing_label, + subject_var = str2lang(subject_var) + ), + expr = { + listing_selected <- dplyr::filter(listing_name, subject_var %in% plotly_brushed_subject) + } + ) + }) + teal.code::eval_code(plotly_selected_q(), as.expression(calls)) }) - teal.code::eval_code(plotly_selected_q(), as.expression(calls)) - }) - - srv_t_reactables("subtables", data = subtables_q, datanames = subtable_names, layout = "tabs") + srv_t_reactables("subtables", data = listings_q, datanames = listing_datanames, layout = "tabs") + } }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 05fe43086..2ad8d14df 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -78,21 +78,25 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec ) } else if (layout == "tabs") { isolate({ - do.call( - tabsetPanel, - c( - list(id = session$ns("reactables")), - lapply( - datanames_r(), - function(dataname) { - tabPanel( - title = datalabels_r()[dataname], - ui_t_reactable(session$ns(dataname)) - ) - } + div( + do.call( + tabsetPanel, + c( + list(id = session$ns("reactables")), + lapply( + datanames_r(), + function(dataname) { + tabPanel( + title = datalabels_r()[dataname], + class = "simple-card", + ui_t_reactable(session$ns(dataname)) + ) + } + ) ) ) ) + }) } @@ -147,6 +151,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. reactable_call <- reactive({ default_args <- list( columns = .make_reactable_columns_call(data()[[dataname]]), + resizable = TRUE, onClick = "select", defaultPageSize = 15, wrap = FALSE, @@ -195,7 +200,32 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. .make_reactable_call <- function(dataname, args) { args <- c( - list(data = str2lang(dataname)), + list( + data = str2lang(dataname), + defaultColDef = quote( + colDef( + cell = function(value) { + is_url <- is.character(value) && any( + grepl( + "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", + x = head(value), + perl = TRUE + ) + ) + if (is_url) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") + } else { + "N/A" + } + } else { + value + } + } + ) + + ) + ), args ) do.call(call, c(list(name = "reactable"), args), quote = TRUE) @@ -214,26 +244,21 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. args <- lapply( seq_along(dataset), function(i) { - label <- attr(dataset[[i]], "label") + column <- dataset[[i]] + label <- attr(column, "label") is_labelled <- length(label) == 1 && !is.na(label) && !identical(label, "") - is_url <- is.character(dataset[[i]]) && any( + is_url <- is.character(column) && any( grepl( "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", - x = head(dataset[[i]]), + x = head(column), perl = TRUE ) ) - + # todo: move url formatter to the defaultColDef + width <- max(nchar(head(as.character(column), 100))) * 9 args <- c( - if (is_labelled) list(name = label), - if (is_url) list(cell = quote(function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - }) - ) + if (!is.na(width) && width > 100 && !is_url) list(width = width), + if (is_labelled) list(name = label) ) if (length(args)) { diff --git a/R/utils.R b/R/utils.R index a6a48cbf5..ec25fe476 100644 --- a/R/utils.R +++ b/R/utils.R @@ -455,7 +455,7 @@ normalize_decorators <- function(decorators) { furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] p <- c(p, setNames(missing_colors, missing_levels)) - } else if (n) { + } else if (length(missing_levels)) { colorspace::qualitative_hcl(N) } else { p diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R index 3b74c614b..b025610d5 100644 --- a/inst/poc_crf2.R +++ b/inst/poc_crf2.R @@ -2,7 +2,7 @@ library(teal) library(DT) library(labelled) library(reactable) -pkgload::load_all("teal.modules.general") +pkgload::load_all("~/nest/teal.modules.general") # Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data with_tooltips <- function(...) { @@ -17,7 +17,7 @@ data <- within(teal_data(), { library(dplyr) library(arrow) library(forcats) - data_path <- "PATH/TO/THE/DATA" + data_path <- "PATH/TO/DATA" swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> filter(!is.na(event_result), !is.na(event_study_day)) |> @@ -159,7 +159,7 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { extreme_grade ) ) - + p <- plotly::plot_ly( source = "swimlane", colors = c( From b496a7e108e7e07e1ce7b537d4ac893aa427cb4a Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 11 Mar 2025 11:32:02 +0000 Subject: [PATCH 053/158] swimlane fix shapes and fct order --- R/tm_data_table.R | 33 ++++++++++++--------------------- R/tm_g_swimlane.R | 34 +++++++++++++++++++--------------- R/tm_g_waterfall.R | 35 +++++++++++++++++++++++------------ R/tm_t_reactable.R | 41 +++++++++++++++++------------------------ R/utils.R | 10 ++++++++-- 5 files changed, 79 insertions(+), 74 deletions(-) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index d2236b70a..35f94641b 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -155,20 +155,12 @@ tm_data_table <- function(label = "Data Table", # UI page module ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { ns <- NS(id) - tagList( + bslib::page_fluid( include_css_files("custom"), teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - bslib::page_fluid( - checkboxInput( - ns("if_distinct"), - "Show only distinct rows:", - value = FALSE - ) - ), - bslib::page_fluid( - uiOutput(ns("dataset_table")) - ) + output = bslib::page_fluid( + div(checkboxInput(ns("if_distinct"), "Show only distinct rows:", value = FALSE)), + uiOutput(ns("data_tables")) ), pre_output = pre_output, post_output = post_output @@ -213,12 +205,12 @@ srv_data_table <- function(id, list(id = session$ns("tabs_selected"), selected = datanames_r()[1]), lapply( datanames_r(), - function(x) { - dataset <- isolate(data()[[x]]) + function(dataname) { + dataset <- isolate(data()[[dataname]]) choices <- names(dataset) labels <- vapply( dataset, - function(x) ifelse(is.null(attr(x, "label")), "", attr(x, "label")), + function(column) ifelse(is.null(attr(column, "label")), "", attr(column, "label")), character(1) ) names(choices) <- ifelse( @@ -226,17 +218,17 @@ srv_data_table <- function(id, choices, paste(choices, labels, sep = ": ") ) - variables_selected <- if (!is.null(variables_selected[[x]])) { - variables_selected[[x]] + variables_selected <- if (!is.null(variables_selected[[dataname]])) { + variables_selected[[dataname]] } else { utils::head(choices) } tabPanel( - title = x, + title = dataname, bslib::layout_columns( col_widths = 12, - ui_data_table( - id = session$ns(x), + ui_dataset_table( + id = session$ns(dataname), choices = choices, selected = variables_selected ) @@ -255,7 +247,6 @@ srv_data_table <- function(id, modules_run <- reactiveVal() modules_to_run <- reactive(setdiff(datanames_r(), isolate(modules_run()))) observeEvent(modules_to_run(), { - print(modules_to_run()) lapply( modules_to_run(), function(dataname) { diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 2405b8f34..10bb57417 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -51,6 +51,10 @@ srv_g_swimlane <- function(id, levels = unique(data()[[dataname]][[value_var]]), color = value_var_color ) + adjusted_symbols <- .shape_palette_discrete( + levels = unique(data()[[dataname]][[value_var]]), + symbol = value_var_symbol + ) subject_var_label <- c(attr(data()[[dataname]][[subject_var]], "label"), "Subject")[1] time_var_label <- c(attr(data()[[dataname]][[time_var]], "label"), "Study Day")[1] data() |> @@ -64,15 +68,16 @@ srv_g_swimlane <- function(id, subject_var_label = sprintf("%s:", subject_var_label), time_var_label = sprintf("%s:", time_var_label), colors = adjusted_colors, - symbols = value_var_symbol, + symbols = adjusted_symbols, height = input$plot_height, - filtered_events = c("disposition","response_assessment", "study_drug_administration"), subject_axis_label = subject_var_label, time_axis_label = time_var_label, expr = { - dataname <- dataname |> - mutate(subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), time_var, .fun = max)) |> - group_by(subject_var, time_var) |> + # todo: forcats::fct_reorder didn't work. + levels <- with(dataname, tapply(time_var, subject_var, max)) |> sort() + dataname <- dataname %>% + mutate(subject_var_ordered = factor(subject_var, levels = names(levels))) %>% + group_by(subject_var, time_var) %>% mutate( tooltip = paste( unique(c( @@ -84,31 +89,27 @@ srv_g_swimlane <- function(id, )) - p <- dataname |> - dplyr::filter( - event_var %in% filtered_events, - !is.na(time_var) - ) |> + p <- dataname %>% plotly::plot_ly( source = "swimlane", colors = colors, symbols = symbols, height = height - ) |> + ) %>% plotly::add_markers( x = ~time_var, y = ~subject_var_ordered, color = ~value_var, symbol = ~value_var, text = ~tooltip, hoverinfo = "text" - ) |> + ) %>% plotly::add_segments( x = ~0, xend = ~study_day, y = ~subject_var_ordered, yend = ~subject_var_ordered, data = dataname |> group_by(subject_var_ordered) |> summarise(study_day = max(time_var)), line = list(width = 1, color = "grey"), showlegend = FALSE - ) |> + ) %>% plotly::layout( xaxis = list(title = time_axis_label), yaxis = list(title = subject_axis_label) - ) |> + ) %>% plotly::layout(dragmode = "select") |> plotly::config(displaylogo = FALSE) } @@ -126,6 +127,10 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) + observeEvent(plotly_q(), { + cat(paste(collapse = "\n", teal.code::get_code(plotly_q()))) + }) + reactive({ req(plotly_selected()) within( @@ -142,7 +147,6 @@ srv_g_swimlane <- function(id, } ) }) - }) } diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 69c4b3c15..210666696 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -8,22 +8,26 @@ tm_g_waterfall <- function(label = "Waterfall", bar_colors = list(), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = 700) { + plot_height = 700, + ...) { module( label = label, ui = ui_g_waterfall, server = srv_g_waterfall, datanames = union(plot_dataname, table_datanames), ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - table_datanames = table_datanames, - subject_var = subject_var, - value_var = value_var, - color_var = color_var, - bar_colors = bar_colors, - value_arbitrary_hlines = value_arbitrary_hlines, - plot_title = plot_title + server_args = c( + list( + plot_dataname = plot_dataname, + table_datanames = table_datanames, + subject_var = subject_var, + value_var = value_var, + color_var = color_var, + bar_colors = bar_colors, + value_arbitrary_hlines = value_arbitrary_hlines, + plot_title = plot_title + ), + list(...) ) ) } @@ -53,7 +57,8 @@ srv_g_waterfall <- function(id, filter_panel_api, value_arbitrary_hlines, plot_title, - plot_height = 600) { + plot_height = 600, + ...) { moduleServer(id, function(input, output, session) { output$color_by_output <- renderUI({ selectInput(session$ns("color_by"), label = "Color by:", choices = color_var$choices, selected = color_var$selected) @@ -180,6 +185,12 @@ srv_g_waterfall <- function(id, }) output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) - srv_t_reactables("subtables", data = tables_selected_q, dataname = sprintf("%s_brushed", table_datanames), layout = "grid") + srv_t_reactables( + "subtables", + data = tables_selected_q, + dataname = sprintf("%s_brushed", table_datanames), + layout = "accordion", + ... + ) }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 2ad8d14df..63b12a0d4 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -16,10 +16,7 @@ tm_t_reactables <- function(label = "Table", datanames = "all", columns = list() ui_t_reactables <- function(id) { ns <- NS(id) - div( - class = "simple-card", - uiOutput(ns("subtables"), container = div, style = "display: flex;") - ) + uiOutput(ns("subtables"), container = bslib::page_fluid) } srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, layout = "grid", ...) { @@ -76,28 +73,24 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec } ) ) - } else if (layout == "tabs") { - isolate({ - div( - do.call( - tabsetPanel, - c( - list(id = session$ns("reactables")), - lapply( - datanames_r(), - function(dataname) { - tabPanel( - title = datalabels_r()[dataname], - class = "simple-card", - ui_t_reactable(session$ns(dataname)) - ) - } - ) + } else if (layout == "accordion") { + div( + do.call( + bslib::accordion, + c( + list(id = session$ns("reactables")), + lapply( + datanames_r(), + function(dataname) { + bslib::accordion_panel( + title = datalabels_r()[dataname], + ui_t_reactable(session$ns(dataname)) + ) + } ) ) ) - - }) + ) } }) |> bindCache(datanames_r()) @@ -153,7 +146,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. columns = .make_reactable_columns_call(data()[[dataname]]), resizable = TRUE, onClick = "select", - defaultPageSize = 15, + defaultPageSize = 10, wrap = FALSE, rowClass = JS(" function(rowInfo) { diff --git a/R/utils.R b/R/utils.R index cceea176c..ad198658f 100644 --- a/R/utils.R +++ b/R/utils.R @@ -416,7 +416,7 @@ select_decorators <- function(decorators, scope) { N <- length(levels) n <- length(p) m <- N - n - if (m & n) { + if (m > 0 && n > 0) { current_space <- rgb2hsv(col2rgb(p)) optimal_color_space <- colorspace::qualitative_hcl(N) color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) @@ -428,6 +428,12 @@ select_decorators <- function(decorators, scope) { colorspace::qualitative_hcl(N) } else { p - } + } + p[levels] } +.shape_palette_discrete <- function(levels, symbol) { + s <- setNames(symbol[levels], levels) + s[is.na(s)] <- "circle-open" + s +} From 7590be1cd7f3843fc89e3eddedac86df1556dd9c Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 12 Mar 2025 11:47:27 +0000 Subject: [PATCH 054/158] wip --- R/tm_data_table.R | 18 ++-- R/tm_g_swimlane.R | 12 ++- R/tm_g_waterfall.R | 13 ++- R/tm_t_reactable.R | 214 +++++++++++++++++++++++++++------------------ 4 files changed, 149 insertions(+), 108 deletions(-) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 35f94641b..724254aa8 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -324,6 +324,14 @@ srv_dataset_table <- function(id, teal.code::eval_code( qenv, substitute( + env = list( + dataname = as.name(dataname), + if_distinct = if_distinct(), + vars = input$variables, + args = dt_args, + dt_options = dt_options, + dt_rows = input$dt_rows + ), expr = { variables <- vars dataframe_selected <- if (if_distinct) { @@ -338,15 +346,7 @@ srv_dataset_table <- function(id, } dt_args$data <- dataframe_selected table <- do.call(DT::datatable, dt_args) - }, - env = list( - dataname = as.name(dataname), - if_distinct = if_distinct(), - vars = input$variables, - args = dt_args, - dt_options = dt_options, - dt_rows = input$dt_rows - ) + } ) ) }) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 10bb57417..28aa68b7c 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -28,9 +28,11 @@ tm_g_swimlane <- function(label = "Swimlane", ui_g_swimlane <- function(id, height) { ns <- NS(id) - div( - class = "simple-card", - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), + bslib::page_fluid( + fluidRow( + column(6, uiOutput(ns("sort_by_output"))), + column(6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + ), plotly::plotlyOutput(ns("plot"), height = "100%") ) } @@ -127,10 +129,6 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) - observeEvent(plotly_q(), { - cat(paste(collapse = "\n", teal.code::get_code(plotly_q()))) - }) - reactive({ req(plotly_selected()) within( diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 210666696..b17d54f17 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -34,15 +34,12 @@ tm_g_waterfall <- function(label = "Waterfall", ui_g_waterfall <- function(id, height) { ns <- NS(id) - tagList( - div( - class = "simple-card", - fluidRow( - column(width = 6, uiOutput(ns("color_by_output"))), - column(width = 6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)), - ), - plotly::plotlyOutput(ns("plot"), height = "100%") + bslib::page_fluid( + fluidRow( + column(6, uiOutput(ns("color_by_output"))), + column(6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) ), + plotly::plotlyOutput(ns("plot"), height = "100%"), uiOutput(ns("tables")) ) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 63b12a0d4..48184eb3f 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -2,19 +2,19 @@ tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), layout = "grid", transformators = list(), decorators = list(), ...) { module( label = label, - ui = ui_t_reactable, - srv = srv_t_reactable, + ui = ui_t_reactables, + server = srv_t_reactables, ui_args = list(decorators = decorators), - srv_args = c( + server_args = c( list(datanames = datanames, columns = columns, layout = layout, decorators = decorators), rlang::list2(...) ), - datanames = subtables, - transformers = transformers + datanames = datanames, + transformators = transformators ) } -ui_t_reactables <- function(id) { +ui_t_reactables <- function(id, decorators) { ns <- NS(id) uiOutput(ns("subtables"), container = bslib::page_fluid) } @@ -34,7 +34,8 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec } else { intersect(datanames, df_datanames) } - }) |> bindEvent(all_datanames_r()) + }) |> + bindEvent(all_datanames_r()) columns_r <- reactive({ req(datanames_r()) @@ -45,7 +46,9 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec colnames(isolate(data())[[dataname]]) } }) - }) |> bindEvent(datanames_r()) + }) |> + bindCache(datanames_r()) |> + bindEvent(datanames_r()) datalabels_r <- reactive({ req(datanames_r()) @@ -53,97 +56,134 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec datalabel <- attr(isolate(data())[[dataname]], "label") if (length(datalabel)) datalabel else dataname }) - }) |> bindEvent(datanames_r()) + }) |> + bindCache(datanames_r()) |> + bindEvent(datanames_r()) # todo: re-render only if datanames changes output$subtables <- renderUI({ if (length(datanames_r()) == 0) return(NULL) - - if (layout == "grid") { - tagList( - lapply( - datanames_r(), - function(dataname) { - div( - class = "simple-card", - style = if (length(datanames_r()) > 1) "width: 50%" else "width: 100%", - h4(datalabels_r()[dataname]), - ui_t_reactable(session$ns(dataname)) - ) - } - ) - ) - } else if (layout == "accordion") { - div( - do.call( - bslib::accordion, - c( - list(id = session$ns("reactables")), - lapply( - datanames_r(), - function(dataname) { - bslib::accordion_panel( - title = datalabels_r()[dataname], - ui_t_reactable(session$ns(dataname)) - ) - } - ) + logger::log_debug("srv_t_reactables@1 render subtables") + div( + do.call( + bslib::accordion, + c( + list(id = session$ns("reactables")), + lapply( + datanames_r(), + function(dataname) { + bslib::accordion_panel( + title = datalabels_r()[dataname], + ui_t_reactable(session$ns(dataname)) + ) + } ) ) ) - } - - }) |> bindCache(datanames_r()) + ) + }) |> + bindCache(datanames_r()) |> + bindEvent(datanames_r()) called_datanames <- reactiveVal() observeEvent(datanames_r(), { lapply( setdiff(datanames_r(), called_datanames()), # call module only once per dataname - function(dataname) srv_t_reactable(dataname, data = data, dataname = dataname, filter_panel_api = filter_panel_api, ...) + function(dataname) { + srv_t_reactable( + dataname, + data = data, + dataname = dataname, + filter_panel_api = filter_panel_api, + columns = columns[[dataname]], + ... + ) + } ) called_datanames(union(called_datanames(), datanames_r())) }) - - - # lapply( - # seq_along(subtables), - # function(i) { - # table_q <- reactive({ - # within( - # plotly_selected_q(), - # dataname = str2lang(dataname), - # subtable_name = subtable_names[i], - # time_var = str2lang(time_var), - # subject_var = str2lang(subject_var), - # col_defs = subtables[[i]], - # expr = { - # subtable_name <- dataname |> - # dplyr::filter( - # time_var %in% plotly_brushed_time, - # subject_var %in% plotly_brushed_subject - # ) |> - # dplyr::select(dplyr::all_of(col_defs)) - # } - # ) - # }) - # srv_t_reactable(subtable_names[i], data = table_q, dataname = subtable_names[i], selection = NULL) - # } - # ) }) } ui_t_reactable <- function(id) { ns <- NS(id) - reactable::reactableOutput(ns("table")) + bslib::page_fluid( + shinyWidgets::pickerInput( + ns("columns"), + label = "Select columns", + choices = NULL, + selected = NULL, + multiple = TRUE, + width = "100%", + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + `show-subtext` = TRUE, + countSelectedText = TRUE, + liveSearch = TRUE + ) + ), + reactable::reactableOutput(ns("table")) + ) + } -srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, ...) { +srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decorators, ...) { moduleServer(id, function(input, output, session) { + logger::log_debug("srv_t_reactable initializing for dataname: { dataname }") dataname_reactable <- sprintf("%s_reactable", dataname) + dataset_labels <- reactive({ + req(data()) + teal.data::col_labels(data()[[dataname]], fill = TRUE) + }) + + cols_choices <- reactive({ + req(dataset_labels()) + choices <- if (length(columns)) { + columns + } else { + names(dataset_labels()) + } + labels_choices <- dataset_labels()[choices] + setNames(choices, labels_choices) + }) |> + bindCache(dataset_labels()) + + + observeEvent(cols_choices(), { + logger::log_debug("srv_t_reactable@1 update column choices") + shinyWidgets::updatePickerInput( + inputId = "columns", + choices = cols_choices(), + selected = cols_choices() + ) + }) + + # this is needed because picker input reacts to the selection while dropdown is open + # to avoid this we need to bypass input through reactiveVal + # https://forum.posit.co/t/only-update-pickerinput-on-close/173833 + cols_selected <- reactiveVal(isolate(cols_choices())) + observeEvent(input$columns_open, `if`(!isTruthy(input$columns_open), cols_selected(input$columns))) + + select_call <- reactive({ + req(cols_selected()) + substitute( + lhs <- rhs, + list( + lhs = str2lang(dataname), + rhs = as.call( + c( + list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), + lapply(cols_selected(), str2lang) + ) + ) + ) + ) + }) reactable_call <- reactive({ + req(input$columns, data()) default_args <- list( - columns = .make_reactable_columns_call(data()[[dataname]]), + columns = .make_reactable_columns_call(data()[[dataname]][cols_selected()]), resizable = TRUE, onClick = "select", defaultPageSize = 10, @@ -157,20 +197,28 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. ") ) args <- modifyList(default_args, rlang::list2(...)) + substitute( lhs <- rhs, list( - lhs = dataname_reactable, - rhs = .make_reactable_call(dataname = dataname, args = args) + lhs = str2lang(dataname_reactable), + rhs = .make_reactable_call(dataname = dataname, args = args) ) ) }) + table_q <- reactive({ - req(data()) - eval_code(data(), reactable_call()) + req(reactable_call(), select_call()) + data() |> + eval_code(select_call()) |> + eval_code(reactable_call()) }) - output$table <- reactable::renderReactable(table_q()[[dataname_reactable]]) + output$table <- reactable::renderReactable({ + logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") + table_q()[[dataname_reactable]] + }) + table_selected_q <- reactive({ selected_row <- reactable::getReactableState("table", "selected") if (!is.null(selected_row)) { @@ -192,7 +240,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. } .make_reactable_call <- function(dataname, args) { - args <- c( + args <- modifyList( list( data = str2lang(dataname), defaultColDef = quote( @@ -214,15 +262,13 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. } else { value } - } + } ) - ) ), args ) - do.call(call, c(list(name = "reactable"), args), quote = TRUE) - + as.call(c(list(name = "reactable"), args)) } #' Makes `reactable::colDef` call containing: @@ -255,14 +301,14 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, decorators, .. ) if (length(args)) { - do.call(call, c(list(name = "colDef"), args), quote = TRUE) + as.call(c(list(name = "colDef"), args)) } } ) names(args) <- names(dataset) args <- Filter(length, args) if (length(args)) { - do.call(call, c(list("list"), args), quote = TRUE) + as.call(c(list("list"), args)) } } From cabb6952c65f3848acc47f79ae863ef1c9746bdb Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 12 Mar 2025 13:22:47 +0100 Subject: [PATCH 055/158] fix reactables reactivity --- R/tm_t_reactable.R | 127 ++++++++++++++++++++++----------------------- 1 file changed, 63 insertions(+), 64 deletions(-) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 48184eb3f..1ffdc8c40 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,12 +1,18 @@ #' @export -tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), layout = "grid", transformators = list(), decorators = list(), ...) { +tm_t_reactables <- function(label = "Table", + datanames = "all", + columns = list(), + layout = "grid", + transformators = list(), + decorators = list(), + ...) { module( label = label, ui = ui_t_reactables, server = srv_t_reactables, ui_args = list(decorators = decorators), server_args = c( - list(datanames = datanames, columns = columns, layout = layout, decorators = decorators), + list(datanames = datanames, columns = columns, layout = layout, decorators = decorators), rlang::list2(...) ), datanames = datanames, @@ -25,18 +31,20 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec req(data()) names(Filter(is.data.frame, as.list(data()))) }) - - datanames_r <- reactive({ - req(all_datanames_r()) + + datanames_r <- reactiveVal() + observeEvent(all_datanames_r(), { df_datanames <- all_datanames_r() - if (identical(datanames, "all")) { + new_datanames <- if (identical(datanames, "all")) { df_datanames } else { intersect(datanames, df_datanames) } - }) |> - bindEvent(all_datanames_r()) - + if (!identical(new_datanames, datanames_r())) { + datanames_r(new_datanames) + } + }) + columns_r <- reactive({ req(datanames_r()) sapply(datanames_r(), function(dataname) { @@ -46,24 +54,22 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec colnames(isolate(data())[[dataname]]) } }) - }) |> - bindCache(datanames_r()) |> - bindEvent(datanames_r()) - + }) + datalabels_r <- reactive({ req(datanames_r()) sapply(datanames_r(), function(dataname) { datalabel <- attr(isolate(data())[[dataname]], "label") if (length(datalabel)) datalabel else dataname }) - }) |> - bindCache(datanames_r()) |> - bindEvent(datanames_r()) - + }) + # todo: re-render only if datanames changes output$subtables <- renderUI({ - if (length(datanames_r()) == 0) return(NULL) logger::log_debug("srv_t_reactables@1 render subtables") + if (length(datanames_r()) == 0) { + return(NULL) + } div( do.call( bslib::accordion, @@ -81,20 +87,18 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec ) ) ) - }) |> - bindCache(datanames_r()) |> - bindEvent(datanames_r()) - + }) + called_datanames <- reactiveVal() observeEvent(datanames_r(), { lapply( setdiff(datanames_r(), called_datanames()), # call module only once per dataname function(dataname) { srv_t_reactable( - dataname, - data = data, - dataname = dataname, - filter_panel_api = filter_panel_api, + dataname, + data = data, + dataname = dataname, + filter_panel_api = filter_panel_api, columns = columns[[dataname]], ... ) @@ -109,10 +113,10 @@ ui_t_reactable <- function(id) { ns <- NS(id) bslib::page_fluid( shinyWidgets::pickerInput( - ns("columns"), - label = "Select columns", - choices = NULL, - selected = NULL, + ns("columns"), + label = "Select columns", + choices = NULL, + selected = NULL, multiple = TRUE, width = "100%", options = shinyWidgets::pickerOptions( @@ -122,22 +126,23 @@ ui_t_reactable <- function(id) { liveSearch = TRUE ) ), - reactable::reactableOutput(ns("table")) + reactable::reactableOutput(ns("table")) ) - } srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decorators, ...) { moduleServer(id, function(input, output, session) { logger::log_debug("srv_t_reactable initializing for dataname: { dataname }") dataname_reactable <- sprintf("%s_reactable", dataname) - + dataset_labels <- reactive({ - req(data()) + req(data()) teal.data::col_labels(data()[[dataname]], fill = TRUE) }) - - cols_choices <- reactive({ + + cols_choices <- reactiveVal() + cols_selected <- reactiveVal() + observeEvent(dataset_labels(), { req(dataset_labels()) choices <- if (length(columns)) { columns @@ -145,33 +150,28 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor names(dataset_labels()) } labels_choices <- dataset_labels()[choices] - setNames(choices, labels_choices) - }) |> - bindCache(dataset_labels()) - - - observeEvent(cols_choices(), { - logger::log_debug("srv_t_reactable@1 update column choices") - shinyWidgets::updatePickerInput( - inputId = "columns", - choices = cols_choices(), - selected = cols_choices() - ) + cols_choices_new <- setNames(choices, labels_choices) + if (!identical(cols_choices_new, cols_choices())) { + logger::log_debug("srv_t_reactable@1 update column choices") + shinyWidgets::updatePickerInput( + inputId = "columns", + choices = cols_choices_new, + selected = cols_choices_new + ) + cols_choices(cols_choices_new) + cols_selected(cols_choices_new) + } }) - - # this is needed because picker input reacts to the selection while dropdown is open - # to avoid this we need to bypass input through reactiveVal - # https://forum.posit.co/t/only-update-pickerinput-on-close/173833 - cols_selected <- reactiveVal(isolate(cols_choices())) + observeEvent(input$columns_open, `if`(!isTruthy(input$columns_open), cols_selected(input$columns))) select_call <- reactive({ req(cols_selected()) substitute( - lhs <- rhs, + lhs <- rhs, list( lhs = str2lang(dataname), - rhs = as.call( + rhs = as.call( c( list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), lapply(cols_selected(), str2lang) @@ -197,17 +197,16 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor ") ) args <- modifyList(default_args, rlang::list2(...)) - + substitute( lhs <- rhs, list( lhs = str2lang(dataname_reactable), - rhs = .make_reactable_call(dataname = dataname, args = args) + rhs = .make_reactable_call(dataname = dataname, args = args) ) ) - }) - + table_q <- reactive({ req(reactable_call(), select_call()) data() |> @@ -218,7 +217,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") table_q()[[dataname_reactable]] }) - + table_selected_q <- reactive({ selected_row <- reactable::getReactableState("table", "selected") if (!is.null(selected_row)) { @@ -228,7 +227,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor dataname_selected = str2lang(sprintf("%s_selected", dataname)), dataname = str2lang(dataname), expr = { - dataname_selected <- dataname[selected_row, ] + dataname_selected <- dataname[selected_row, ] } ) } else { @@ -258,7 +257,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor htmltools::tags$a(href = value, target = "_blank", "Link") } else { "N/A" - } + } } else { value } @@ -281,7 +280,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor .make_reactable_columns_call <- function(dataset) { checkmate::assert_data_frame(dataset) args <- lapply( - seq_along(dataset), + seq_along(dataset), function(i) { column <- dataset[[i]] label <- attr(column, "label") @@ -308,7 +307,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor names(args) <- names(dataset) args <- Filter(length, args) if (length(args)) { - as.call(c(list("list"), args)) + as.call(c(list("list"), args)) } } From 29517c8586e9b1ad0a86cbcb6e2582dd14d603d3 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 12 Mar 2025 16:18:38 +0000 Subject: [PATCH 056/158] sort input swimlane --- R/tm_g_swimlane.R | 106 +++++++++++++++++++++++++++++++------------- R/tm_g_waterfall.R | 3 +- R/tm_swimlane_mdr.R | 8 ++++ R/tm_t_reactable.R | 50 ++++++++++++--------- 4 files changed, 112 insertions(+), 55 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 28aa68b7c..58fe9535c 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -5,6 +5,8 @@ tm_g_swimlane <- function(label = "Swimlane", subject_var, value_var, event_var, + sort_var = NULL, + group_var = NULL, value_var_color = character(0), value_var_symbol, plot_height = 700) { @@ -20,6 +22,8 @@ tm_g_swimlane <- function(label = "Swimlane", subject_var = subject_var, value_var = value_var, event_var = event_var, + sort_var = sort_var, + group_var = group_var, value_var_color = value_var_color, value_var_symbol = value_var_symbol ) @@ -29,9 +33,9 @@ tm_g_swimlane <- function(label = "Swimlane", ui_g_swimlane <- function(id, height) { ns <- NS(id) bslib::page_fluid( - fluidRow( - column(6, uiOutput(ns("sort_by_output"))), - column(6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + bslib::layout_columns( + selectInput(ns("sort_by"), label = "Select variable:", choices = NULL, selected = NULL, multiple = FALSE), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), plotly::plotlyOutput(ns("plot"), height = "100%") ) @@ -43,12 +47,39 @@ srv_g_swimlane <- function(id, subject_var, value_var, event_var, + sort_var = time_var, + group_var = NULL, value_var_color, value_var_symbol, filter_panel_api) { moduleServer(id, function(input, output, session) { + + sort_choices <- reactiveVal() + sort_selected <- reactiveVal() + if (inherits(sort_var, c("choices_selected", "select_spec"))) { + if (length(sort_var$choices) == 1) { + sort_var <- sort_var$choices + } else { + updateSelectInput(inputId = "sort_by", choices = sort_var$choices, selected = sort_var$selected) + observeEvent(input$sort_by, { + if (!identical(input$sort_by, sort_selected())) { + sort_selected(input$sort_by) + } + }) + } + } + if (length(sort_var) == 1) { + isolate(sort_choices(sort_var)) + isolate(sort_selected(sort_var)) + shinyjs::hide("sort_by") + } + + + + + plotly_q <- reactive({ - req(data()) + req(data(), sort_selected()) adjusted_colors <- .color_palette_discrete( levels = unique(data()[[dataname]][[value_var]]), color = value_var_color @@ -67,6 +98,8 @@ srv_g_swimlane <- function(id, subject_var = str2lang(subject_var), value_var = str2lang(value_var), event_var = str2lang(event_var), + sort_var = str2lang(sort_selected()), + group_var = if (length(group_var)) group_var, subject_var_label = sprintf("%s:", subject_var_label), time_var_label = sprintf("%s:", time_var_label), colors = adjusted_colors, @@ -76,8 +109,39 @@ srv_g_swimlane <- function(id, time_axis_label = time_var_label, expr = { # todo: forcats::fct_reorder didn't work. - levels <- with(dataname, tapply(time_var, subject_var, max)) |> sort() - dataname <- dataname %>% + plotly_fun <- function(data) { + data %>% + plotly::plot_ly( + source = "swimlane", + colors = colors, + symbols = symbols, + height = height + ) %>% + plotly::add_markers( + x = ~time_var, + y = ~subject_var_ordered, + color = ~value_var, + symbol = ~value_var, + text = ~tooltip, + legendgroup = ~event_var, + hoverinfo = "text" + ) %>% + plotly::add_segments( + x = ~0, xend = ~study_day, + y = ~subject_var_ordered, yend = ~subject_var_ordered, + color = ~event_var, + data = data |> group_by(subject_var_ordered, event_var) |> summarise(study_day = max(time_var)), + line = list(width = 1, color = "grey"), + showlegend = FALSE + ) %>% + plotly::layout( + xaxis = list(title = time_axis_label), yaxis = list(title = subject_axis_label) + ) %>% + plotly::layout(dragmode = "select") %>% + plotly::config(displaylogo = FALSE) + } + levels <- with(dataname, tapply(sort_var, subject_var, max)) |> sort() + p <- dataname %>% mutate(subject_var_ordered = factor(subject_var, levels = names(levels))) %>% group_by(subject_var, time_var) %>% mutate( @@ -88,32 +152,10 @@ srv_g_swimlane <- function(id, sprintf("%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) )), collapse = "
" - )) - - - p <- dataname %>% - plotly::plot_ly( - source = "swimlane", - colors = colors, - symbols = symbols, - height = height - ) %>% - plotly::add_markers( - x = ~time_var, y = ~subject_var_ordered, color = ~value_var, symbol = ~value_var, - text = ~tooltip, - hoverinfo = "text" - ) %>% - plotly::add_segments( - x = ~0, xend = ~study_day, y = ~subject_var_ordered, yend = ~subject_var_ordered, - data = dataname |> group_by(subject_var_ordered) |> summarise(study_day = max(time_var)), - line = list(width = 1, color = "grey"), - showlegend = FALSE - ) %>% - plotly::layout( - xaxis = list(title = time_axis_label), yaxis = list(title = subject_axis_label) - ) %>% - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) + )) %>% + split(if (is.null(group_var)) "" else .[[group_var]]) %>% + lapply(plotly_fun) %>% + plotly::subplot(nrows = length(.), shareX = TRUE, titleX = FALSE) } ) }) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index b17d54f17..9b21261a7 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -185,8 +185,7 @@ srv_g_waterfall <- function(id, srv_t_reactables( "subtables", data = tables_selected_q, - dataname = sprintf("%s_brushed", table_datanames), - layout = "accordion", + dataname = sprintf("%s_brushed", table_datanames), ... ) }) diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R index d5125d99e..68557078e 100644 --- a/R/tm_swimlane_mdr.R +++ b/R/tm_swimlane_mdr.R @@ -5,6 +5,8 @@ tm_g_swimlane_mdr <- function(label = "Swimlane", subject_var, value_var, event_var, + sort_var = time_var, + group_var = NULL, listing_datanames = character(0), value_var_color = c( "DEATH" = "black", @@ -49,6 +51,8 @@ tm_g_swimlane_mdr <- function(label = "Swimlane", subject_var = subject_var, value_var = value_var, event_var = event_var, + sort_var = sort_var, + group_var = group_var, value_var_color = value_var_color, value_var_symbol = value_var_symbol, listing_datanames = listing_datanames, @@ -74,6 +78,8 @@ srv_g_swimlane_mdr <- function(id, subject_var, value_var, event_var, + sort_var, + group_var, value_var_color, value_var_symbol, listing_datanames, @@ -88,6 +94,8 @@ srv_g_swimlane_mdr <- function(id, subject_var = subject_var, value_var = value_var, event_var = event_var, + sort_var = sort_var, + group_var = group_var, value_var_color = value_var_color, value_var_symbol = value_var_symbol, filter_panel_api = filter_panel_api diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 1ffdc8c40..fe60de13d 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -2,7 +2,6 @@ tm_t_reactables <- function(label = "Table", datanames = "all", columns = list(), - layout = "grid", transformators = list(), decorators = list(), ...) { @@ -12,7 +11,7 @@ tm_t_reactables <- function(label = "Table", server = srv_t_reactables, ui_args = list(decorators = decorators), server_args = c( - list(datanames = datanames, columns = columns, layout = layout, decorators = decorators), + list(datanames = datanames, columns = columns, decorators = decorators), rlang::list2(...) ), datanames = datanames, @@ -20,12 +19,12 @@ tm_t_reactables <- function(label = "Table", ) } -ui_t_reactables <- function(id, decorators) { +ui_t_reactables <- function(id, decorators = list()) { ns <- NS(id) uiOutput(ns("subtables"), container = bslib::page_fluid) } -srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, decorators, layout = "grid", ...) { +srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns = list(), decorators = list(), ...) { moduleServer(id, function(input, output, session) { all_datanames_r <- reactive({ req(data()) @@ -111,21 +110,26 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns, dec ui_t_reactable <- function(id) { ns <- NS(id) + + input <- shinyWidgets::pickerInput( + ns("columns"), + label = NULL, + choices = NULL, + selected = NULL, + multiple = TRUE, + width = "100%", + options = shinyWidgets::pickerOptions( + actionsBox = TRUE, + `show-subtext` = TRUE, + countSelectedText = TRUE, + liveSearch = TRUE + ) + ) + + # input <- actionButton(ns("show_select_columns"), "Nothing selected", class = "rounded-pill btn-sm primary") |> + # bslib::popover(input) bslib::page_fluid( - shinyWidgets::pickerInput( - ns("columns"), - label = "Select columns", - choices = NULL, - selected = NULL, - multiple = TRUE, - width = "100%", - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - `show-subtext` = TRUE, - countSelectedText = TRUE, - liveSearch = TRUE - ) - ), + input, reactable::reactableOutput(ns("table")) ) } @@ -162,8 +166,13 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor cols_selected(cols_choices_new) } }) - observeEvent(input$columns_open, `if`(!isTruthy(input$columns_open), cols_selected(input$columns))) + observeEvent(cols_selected(), { + updateActionButton( + inputId = "show_select_columns", + label = paste(substring(toString(cols_selected()), 1, 100), "...") + ) + }) select_call <- reactive({ req(cols_selected()) @@ -181,13 +190,12 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor ) }) reactable_call <- reactive({ - req(input$columns, data()) + req(cols_selected(), data()) default_args <- list( columns = .make_reactable_columns_call(data()[[dataname]][cols_selected()]), resizable = TRUE, onClick = "select", defaultPageSize = 10, - wrap = FALSE, rowClass = JS(" function(rowInfo) { if (rowInfo.selected) { From 246bfb2e501196f2d8694fa3e93413566d6c991a Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 12 Mar 2025 16:23:52 +0000 Subject: [PATCH 057/158] v3 --- R/tm_g_swimlane.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 58fe9535c..61fd7324f 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -34,7 +34,7 @@ ui_g_swimlane <- function(id, height) { ns <- NS(id) bslib::page_fluid( bslib::layout_columns( - selectInput(ns("sort_by"), label = "Select variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("sort_by"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), plotly::plotlyOutput(ns("plot"), height = "100%") From 9d51de31bef33593944e38cd7f9dbab68a822f7a Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 13 Mar 2025 15:36:21 +0000 Subject: [PATCH 058/158] v4 --- R/tm_g_swimlane.R | 47 +++++++++++-------- R/tm_g_waterfall.R | 113 ++++++++++++++++++++++++++++----------------- R/tm_t_reactable.R | 89 +++++++++++++++++++++-------------- 3 files changed, 154 insertions(+), 95 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 61fd7324f..41f93b17c 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -140,9 +140,16 @@ srv_g_swimlane <- function(id, plotly::layout(dragmode = "select") %>% plotly::config(displaylogo = FALSE) } - levels <- with(dataname, tapply(sort_var, subject_var, max)) |> sort() + + levels <- dataname %>% + group_by(subject_var, group_var) %>% + summarize(v = max(sort_var)) %>% + ungroup() %>% + arrange(group_var, v) %>% + pull(subject_var) + p <- dataname %>% - mutate(subject_var_ordered = factor(subject_var, levels = names(levels))) %>% + mutate(subject_var_ordered = factor(subject_var, levels = levels)) %>% group_by(subject_var, time_var) %>% mutate( tooltip = paste( @@ -153,9 +160,7 @@ srv_g_swimlane <- function(id, )), collapse = "
" )) %>% - split(if (is.null(group_var)) "" else .[[group_var]]) %>% - lapply(plotly_fun) %>% - plotly::subplot(nrows = length(.), shareX = TRUE, titleX = FALSE) + plotly_fun() } ) }) @@ -173,19 +178,25 @@ srv_g_swimlane <- function(id, reactive({ req(plotly_selected()) - within( - plotly_q(), - dataname = str2lang(dataname), - time_var = str2lang(time_var), - subject_var = subject_var, - value_var = str2lang(value_var), - time_vals = plotly_selected()$x, - subject_vals = plotly_selected()$y, - expr = { - plotly_brushed_time <- time_vals - plotly_brushed_subject <- subject_vals - } - ) + primary_key_cols <- join_keys(plotly_q())[dataname, dataname] + if (length(primary_key_cols)) { + within( + plotly_q(), + dataname = str2lang(dataname), + time_var = str2lang(time_var), + subject_var = subject_var, + value_var = str2lang(value_var), + time_vals = plotly_selected()$x, + subject_vals = plotly_selected()$y, + primary_key_cols = primary_key_cols, + expr = { + plotly_selected_keys <- dplyr::filter(time_var %in% time_vals, subject_var %in% subject_vals) %>% + dplyr::select(primary_key_cols) + plotly_brushed_time <- time_vals + plotly_brushed_subject <- subject_vals + } + ) + } }) }) } diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 9b21261a7..e8b014f4a 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,14 +1,14 @@ #' @export tm_g_waterfall <- function(label = "Waterfall", plot_dataname, - table_datanames, subject_var, value_var, color_var = NULL, bar_colors = list(), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = 700, + plot_height = 700, + table_datanames, ...) { module( label = label, @@ -46,15 +46,15 @@ ui_g_waterfall <- function(id, height) { srv_g_waterfall <- function(id, data, plot_dataname, - table_datanames, subject_var, value_var, color_var, bar_colors, - filter_panel_api, value_arbitrary_hlines, plot_title, plot_height = 600, + table_datanames = character(0), + filter_panel_api, ...) { moduleServer(id, function(input, output, session) { output$color_by_output <- renderUI({ @@ -96,16 +96,16 @@ srv_g_waterfall <- function(id, title = paste0(value_var_label, " (Waterfall plot)"), height = input$plot_height, expr = { - p <- dataname |> + p <- dataname %>% dplyr::mutate( subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE) - ) |> - dplyr::filter(!duplicated(subject_var)) |> + ) %>% + dplyr::filter(!duplicated(subject_var)) %>% # todo: one value for x, y: distinct or summarize(value = foo(value_var)) [foo: summarize_fun] plotly::plot_ly( source = "waterfall", height = height - ) |> + ) %>% plotly::add_bars( x = ~subject_var_ordered, y = ~value_var, @@ -116,7 +116,7 @@ srv_g_waterfall <- function(id, value_var_label, ":", value_var, "
" ), hoverinfo = "text" - ) |> + ) %>% plotly::layout( shapes = lapply(value_arbitrary_hlines, function(y) { list( @@ -133,9 +133,9 @@ srv_g_waterfall <- function(id, xaxis = list(title = subject_var_label, tickangle = -45), yaxis = list(title = value_var_label), legend = list(title = list(text = "Color by:")), - barmode = "relative", - dragmode = "select" - ) |> + barmode = "relative" + ) %>% + plotly::layout( dragmode = "select") %>% plotly::config(displaylogo = FALSE) }, height = input$plot_height @@ -145,48 +145,77 @@ srv_g_waterfall <- function(id, output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) + plotly_selected_q <- reactive({ req(plotly_selected()) + primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) + req(primary_keys) within( plotly_q(), - subject_vals = plotly_selected()$x, - value_vals = plotly_selected()$y, expr = { - # todo: this should use the join keys instead. Probably need to filter visualization data.frame and use its column - plotly_brushed_subjects <- subject_vals - plotly_brushed_value <- value_vals - } + waterfall_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% + dplyr::select(primary_keys) + }, + dataname = str2lang(plot_dataname), + xvar = str2lang(subject_var), + yvar = str2lang(value_var), + xvals = plotly_selected()$x, + yvals = plotly_selected()$y, + primary_keys = primary_keys ) }) - - tables_selected_q <- reactive({ - req(plotly_selected_q()) - teal.code::eval_code( - plotly_selected_q(), - code = as.expression( - lapply( - table_datanames, - function(dataname) { - substitute( - expr = dataname_brushed <- dplyr::filter(dataname, subject_var %in% plotly_brushed_subjects), - env = list( - dataname_brushed = str2lang(sprintf("%s_brushed", dataname)), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var) - ) + + children_names <- reactive({ + if (length(table_datanames) == 0) { + children(plotly_selected_q(), plot_dataname) + } else { + table_datanames + } + }) + + tables_selected_q <- eventReactive(plotly_selected_q(), { + exprs <- as.expression( + lapply( + children_names(), + function(childname) { + join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] + substitute( + expr = { + childname <- dplyr::right_join(childname, waterfall_selected, by = by) + }, + list( + childname = str2lang(childname), + by = join_cols ) - } - ) + ) + } ) ) + eval_code(plotly_selected_q(), exprs) }) output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) - srv_t_reactables( - "subtables", - data = tables_selected_q, - dataname = sprintf("%s_brushed", table_datanames), - ... - ) + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) }) } + +# todo: to teal_data +children <- function(x, dataset_name = character(0)) { + checkmate::assert_multi_class(x, c("teal_data", "join_keys")) + checkmate::assert_character(dataset_name, max.len = 1) + if (length(dataset_name)) { + names( + Filter( + function(parent) parent == dataset_name, + parents(x) + ) + ) + } else { + all_parents <- unique(unlist(parents(x))) + names(all_parents) <- all_parents + lapply( + all_parents, + function(parent) children(x = x, dataset_name = parent) + ) + } +} diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index fe60de13d..a8f8e9afc 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,7 +1,7 @@ #' @export tm_t_reactables <- function(label = "Table", datanames = "all", - columns = list(), + colnames = list(), transformators = list(), decorators = list(), ...) { @@ -11,7 +11,7 @@ tm_t_reactables <- function(label = "Table", server = srv_t_reactables, ui_args = list(decorators = decorators), server_args = c( - list(datanames = datanames, columns = columns, decorators = decorators), + list(datanames = datanames, colnames = colnames, decorators = decorators), rlang::list2(...) ), datanames = datanames, @@ -24,31 +24,15 @@ ui_t_reactables <- function(id, decorators = list()) { uiOutput(ns("subtables"), container = bslib::page_fluid) } -srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns = list(), decorators = list(), ...) { +srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), ...) { moduleServer(id, function(input, output, session) { - all_datanames_r <- reactive({ - req(data()) - names(Filter(is.data.frame, as.list(data()))) - }) - - datanames_r <- reactiveVal() - observeEvent(all_datanames_r(), { - df_datanames <- all_datanames_r() - new_datanames <- if (identical(datanames, "all")) { - df_datanames - } else { - intersect(datanames, df_datanames) - } - if (!identical(new_datanames, datanames_r())) { - datanames_r(new_datanames) - } - }) - - columns_r <- reactive({ + # todo: this to the function .validate_datanames + datanames_r <- .validate_datanames(datanames = datanames, data = data) + colnames_r <- reactive({ req(datanames_r()) sapply(datanames_r(), function(dataname) { - if (length(columns[[dataname]])) { - columns()[[dataname]] + if (length(colnames[[dataname]])) { + colnames()[[dataname]] } else { colnames(isolate(data())[[dataname]]) } @@ -98,7 +82,7 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, columns = li data = data, dataname = dataname, filter_panel_api = filter_panel_api, - columns = columns[[dataname]], + colnames = colnames[[dataname]], ... ) } @@ -112,7 +96,7 @@ ui_t_reactable <- function(id) { ns <- NS(id) input <- shinyWidgets::pickerInput( - ns("columns"), + ns("colnames"), label = NULL, choices = NULL, selected = NULL, @@ -126,7 +110,7 @@ ui_t_reactable <- function(id) { ) ) - # input <- actionButton(ns("show_select_columns"), "Nothing selected", class = "rounded-pill btn-sm primary") |> + # input <- actionButton(ns("show_select_colnames"), "Nothing selected", class = "rounded-pill btn-sm primary") |> # bslib::popover(input) bslib::page_fluid( input, @@ -134,7 +118,7 @@ ui_t_reactable <- function(id) { ) } -srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decorators, ...) { +srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, decorators, ...) { moduleServer(id, function(input, output, session) { logger::log_debug("srv_t_reactable initializing for dataname: { dataname }") dataname_reactable <- sprintf("%s_reactable", dataname) @@ -148,8 +132,8 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor cols_selected <- reactiveVal() observeEvent(dataset_labels(), { req(dataset_labels()) - choices <- if (length(columns)) { - columns + choices <- if (length(colnames)) { + colnames } else { names(dataset_labels()) } @@ -158,7 +142,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor if (!identical(cols_choices_new, cols_choices())) { logger::log_debug("srv_t_reactable@1 update column choices") shinyWidgets::updatePickerInput( - inputId = "columns", + inputId = "colnames", choices = cols_choices_new, selected = cols_choices_new ) @@ -166,10 +150,10 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor cols_selected(cols_choices_new) } }) - observeEvent(input$columns_open, `if`(!isTruthy(input$columns_open), cols_selected(input$columns))) + observeEvent(input$colnames_open, `if`(!isTruthy(input$colnames_open), cols_selected(input$colnames))) observeEvent(cols_selected(), { updateActionButton( - inputId = "show_select_columns", + inputId = "show_select_colnames", label = paste(substring(toString(cols_selected()), 1, 100), "...") ) }) @@ -192,7 +176,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor reactable_call <- reactive({ req(cols_selected(), data()) default_args <- list( - columns = .make_reactable_columns_call(data()[[dataname]][cols_selected()]), + #columns = .make_reactable_columns_call(data()[[dataname]][cols_selected()]), resizable = TRUE, onClick = "select", defaultPageSize = 10, @@ -217,6 +201,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor table_q <- reactive({ req(reactable_call(), select_call()) + print(reactable_call()) data() |> eval_code(select_call()) |> eval_code(reactable_call()) @@ -275,7 +260,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor ), args ) - as.call(c(list(name = "reactable"), args)) + as.call(c(list(name = quote(reactable)), args)) } #' Makes `reactable::colDef` call containing: @@ -322,3 +307,37 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, columns, decor .name_to_id <- function(name) { gsub("[[:space:][:punct:]]+", "_", x = tolower(name)) } + +.validate_datanames <- function(datanames, data, class = "data.frame") { + all_datanames_r <- reactive({ + req(data()) + names( + Filter( + function(dataset) inherits(dataset, class), + as.list(data()) + ) + ) + }) + + this_datanames_r <- reactive({ + if (is.reactive(datanames)) { + datanames() + } else { + datanames + } + }) + + datanames_r <- reactiveVal() + + observeEvent(all_datanames_r(), { + new_datanames <- if (identical(this_datanames_r(), "all")) { + all_datanames_r() + } else { + intersect(this_datanames_r(), all_datanames_r()) + } + if (!identical(new_datanames, datanames_r())) { + datanames_r(new_datanames) + } + }) + datanames_r +} From b1e4f60dded368850eb1efd4bd75244d52314ed6 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 13 Mar 2025 15:43:09 +0000 Subject: [PATCH 059/158] wip --- R/tm_t_reactable.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index a8f8e9afc..f545b534b 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -201,7 +201,6 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco table_q <- reactive({ req(reactable_call(), select_call()) - print(reactable_call()) data() |> eval_code(select_call()) |> eval_code(reactable_call()) From 9c37a22d7621442749fba15530c2f434b0030a39 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 14 Mar 2025 10:45:46 +0000 Subject: [PATCH 060/158] freeze column --- R/tm_t_reactable.R | 129 ++++++++++++++++++++++----------------------- 1 file changed, 63 insertions(+), 66 deletions(-) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index f545b534b..2e6b0b43f 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -158,52 +158,30 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco ) }) - select_call <- reactive({ + + table_q <- reactive({ req(cols_selected()) - substitute( - lhs <- rhs, - list( + data() |> + within( # select call + lhs <- rhs, lhs = str2lang(dataname), rhs = as.call( c( list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), - lapply(cols_selected(), str2lang) + lapply(unname(cols_selected()), str2lang) ) ) - ) - ) - }) - reactable_call <- reactive({ - req(cols_selected(), data()) - default_args <- list( - #columns = .make_reactable_columns_call(data()[[dataname]][cols_selected()]), - resizable = TRUE, - onClick = "select", - defaultPageSize = 10, - rowClass = JS(" - function(rowInfo) { - if (rowInfo.selected) { - return 'selected-row'; - } - } - ") - ) - args <- modifyList(default_args, rlang::list2(...)) - - substitute( - lhs <- rhs, - list( + ) |> + within( # reactable call + lhs <- rhs, lhs = str2lang(dataname_reactable), - rhs = .make_reactable_call(dataname = dataname, args = args) + rhs = .make_reactable_call( + dataset = data()[[dataname]][cols_selected()], + dataname = dataname, + args = rlang::list2(...) + ) ) - ) - }) - - table_q <- reactive({ - req(reactable_call(), select_call()) - data() |> - eval_code(select_call()) |> - eval_code(reactable_call()) + }) output$table <- reactable::renderReactable({ logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") @@ -230,36 +208,58 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco }) } -.make_reactable_call <- function(dataname, args) { - args <- modifyList( - list( - data = str2lang(dataname), - defaultColDef = quote( - colDef( - cell = function(value) { - is_url <- is.character(value) && any( - grepl( - "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", - x = head(value), - perl = TRUE - ) +.make_reactable_call <- function(dataset, dataname, args) { + columns <- .make_reactable_columns_call(dataset) + if (length(args$columns)) { + columns <- modifyList(columns, args$columns) + args <- args[!names(args) %in% "columns"] + } + + default_args <- list( + columns = columns, + resizable = TRUE, + onClick = "select", + defaultPageSize = 10, + rowClass = JS({" + function(rowInfo) { + if (rowInfo.selected) { + return 'selected-row'; + } + } + "}), + defaultColDef = quote( + colDef( + cell = function(value) { + is_url <- is.character(value) && any( + grepl( + "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", + x = head(value), + perl = TRUE ) - if (is_url) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } + ) + if (is_url) { + if (!is.na(value) && !is.null(value) && value != "") { + htmltools::tags$a(href = value, target = "_blank", "Link") } else { - value + "N/A" } + } else { + value } - ) + } ) - ), - args + ) + ) + + as.call( + c( + list( + name = quote(reactable), + data = str2lang(dataname) + ), + modifyList(default_args, args) + ) ) - as.call(c(list(name = quote(reactable)), args)) } #' Makes `reactable::colDef` call containing: @@ -292,15 +292,12 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco ) if (length(args)) { - as.call(c(list(name = "colDef"), args)) + as.call(c(list(name = quote(colDef)), args)) } } ) names(args) <- names(dataset) - args <- Filter(length, args) - if (length(args)) { - as.call(c(list("list"), args)) - } + Filter(length, args) } .name_to_id <- function(name) { From cf14bcfd909ba5debece336b7809556e38ee55ab Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Mar 2025 13:52:21 +0000 Subject: [PATCH 061/158] wip v5 --- R/tm_g_swimlane.R | 105 +++++++++++++++++++++++++++++-------------- R/tm_t_reactable.R | 109 +++++++++++++-------------------------------- 2 files changed, 103 insertions(+), 111 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 41f93b17c..0c34581d6 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -1,6 +1,6 @@ #' @export tm_g_swimlane <- function(label = "Swimlane", - dataname, + plot_dataname, time_var, subject_var, value_var, @@ -9,15 +9,17 @@ tm_g_swimlane <- function(label = "Swimlane", group_var = NULL, value_var_color = character(0), value_var_symbol, - plot_height = 700) { + plot_height = 700, + table_datanames, + ...) { module( label = label, ui = ui_g_swimlane, server = srv_g_swimlane, - datanames = "all", + datanames = c(plot_dataname, table_datanames), ui_args = list(height = plot_height), server_args = list( - dataname = dataname, + plot_dataname = plot_dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, @@ -25,24 +27,29 @@ tm_g_swimlane <- function(label = "Swimlane", sort_var = sort_var, group_var = group_var, value_var_color = value_var_color, - value_var_symbol = value_var_symbol + value_var_symbol = value_var_symbol, + table_datanames = table_datanames, + ... ) ) } ui_g_swimlane <- function(id, height) { + + ns <- NS(id) bslib::page_fluid( bslib::layout_columns( selectInput(ns("sort_by"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - plotly::plotlyOutput(ns("plot"), height = "100%") + plotly::plotlyOutput(ns("plot"), height = "100%"), + uiOutput(ns("tables")) ) } srv_g_swimlane <- function(id, data, - dataname, + plot_dataname, time_var, subject_var, value_var, @@ -51,7 +58,9 @@ srv_g_swimlane <- function(id, group_var = NULL, value_var_color, value_var_symbol, - filter_panel_api) { + table_datanames, + filter_panel_api, + ...) { moduleServer(id, function(input, output, session) { sort_choices <- reactiveVal() @@ -81,19 +90,19 @@ srv_g_swimlane <- function(id, plotly_q <- reactive({ req(data(), sort_selected()) adjusted_colors <- .color_palette_discrete( - levels = unique(data()[[dataname]][[value_var]]), + levels = unique(data()[[plot_dataname]][[value_var]]), color = value_var_color ) adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[dataname]][[value_var]]), + levels = unique(data()[[plot_dataname]][[value_var]]), symbol = value_var_symbol ) - subject_var_label <- c(attr(data()[[dataname]][[subject_var]], "label"), "Subject")[1] - time_var_label <- c(attr(data()[[dataname]][[time_var]], "label"), "Study Day")[1] + subject_var_label <- c(attr(data()[[plot_dataname]][[subject_var]], "label"), "Subject")[1] + time_var_label <- c(attr(data()[[plot_dataname]][[time_var]], "label"), "Study Day")[1] data() |> within( - dataname = str2lang(dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", dataname)), + dataname = str2lang(plot_dataname), + dataname_filtered = str2lang(sprintf("%s_filtered", plot_dataname)), time_var = str2lang(time_var), subject_var = str2lang(subject_var), value_var = str2lang(value_var), @@ -176,28 +185,58 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) - reactive({ + plotly_selected_q <- reactive({ req(plotly_selected()) - primary_key_cols <- join_keys(plotly_q())[dataname, dataname] - if (length(primary_key_cols)) { - within( - plotly_q(), - dataname = str2lang(dataname), - time_var = str2lang(time_var), - subject_var = subject_var, - value_var = str2lang(value_var), - time_vals = plotly_selected()$x, - subject_vals = plotly_selected()$y, - primary_key_cols = primary_key_cols, - expr = { - plotly_selected_keys <- dplyr::filter(time_var %in% time_vals, subject_var %in% subject_vals) %>% - dplyr::select(primary_key_cols) - plotly_brushed_time <- time_vals - plotly_brushed_subject <- subject_vals - } - ) + primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) + req(primary_keys) + within( + plotly_q(), + expr = { + swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% + dplyr::select(primary_keys) + }, + dataname = str2lang(plot_dataname), + xvar = str2lang(time_var), + yvar = str2lang(subject_var), + xvals = plotly_selected()$x, + yvals = plotly_selected()$y, + primary_keys = primary_keys + ) + }) + + children_names <- reactive({ + if (length(table_datanames) == 0) { + children(plotly_selected_q(), plot_dataname) + } else { + table_datanames } }) + + tables_selected_q <- eventReactive(plotly_selected_q(), { + exprs <- as.expression( + lapply( + children_names(), + function(childname) { + join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] + substitute( + expr = { + childname <- dplyr::right_join(childname, swimlane_selected, by = by) + }, + list( + childname = str2lang(childname), + by = join_cols + ) + ) + } + ) + ) + eval_code(plotly_selected_q(), exprs) + }) + + output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) + + }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 2e6b0b43f..2e70236eb 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -161,26 +161,22 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco table_q <- reactive({ req(cols_selected()) - data() |> - within( # select call - lhs <- rhs, - lhs = str2lang(dataname), - rhs = as.call( - c( - list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), - lapply(unname(cols_selected()), str2lang) - ) - ) - ) |> - within( # reactable call - lhs <- rhs, - lhs = str2lang(dataname_reactable), - rhs = .make_reactable_call( - dataset = data()[[dataname]][cols_selected()], - dataname = dataname, - args = rlang::list2(...) - ) + select_call <- as.call( + c( + list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), + lapply(unname(cols_selected()), str2lang) ) + ) + + reactable_call <- .make_reactable_call( + dataset = data()[[dataname]][cols_selected()], + dataname = dataname, + args = rlang::list2(...) + ) + + data() |> + within(lhs <- rhs, lhs = str2lang(dataname), rhs = select_call) |> + within(lhs <- rhs, lhs = str2lang(dataname_reactable), rhs = reactable_call) }) output$table <- reactable::renderReactable({ @@ -209,55 +205,18 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco } .make_reactable_call <- function(dataset, dataname, args) { - columns <- .make_reactable_columns_call(dataset) - if (length(args$columns)) { - columns <- modifyList(columns, args$columns) - args <- args[!names(args) %in% "columns"] - } - - default_args <- list( - columns = columns, - resizable = TRUE, - onClick = "select", - defaultPageSize = 10, - rowClass = JS({" - function(rowInfo) { - if (rowInfo.selected) { - return 'selected-row'; - } - } - "}), - defaultColDef = quote( - colDef( - cell = function(value) { - is_url <- is.character(value) && any( - grepl( - "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", - x = head(value), - perl = TRUE - ) - ) - if (is_url) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } else { - value - } - } - ) - ) + columns <- .make_reactable_columns_call(dataset = dataset, col_defs = args$columns) + call_args <- modifyList( + list(columns = columns, onClick = "select"), + args[!names(args) %in% "columns"] ) - as.call( c( list( name = quote(reactable), data = str2lang(dataname) ), - modifyList(default_args, args) + call_args ) ) } @@ -269,30 +228,24 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco #' @param dataset (`data.frame`) #' @return named list of `colDef` calls #' @keywords internal -.make_reactable_columns_call <- function(dataset) { +.make_reactable_columns_call <- function(dataset, col_defs) { checkmate::assert_data_frame(dataset) args <- lapply( - seq_along(dataset), + colnames(dataset), function(i) { column <- dataset[[i]] label <- attr(column, "label") is_labelled <- length(label) == 1 && !is.na(label) && !identical(label, "") - is_url <- is.character(column) && any( - grepl( - "https?:\\/\\/(www\\.)?[-a-zA-Z0-9@:%._\\+~#=]{1,256}\\.[a-zA-Z0-9()]{1,6}\\b([-a-zA-Z0-9()@:%_\\+.~#?&//=]*)", - x = head(column), - perl = TRUE + default_col_def <- if (is_labelled) list(name = label) else list() + col_def_override <- if (!is.null(col_defs[[i]])) col_defs[[i]] else list() + col_def_args <- modifyList(default_col_def, col_def_override) + if (length(col_def_args)) { + as.call( + c( + list(quote(colDef)), + col_def_args + ) ) - ) - # todo: move url formatter to the defaultColDef - width <- max(nchar(head(as.character(column), 100))) * 9 - args <- c( - if (!is.na(width) && width > 100 && !is_url) list(width = width), - if (is_labelled) list(name = label) - ) - - if (length(args)) { - as.call(c(list(name = quote(colDef)), args)) } } ) From bf0cbaddd5629080a7d2f6e575000b027691867b Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Mar 2025 15:24:36 +0000 Subject: [PATCH 062/158] wip v5 --- R/tm_g_swimlane.R | 23 +++++++++++------------ R/tm_g_waterfall.R | 5 ++--- 2 files changed, 13 insertions(+), 15 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 0c34581d6..de6747c4e 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -44,7 +44,7 @@ ui_g_swimlane <- function(id, height) { sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), plotly::plotlyOutput(ns("plot"), height = "100%"), - uiOutput(ns("tables")) + ui_t_reactables(ns("subtables")) ) } srv_g_swimlane <- function(id, @@ -82,10 +82,7 @@ srv_g_swimlane <- function(id, isolate(sort_selected(sort_var)) shinyjs::hide("sort_by") } - - - - + plotly_q <- reactive({ req(data(), sort_selected()) @@ -162,13 +159,16 @@ srv_g_swimlane <- function(id, group_by(subject_var, time_var) %>% mutate( tooltip = paste( - unique(c( - paste(subject_var_label, subject_var), - paste(time_var_label, time_var), - sprintf("%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) - )), + unique( + c( + paste(subject_var_label, subject_var), + paste(time_var_label, time_var), + sprintf("%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) + ) + ), collapse = "
" - )) %>% + ) + ) %>% plotly_fun() } ) @@ -233,7 +233,6 @@ srv_g_swimlane <- function(id, eval_code(plotly_selected_q(), exprs) }) - output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index e8b014f4a..ec29003cd 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -40,7 +40,7 @@ ui_g_waterfall <- function(id, height) { column(6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) ), plotly::plotlyOutput(ns("plot"), height = "100%"), - uiOutput(ns("tables")) + ui_t_reactables(ns("subtables")) ) } srv_g_waterfall <- function(id, @@ -193,8 +193,7 @@ srv_g_waterfall <- function(id, ) eval_code(plotly_selected_q(), exprs) }) - - output$tables <- renderUI(ui_t_reactables(session$ns("subtables"))) + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) }) } From e9ac8241d71fc5d4b9149ea318b02b43d710b5a1 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 17 Mar 2025 15:39:12 +0000 Subject: [PATCH 063/158] wip v5 --- R/tm_g_swimlane.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index de6747c4e..530028e57 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -234,7 +234,6 @@ srv_g_swimlane <- function(id, }) srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) - }) } From 165d891f872c212380b8a357827714519942484d Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 07:17:12 +0000 Subject: [PATCH 064/158] wip v5 --- R/tm_g_waterfall.R | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index ec29003cd..ebd02f243 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -81,7 +81,13 @@ srv_g_waterfall <- function(id, attr(data()[[plot_dataname]][[value_var]], "label"), value_var )[1] - + + color_var_label <- c( + attr(data()[[plot_dataname]][[input$color_by]], "label"), + input$color_by + )[1] + + data() |> within( dataname = str2lang(plot_dataname), @@ -93,13 +99,21 @@ srv_g_waterfall <- function(id, value_arbitrary_hlines = value_arbitrary_hlines, subject_var_label = subject_var_label, value_var_label = value_var_label, + color_var_label = color_var_label, title = paste0(value_var_label, " (Waterfall plot)"), height = input$plot_height, expr = { p <- dataname %>% dplyr::mutate( - subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE) + subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE), + tooltip = sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, subject_var, + value_var_label, value_var, + color_var_label, color_var + ) ) %>% + dplyr::filter(!duplicated(subject_var)) %>% # todo: one value for x, y: distinct or summarize(value = foo(value_var)) [foo: summarize_fun] plotly::plot_ly( @@ -111,10 +125,7 @@ srv_g_waterfall <- function(id, y = ~value_var, color = ~color_var, colors = colors, - text = ~ paste( - subject_var_label, ":", subject_var, - value_var_label, ":", value_var, "
" - ), + text = ~ tooltip, hoverinfo = "text" ) %>% plotly::layout( From 607105a15cb9e904f6f17a3abf7395ab2ce11b68 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 13:43:23 +0000 Subject: [PATCH 065/158] spiderplot lines blue --- R/tm_g_spiderplot.R | 96 +++++++++++++++++++++++++-------- R/tm_g_swimlane.R | 7 +-- R/tm_g_waterfall.R | 2 +- R/tm_swimlane_mdr.R | 127 -------------------------------------------- 4 files changed, 79 insertions(+), 153 deletions(-) delete mode 100644 R/tm_swimlane_mdr.R diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 082cb8213..c3ad97faf 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -1,10 +1,16 @@ #' @export tm_g_spiderplot <- function(label = "Spiderplot", + plot_dataname, time_var, subject_var, value_var, event_var, + color_var, + point_colors, + point_symbols, plot_height = 600, + table_datanames = character(0), + reactable_args = list(), transformator = transformator) { module( label = label, @@ -12,12 +18,18 @@ tm_g_spiderplot <- function(label = "Spiderplot", server = srv_g_spiderplot, ui_args = list(height = plot_height), server_args = list( + plot_dataname = plot_dataname, time_var = time_var, subject_var = subject_var, value_var = value_var, - event_var = event_var + event_var = event_var, + color_var = color_var, + point_colors = point_colors, + point_symbols = point_symbols, + table_datanames = table_datanames, + reactable_args = reactable_args ), - datanames = "all", + datanames = union(plot_dataname, table_datanames) ) } @@ -43,17 +55,22 @@ ui_g_spiderplot <- function(id, height) { srv_g_spiderplot <- function(id, data, - dataname, + plot_dataname, time_var, subject_var, value_var, event_var, - filter_panel_api, - plot_height = 600) { + color_var, + point_colors, + point_symbols, + plot_height = 600, + table_datanames, + reactable_args, + filter_panel_api) { moduleServer(id, function(input, output, session) { event_levels <- reactive({ req(data()) - unique(data()[[dataname]][[event_var]]) + unique(data()[[plot_dataname]][[event_var]]) }) observeEvent(event_levels(), { updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) @@ -62,34 +79,69 @@ srv_g_spiderplot <- function(id, plotly_q <- reactive({ # todo: tooltip! req(input$select_event) - within( + + time_var_label <- c( + attr(data()[[plot_dataname]][[time_var]], "label"), + time_var + )[1] + + subject_var_label <- c( + attr(data()[[plot_dataname]][[subject_var]], "label"), + subject_var + )[1] + + ee <- within( data(), - dataname = str2lang(dataname), + dataname = str2lang(plot_dataname), time_var = str2lang(time_var), subject_var = str2lang(subject_var), value_var = str2lang(value_var), event_var = str2lang(event_var), + color_var = str2lang(color_var), selected_event = input$select_event, height = input$plot_height, - xaxis_label = attr(data()[[dataname]][[time_var]], "label"), - yaxis_label = input$select_event, + time_var_label = time_var_label, + event_var_label = input$select_event, + subject_var_label = subject_var_label, title = paste0(input$select_event, " Over Time"), expr = { - p <- dataname |> filter(event_var == selected_event)|> - plotly::plot_ly(source = "spiderplot", height = height) |> + dd <- dataname %>% + arrange(subject_var, time_var) %>% + filter(event_var == selected_event) %>% + mutate( + tooltip = sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, subject_var, + time_var_label, time_var, + event_var_label, value_var + ) + ) %>% + group_by(subject_var) # %>% + # group_modify(~ { + # .first_x <- within(.x[1, ], { + # value_var <- 0 + # time_var <- 0 + # }) + # bind_rows(.first_x, .x) + # }) + p <- dd |> plotly::plot_ly(source = "spiderplot", height = height) %>% + plotly::add_trace( + x = ~time_var, + y = ~value_var, + mode = 'lines+markers', + text = ~ tooltip, + hoverinfo = "text" + ) %>% plotly::add_markers( - x = ~time_var, y = ~value_var, color = ~subject_var - ) |> - plotly::add_lines( - x = ~time_var, y = ~value_var, color = ~subject_var, - showlegend = FALSE - ) |> + x = ~time_var, y = ~value_var, color = ~color_var, symbol = ~color_var + ) %>% plotly::layout( - xaxis = list(title = xaxis_label, zeroline = FALSE), - yaxis = list(title = yaxis_label), + xaxis = list(title = time_var_label), + yaxis = list(title = event_var_label), title = title, + showlegend = FALSE, dragmode = "select" - ) |> + ) %>% plotly::config(displaylogo = FALSE) } ) @@ -103,7 +155,7 @@ srv_g_spiderplot <- function(id, req(plotly_selected()) within( plotly_q(), - dataname = str2lang(dataname), + dataname = str2lang(plot_dataname), time_var = str2lang(time_var), subject_var = subject_var, value_var = str2lang(value_var), diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 530028e57..8a4ae95df 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -10,7 +10,7 @@ tm_g_swimlane <- function(label = "Swimlane", value_var_color = character(0), value_var_symbol, plot_height = 700, - table_datanames, + table_datanames = character(0), ...) { module( label = label, @@ -137,11 +137,12 @@ srv_g_swimlane <- function(id, y = ~subject_var_ordered, yend = ~subject_var_ordered, color = ~event_var, data = data |> group_by(subject_var_ordered, event_var) |> summarise(study_day = max(time_var)), - line = list(width = 1, color = "grey"), + line = list(width = 2, color = "grey"), showlegend = FALSE ) %>% plotly::layout( - xaxis = list(title = time_axis_label), yaxis = list(title = subject_axis_label) + xaxis = list(title = time_axis_label), + yaxis = list(title = subject_axis_label) ) %>% plotly::layout(dragmode = "select") %>% plotly::config(displaylogo = FALSE) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index ebd02f243..5e13188c8 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -8,7 +8,7 @@ tm_g_waterfall <- function(label = "Waterfall", value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", plot_height = 700, - table_datanames, + table_datanames = character(0), ...) { module( label = label, diff --git a/R/tm_swimlane_mdr.R b/R/tm_swimlane_mdr.R deleted file mode 100644 index 68557078e..000000000 --- a/R/tm_swimlane_mdr.R +++ /dev/null @@ -1,127 +0,0 @@ -#' @export -tm_g_swimlane_mdr <- function(label = "Swimlane", - plot_dataname, - time_var, - subject_var, - value_var, - event_var, - sort_var = time_var, - group_var = NULL, - listing_datanames = character(0), - value_var_color = c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue", - "X Administration Injection" = "goldenrod", - "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid" - ), - # possible markers https://plotly.com/python/marker-style/ - value_var_symbol = c( - "DEATH" = "circle", - "WITHDRAWAL BY SUBJECT" = "square", - "PD (Progressive Disease)" = "circle", - "SD (Stable Disease)" = "square-open", - "MR (Minimal/Minor Response)" = "star-open", - "PR (Partial Response)" = "star-open", - "VGPR (Very Good Partial Response)" = "star-open", - "CR (Complete Response)" = "star-open", - "SCR (Stringent Complete Response)" = "star-open", - "X Administration Injection" = "line-ns", - "Y Administration Infusion" = "line-ns", - "Z Administration Infusion" = "line-ns" - ), - plot_height = 700) { - checkmate::assert_character(value_var_color) - module( - label = label, - ui = ui_g_swimlane_mdr, - server = srv_g_swimlane_mdr, - datanames = union(plot_dataname, listing_datanames), - ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - time_var = time_var, - subject_var = subject_var, - value_var = value_var, - event_var = event_var, - sort_var = sort_var, - group_var = group_var, - value_var_color = value_var_color, - value_var_symbol = value_var_symbol, - listing_datanames = listing_datanames, - plot_height = plot_height - ) - ) -} - -ui_g_swimlane_mdr <- function(id, height) { - ns <- NS(id) - tagList( - div( - h4("Swim Lane - Duration of Tx"), - ui_g_swimlane(ns("plot"), height = height) - ), - ui_t_reactables(ns("subtables")) - ) -} -srv_g_swimlane_mdr <- function(id, - data, - plot_dataname, - time_var, - subject_var, - value_var, - event_var, - sort_var, - group_var, - value_var_color, - value_var_symbol, - listing_datanames, - filter_panel_api, - plot_height = 600) { - moduleServer(id, function(input, output, session) { - plotly_selected_q <- srv_g_swimlane( - "plot", - data = data, - dataname = plot_dataname, - time_var = time_var, - subject_var = subject_var, - value_var = value_var, - event_var = event_var, - sort_var = sort_var, - group_var = group_var, - value_var_color = value_var_color, - value_var_symbol = value_var_symbol, - filter_panel_api = filter_panel_api - ) - - if (length(listing_datanames)) { - listings_q <- reactive({ - req(plotly_selected_q()) - calls <- lapply(seq_along(listing_datanames), function(i) { - listing_name <- listing_names[i] - listing_label <- attr(plotly_selected_q()[[listing_name]], "label") - substitute( - list( - listing_name = str2lang(listing_name), - listing_selected = str2lang(sprintf("%s_selected", listing_name)), - listing_label = listing_label, - subject_var = str2lang(subject_var) - ), - expr = { - listing_selected <- dplyr::filter(listing_name, subject_var %in% plotly_brushed_subject) - } - ) - }) - teal.code::eval_code(plotly_selected_q(), as.expression(calls)) - }) - srv_t_reactables("subtables", data = listings_q, datanames = listing_datanames, layout = "tabs") - } - }) -} From cb5c6164e4bf153ccbac49c7977a13413fd4e7bd Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 15:07:20 +0000 Subject: [PATCH 066/158] wip v5 --- R/tm_g_spiderplot.R | 98 ++++++++++++++++++++++++++++++--------------- R/tm_g_swimlane.R | 10 ++--- R/tm_g_waterfall.R | 30 +++++++------- R/tm_t_reactable.R | 18 +++++---- 4 files changed, 95 insertions(+), 61 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index c3ad97faf..05949fe2a 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -48,7 +48,8 @@ ui_g_spiderplot <- function(id, height) { sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ) ), - plotly::plotlyOutput(ns("plot"), height = "100%") + plotly::plotlyOutput(ns("plot"), height = "100%"), + ui_t_reactables(ns("subtables")) ) } @@ -64,8 +65,8 @@ srv_g_spiderplot <- function(id, point_colors, point_symbols, plot_height = 600, - table_datanames, - reactable_args, + table_datanames = character(0), + reactable_args = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { event_levels <- reactive({ @@ -108,38 +109,38 @@ srv_g_spiderplot <- function(id, dd <- dataname %>% arrange(subject_var, time_var) %>% filter(event_var == selected_event) %>% + group_by(subject_var) %>% mutate( + x = dplyr::lag(time_var, default = 0), + y = dplyr:::lag(value_var, default = 0), tooltip = sprintf( "%s: %s
%s: %s%%
%s: %s", subject_var_label, subject_var, time_var_label, time_var, event_var_label, value_var ) - ) %>% - group_by(subject_var) # %>% - # group_modify(~ { - # .first_x <- within(.x[1, ], { - # value_var <- 0 - # time_var <- 0 - # }) - # bind_rows(.first_x, .x) - # }) - p <- dd |> plotly::plot_ly(source = "spiderplot", height = height) %>% - plotly::add_trace( - x = ~time_var, + ) + p <- dd |> plotly::plot_ly( + source = "spiderplot", + height = height, + x = ~x, + y = ~y, + xend = ~time_var, + yend = ~value_var, + color = ~color_var + ) %>% + plotly::add_segments() %>% + plotly::add_markers( + x = ~time_var, y = ~value_var, - mode = 'lines+markers', + symbol = ~color_var, text = ~ tooltip, hoverinfo = "text" ) %>% - plotly::add_markers( - x = ~time_var, y = ~value_var, color = ~color_var, symbol = ~color_var - ) %>% plotly::layout( xaxis = list(title = time_var_label), yaxis = list(title = event_var_label), title = title, - showlegend = FALSE, dragmode = "select" ) %>% plotly::config(displaylogo = FALSE) @@ -148,24 +149,57 @@ srv_g_spiderplot <- function(id, }) output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - - reactive({ + + plotly_selected_q <- reactive({ req(plotly_selected()) + primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) + req(primary_keys) within( plotly_q(), - dataname = str2lang(plot_dataname), - time_var = str2lang(time_var), - subject_var = subject_var, - value_var = str2lang(value_var), - time_vals = plotly_selected()$x, - value_vals = plotly_selected()$y, expr = { - plotly_brushed_time <- time_vals - plotly_brushed_value <- value_vals - } + spiderplot_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% + dplyr::select(primary_keys) + }, + dataname = str2lang(plot_dataname), + xvar = str2lang(time_var), + yvar = str2lang(value_var), + xvals = plotly_selected()$x, + yvals = plotly_selected()$y, + primary_keys = primary_keys + ) + }) + + children_names <- reactive({ + if (length(table_datanames) == 0) { + children(plotly_selected_q(), plot_dataname) + } else { + table_datanames + } + }) + + tables_selected_q <- eventReactive(plotly_selected_q(), { + exprs <- as.expression( + lapply( + children_names(), + function(childname) { + join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] + substitute( + expr = { + childname <- dplyr::right_join(childname, spiderplot_selected, by = by) + }, + list( + childname = str2lang(childname), + by = join_cols + ) + ) + } + ) ) + eval_code(plotly_selected_q(), exprs) }) + + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 8a4ae95df..771edca8a 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -11,7 +11,7 @@ tm_g_swimlane <- function(label = "Swimlane", value_var_symbol, plot_height = 700, table_datanames = character(0), - ...) { + reactable_args = list()) { module( label = label, ui = ui_g_swimlane, @@ -29,7 +29,7 @@ tm_g_swimlane <- function(label = "Swimlane", value_var_color = value_var_color, value_var_symbol = value_var_symbol, table_datanames = table_datanames, - ... + reactable_args = reactable_args ) ) } @@ -59,8 +59,8 @@ srv_g_swimlane <- function(id, value_var_color, value_var_symbol, table_datanames, - filter_panel_api, - ...) { + reactable_args = list(), + filter_panel_api) { moduleServer(id, function(input, output, session) { sort_choices <- reactiveVal() @@ -234,7 +234,7 @@ srv_g_swimlane <- function(id, eval_code(plotly_selected_q(), exprs) }) - srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 5e13188c8..1ceabb29b 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -9,25 +9,23 @@ tm_g_waterfall <- function(label = "Waterfall", plot_title = "Waterfall plot", plot_height = 700, table_datanames = character(0), - ...) { + reactable_args = list()) { module( label = label, ui = ui_g_waterfall, server = srv_g_waterfall, datanames = union(plot_dataname, table_datanames), ui_args = list(height = plot_height), - server_args = c( - list( - plot_dataname = plot_dataname, - table_datanames = table_datanames, - subject_var = subject_var, - value_var = value_var, - color_var = color_var, - bar_colors = bar_colors, - value_arbitrary_hlines = value_arbitrary_hlines, - plot_title = plot_title - ), - list(...) + server_args = list( + plot_dataname = plot_dataname, + table_datanames = table_datanames, + subject_var = subject_var, + value_var = value_var, + color_var = color_var, + bar_colors = bar_colors, + value_arbitrary_hlines = value_arbitrary_hlines, + plot_title = plot_title, + reactable_args = reactable_args ) ) } @@ -54,8 +52,8 @@ srv_g_waterfall <- function(id, plot_title, plot_height = 600, table_datanames = character(0), - filter_panel_api, - ...) { + reactable_args = list(), + filter_panel_api) { moduleServer(id, function(input, output, session) { output$color_by_output <- renderUI({ selectInput(session$ns("color_by"), label = "Color by:", choices = color_var$choices, selected = color_var$selected) @@ -205,7 +203,7 @@ srv_g_waterfall <- function(id, eval_code(plotly_selected_q(), exprs) }) - srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, ...) + srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 2e70236eb..38745ee9c 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -4,15 +4,17 @@ tm_t_reactables <- function(label = "Table", colnames = list(), transformators = list(), decorators = list(), - ...) { + reactable_args = list()) { module( label = label, ui = ui_t_reactables, server = srv_t_reactables, ui_args = list(decorators = decorators), - server_args = c( - list(datanames = datanames, colnames = colnames, decorators = decorators), - rlang::list2(...) + server_args = list( + datanames = datanames, + colnames = colnames, + reactable_args = reactable_args, + decorators = decorators ), datanames = datanames, transformators = transformators @@ -24,7 +26,7 @@ ui_t_reactables <- function(id, decorators = list()) { uiOutput(ns("subtables"), container = bslib::page_fluid) } -srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), ...) { +srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), reactable_args = list()) { moduleServer(id, function(input, output, session) { # todo: this to the function .validate_datanames datanames_r <- .validate_datanames(datanames = datanames, data = data) @@ -83,7 +85,7 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = l dataname = dataname, filter_panel_api = filter_panel_api, colnames = colnames[[dataname]], - ... + reactable_args = reactable_args ) } ) @@ -118,7 +120,7 @@ ui_t_reactable <- function(id) { ) } -srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, decorators, ...) { +srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, decorators, reactable_args = list()) { moduleServer(id, function(input, output, session) { logger::log_debug("srv_t_reactable initializing for dataname: { dataname }") dataname_reactable <- sprintf("%s_reactable", dataname) @@ -171,7 +173,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco reactable_call <- .make_reactable_call( dataset = data()[[dataname]][cols_selected()], dataname = dataname, - args = rlang::list2(...) + args = reactable_args ) data() |> From 18fd08c41e336335ad04478da52359f2c5c1ffff Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 15:08:28 +0000 Subject: [PATCH 067/158] wip v5 --- NAMESPACE | 1 - man/dot-make_reactable_columns_call.Rd | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 1c5bcba30..8edbf3232 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,7 +24,6 @@ export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) export(tm_g_spiderplot) export(tm_g_swimlane) -export(tm_g_swimlane_mdr) export(tm_g_waterfall) export(tm_missing_data) export(tm_outliers) diff --git a/man/dot-make_reactable_columns_call.Rd b/man/dot-make_reactable_columns_call.Rd index 22b11063e..079641f10 100644 --- a/man/dot-make_reactable_columns_call.Rd +++ b/man/dot-make_reactable_columns_call.Rd @@ -7,7 +7,7 @@ name = \if{html}{\out{}} cell = \if{html}{\out{}} Arguments of \code{\link[reactable:colDef]{reactable::colDef()}} are specified only if necessary} \usage{ -.make_reactable_columns_call(dataset) +.make_reactable_columns_call(dataset, col_defs) } \arguments{ \item{dataset}{(\code{data.frame})} From 02040a5b2b4c511264b59072ab5c97b9e33e6c3e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 20:49:13 +0000 Subject: [PATCH 068/158] wip v5 --- R/tm_g_spiderplot.R | 76 ++++++++++++++++++++++++++++----------------- R/tm_g_swimlane.R | 2 +- R/tm_g_waterfall.R | 1 + R/tm_t_reactable.R | 6 ++-- 4 files changed, 51 insertions(+), 34 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 05949fe2a..770349e5c 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -78,9 +78,18 @@ srv_g_spiderplot <- function(id, }) plotly_q <- reactive({ - # todo: tooltip! req(input$select_event) + adjusted_colors <- .color_palette_discrete( + levels = unique(data()[[plot_dataname]][[color_var]]), + color = point_colors + ) + + adjusted_symbols <- .shape_palette_discrete( + levels = unique(data()[[plot_dataname]][[color_var]]), + symbol = point_symbols + ) + time_var_label <- c( attr(data()[[plot_dataname]][[time_var]], "label"), time_var @@ -100,50 +109,59 @@ srv_g_spiderplot <- function(id, event_var = str2lang(event_var), color_var = str2lang(color_var), selected_event = input$select_event, + colors = adjusted_colors, + symbols = adjusted_symbols, height = input$plot_height, time_var_label = time_var_label, event_var_label = input$select_event, subject_var_label = subject_var_label, title = paste0(input$select_event, " Over Time"), expr = { - dd <- dataname %>% - arrange(subject_var, time_var) %>% + plotly_fun <- function(data) { + data %>% + plotly::plot_ly( + source = "spiderplot", + height = height, + color = ~color_var, + colors = colors, + symbols = symbols + ) %>% + plotly::add_segments( + x = ~x, + y = ~y, + xend = ~time_var, + yend = ~value_var + ) %>% + plotly::add_markers( + x = ~time_var, + y = ~value_var, + symbol = ~color_var, + text = ~ tooltip, + hoverinfo = "text" + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = event_var_label), + title = title, + dragmode = "select" + ) %>% + plotly::config(displaylogo = FALSE) + } + p <- dataname %>% filter(event_var == selected_event) %>% + arrange(subject_var, time_var) %>% group_by(subject_var) %>% mutate( x = dplyr::lag(time_var, default = 0), y = dplyr:::lag(value_var, default = 0), tooltip = sprintf( - "%s: %s
%s: %s%%
%s: %s", + "%s: %s
%s: %s
%s: %s%%", subject_var_label, subject_var, time_var_label, time_var, - event_var_label, value_var + event_var_label, value_var * 100 ) - ) - p <- dd |> plotly::plot_ly( - source = "spiderplot", - height = height, - x = ~x, - y = ~y, - xend = ~time_var, - yend = ~value_var, - color = ~color_var - ) %>% - plotly::add_segments() %>% - plotly::add_markers( - x = ~time_var, - y = ~value_var, - symbol = ~color_var, - text = ~ tooltip, - hoverinfo = "text" - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = event_var_label), - title = title, - dragmode = "select" ) %>% - plotly::config(displaylogo = FALSE) + plotly_fun() } ) }) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 771edca8a..70c1aafe4 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -135,7 +135,6 @@ srv_g_swimlane <- function(id, plotly::add_segments( x = ~0, xend = ~study_day, y = ~subject_var_ordered, yend = ~subject_var_ordered, - color = ~event_var, data = data |> group_by(subject_var_ordered, event_var) |> summarise(study_day = max(time_var)), line = list(width = 2, color = "grey"), showlegend = FALSE @@ -188,6 +187,7 @@ srv_g_swimlane <- function(id, plotly_selected_q <- reactive({ req(plotly_selected()) + # todo: change it to foreign keys needed to merge with table_datanames primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) req(primary_keys) within( diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 1ceabb29b..41ae0e99d 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -65,6 +65,7 @@ srv_g_waterfall <- function(id, } plotly_q <- reactive({ req(data(), input$color_by) + adjusted_colors <- .color_palette_discrete( levels = unique(data()[[plot_dataname]][[input$color_by]]), color = bar_colors[[input$color_by]] diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 38745ee9c..08ee2eb4d 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -28,7 +28,6 @@ ui_t_reactables <- function(id, decorators = list()) { srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), reactable_args = list()) { moduleServer(id, function(input, output, session) { - # todo: this to the function .validate_datanames datanames_r <- .validate_datanames(datanames = datanames, data = data) colnames_r <- reactive({ req(datanames_r()) @@ -49,7 +48,6 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = l }) }) - # todo: re-render only if datanames changes output$subtables <- renderUI({ logger::log_debug("srv_t_reactables@1 render subtables") if (length(datanames_r()) == 0) { @@ -160,7 +158,6 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco ) }) - table_q <- reactive({ req(cols_selected()) select_call <- as.call( @@ -185,7 +182,8 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") table_q()[[dataname_reactable]] }) - + + # todo: add select -> show children table table_selected_q <- reactive({ selected_row <- reactable::getReactableState("table", "selected") if (!is.null(selected_row)) { From b926f3553e423c322a65626dcbb32e408f1bce82 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 18 Mar 2025 21:23:17 +0000 Subject: [PATCH 069/158] wip v5 --- R/tm_g_spiderplot.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 770349e5c..8167b7136 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -161,6 +161,7 @@ srv_g_spiderplot <- function(id, event_var_label, value_var * 100 ) ) %>% + ungroup() %>% plotly_fun() } ) From 4495bc7428f7c6f33f8857b3e67ff902e4538fc0 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 25 Mar 2025 11:39:59 +0000 Subject: [PATCH 070/158] major cleaning --- R/module_colur_picker.R | 99 +++++++ R/roxygen2_templates.R | 52 ++++ R/tm_g_spiderplot.R | 253 ++++++++--------- R/tm_g_swimlane.R | 302 ++++++++++----------- R/tm_g_waterfall.R | 278 +++++++++---------- R/tm_t_reactable.R | 14 +- R/utils.R | 170 ++++++------ man/dot-color_palette_discrete.Rd | 2 +- man/dot-plotly_selected_filter_children.Rd | 35 +++ man/shared_params.Rd | 8 +- man/tm_a_pca.Rd | 4 +- man/tm_a_regression.Rd | 4 +- man/tm_g_association.Rd | 4 +- man/tm_g_bivariate.Rd | 4 +- man/tm_g_distribution.Rd | 4 +- man/tm_g_response.Rd | 4 +- man/tm_g_scatterplot.Rd | 4 +- man/tm_g_scatterplotmatrix.Rd | 4 +- man/tm_g_spiderplot.Rd | 57 ++++ man/tm_g_swimlane.Rd | 61 +++++ man/tm_g_waterfall.Rd | 52 ++++ man/tm_missing_data.Rd | 4 +- man/tm_outliers.Rd | 4 +- man/tm_t_crosstable.Rd | 4 +- man/tm_t_reactables.Rd | 41 +++ 25 files changed, 905 insertions(+), 563 deletions(-) create mode 100644 R/module_colur_picker.R create mode 100644 man/dot-plotly_selected_filter_children.Rd create mode 100644 man/tm_g_spiderplot.Rd create mode 100644 man/tm_g_swimlane.Rd create mode 100644 man/tm_g_waterfall.Rd create mode 100644 man/tm_t_reactables.Rd diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R new file mode 100644 index 000000000..2d363e371 --- /dev/null +++ b/R/module_colur_picker.R @@ -0,0 +1,99 @@ +# todo: to teal widgets? + +colour_picker_ui <- function(id) { + ns <- NS(id) + bslib::accordion( + uiOutput(ns("module"), title = "Event colors:", container = bslib::accordion_panel), + open = FALSE + ) +} + +colour_picker_srv <- function(id, x, default_colors) { + moduleServer(id, function(input, output, session) { + default_colors_adjusted <- reactive({ + req(x()) + .color_palette_discrete( + levels = unique(x()), + color = default_colors + ) + }) + + color_values <- reactiveVal() + observeEvent(default_colors_adjusted(), { + if (!identical(default_colors_adjusted(), color_values())) { + color_values(default_colors_adjusted()) + } + }) + + output$module <- renderUI({ + tagList( + lapply( + names(color_values()), + function(level) { + div( + colourpicker::colourInput( + inputId = session$ns(.name_to_id(level)), + label = level, + value = color_values()[level] + ) + ) + } + ) + ) + }) + + color_input_values <- reactiveVal() + observe({ + req(color_values()) + new_input_values <- sapply(names(color_values()), function(level) { + c(input[[.name_to_id(level)]], color_values()[[level]])[1] + }) + if (!identical(new_input_values, isolate(color_input_values()))) { + isolate(color_input_values(new_input_values)) + } + }) + + color_input_values + }) +} + + + +#' Color palette discrete +#' +#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by +#' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels +#' as the rest will be filled automatically. +#' @param levels (`character`) values of possible variable levels +#' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`. +#' @return `character` with hex colors named by `levels`. +.color_palette_discrete <- function(levels, color) { + p <- color[names(color) %in% levels] + p_rgb_num <- col2rgb(p) + p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) + p <- setNames(p_hex, names(p)) + missing_levels <- setdiff(levels, names(p)) + N <- length(levels) + n <- length(p) + m <- N - n + if (m > 0 && n > 0) { + current_space <- rgb2hsv(col2rgb(p)) + optimal_color_space <- colorspace::qualitative_hcl(N) + color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) + optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] + furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) + missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] + p <- c(p, setNames(missing_colors, missing_levels)) + } else if (length(missing_levels)) { + colorspace::qualitative_hcl(N) + } else { + p + } + p[names(p) %in% levels] +} + +.shape_palette_discrete <- function(levels, symbol) { + s <- setNames(symbol[levels], levels) + s[is.na(s)] <- "circle-open" + s +} diff --git a/R/roxygen2_templates.R b/R/roxygen2_templates.R index 8ff396409..d8e1145f0 100644 --- a/R/roxygen2_templates.R +++ b/R/roxygen2_templates.R @@ -14,3 +14,55 @@ roxygen_ggplot2_args_param <- function(...) { } # nocov end + +#' Shared parameters documentation +#' +#' Defines common arguments shared across multiple functions in the package +#' to avoid repetition by using `inheritParams`. +#' +#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of +#' `value`, `min`, and `max` intended for use with a slider UI element. +#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of +#' `value`, `min`, and `max` for a slider encoding the plot width. +#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not +#' rotate by default (`FALSE`). +#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. +#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] +#' with settings for the module plot. +#' The argument is merged with options variable `teal.ggplot2_args` and default module setup. +#' +#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")` +#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] +#' with settings for the module table. +#' The argument is merged with options variable `teal.basic_table_args` and default module setup. +#' +#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")` +#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, +#' providing context or a title. +#' with text placed before the output to put the output into context. For example a title. +#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, +#' adding context or further instructions. Elements like `shiny::helpText()` are useful. +#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. +#' - When the length of `alpha` is one: the plot points will have a fixed opacity. +#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on +#' vector of `value`, `min`, and `max`. +#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. +#' - When the length of `size` is one: the plot point sizes will have a fixed size. +#' - When the length of `size` is three: the plot points size are dynamically adjusted based on +#' vector of `value`, `min`, and `max`. +#' @param decorators `r lifecycle::badge("experimental")` +#' (named `list` of lists of `teal_transform_module`) optional, +#' decorator for tables or plots included in the module output reported. +#' The decorators are applied to the respective output objects. +#' +#' @param table_datanames (`character`) names of the datasets which should be listed below the plot +#' when some data points are selected. Objects named after `table_datanames` will be pulled from +#' `data` so it is important that data actually contains these datasets. Please be aware that +#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. +#' See section "Decorating Module" below for more details. +#' +#' @return Object of class `teal_module` to be used in `teal` applications. +#' +#' @name shared_params +#' @keywords internal +NULL \ No newline at end of file diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 8167b7136..4b4129e50 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -1,9 +1,27 @@ +#' `teal` module: Spider Plot +#' +#' Module visualizes value development in time grouped by subjects. +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. +#' @param time_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as x-axis. +#' @param value_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as y-axis. +#' column. +#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to be used as grouping variable for displayed lines/points. +#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to be used to differentiate colors and symbols. +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' by levels of `color_var` column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` +#' column. #' @export tm_g_spiderplot <- function(label = "Spiderplot", plot_dataname, time_var, - subject_var, value_var, + subject_var, event_var, color_var, point_colors, @@ -20,8 +38,8 @@ tm_g_spiderplot <- function(label = "Spiderplot", server_args = list( plot_dataname = plot_dataname, time_var = time_var, - subject_var = subject_var, value_var = value_var, + subject_var = subject_var, event_var = event_var, color_var = color_var, point_colors = point_colors, @@ -36,21 +54,16 @@ tm_g_spiderplot <- function(label = "Spiderplot", ui_g_spiderplot <- function(id, height) { ns <- NS(id) - div( - div( - class = "row", - column( - width = 6, - selectInput(ns("select_event"), "Select Y Axis", NULL) - ), - column( - width = 6, - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) - ) + bslib::page_sidebar( + sidebar = div( + selectInput(ns("select_event"), "Select Y Axis", NULL), + colour_picker_ui(ns("colors")), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) - + bslib::page_fillable( + plotly::plotlyOutput(ns("plot"), height = "100%"), + ui_t_reactables(ns("subtables")) + ) ) } @@ -58,8 +71,8 @@ srv_g_spiderplot <- function(id, data, plot_dataname, time_var, - subject_var, value_var, + subject_var, event_var, color_var, point_colors, @@ -77,92 +90,48 @@ srv_g_spiderplot <- function(id, updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) }) + color_inputs <- colour_picker_srv( + "colors", + x = reactive(data()[[plot_dataname]][[color_var]]), + default_colors = point_colors + ) + plotly_q <- reactive({ - req(input$select_event) - - adjusted_colors <- .color_palette_discrete( - levels = unique(data()[[plot_dataname]][[color_var]]), - color = point_colors - ) - + req(input$select_event, color_inputs()) + adjusted_symbols <- .shape_palette_discrete( levels = unique(data()[[plot_dataname]][[color_var]]), symbol = point_symbols ) - time_var_label <- c( - attr(data()[[plot_dataname]][[time_var]], "label"), - time_var - )[1] - - subject_var_label <- c( - attr(data()[[plot_dataname]][[subject_var]], "label"), - subject_var - )[1] - - ee <- within( + within( data(), dataname = str2lang(plot_dataname), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - event_var = str2lang(event_var), - color_var = str2lang(color_var), + event_var_lang = str2lang(event_var), + time_var = time_var, + value_var = value_var, + subject_var = subject_var, + event_var = event_var, + color_var = color_var, selected_event = input$select_event, - colors = adjusted_colors, + colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - time_var_label = time_var_label, - event_var_label = input$select_event, - subject_var_label = subject_var_label, - title = paste0(input$select_event, " Over Time"), + title = sprintf("%s over time", input$selected_event), expr = { - plotly_fun <- function(data) { - data %>% - plotly::plot_ly( - source = "spiderplot", - height = height, - color = ~color_var, - colors = colors, - symbols = symbols - ) %>% - plotly::add_segments( - x = ~x, - y = ~y, - xend = ~time_var, - yend = ~value_var - ) %>% - plotly::add_markers( - x = ~time_var, - y = ~value_var, - symbol = ~color_var, - text = ~ tooltip, - hoverinfo = "text" - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = event_var_label), - title = title, - dragmode = "select" - ) %>% - plotly::config(displaylogo = FALSE) - } p <- dataname %>% - filter(event_var == selected_event) %>% - arrange(subject_var, time_var) %>% - group_by(subject_var) %>% - mutate( - x = dplyr::lag(time_var, default = 0), - y = dplyr:::lag(value_var, default = 0), - tooltip = sprintf( - "%s: %s
%s: %s
%s: %s%%", - subject_var_label, subject_var, - time_var_label, time_var, - event_var_label, value_var * 100 - ) + filter(event_var_lang == selected_event) %>% + spiderplotly( + time_var = time_var, + value_var = value_var, + subject_var = subject_var, + event_var = event_var, + color_var = color_var, + colors = colors, + symbols = symbols, + height = height ) %>% - ungroup() %>% - plotly_fun() + plotly::layout(title = title) } ) }) @@ -171,54 +140,66 @@ srv_g_spiderplot <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - plotly_selected_q <- reactive({ - req(plotly_selected()) - primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) - req(primary_keys) - within( - plotly_q(), - expr = { - spiderplot_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% - dplyr::select(primary_keys) - }, - dataname = str2lang(plot_dataname), - xvar = str2lang(time_var), - yvar = str2lang(value_var), - xvals = plotly_selected()$x, - yvals = plotly_selected()$y, - primary_keys = primary_keys - ) - }) - - children_names <- reactive({ - if (length(table_datanames) == 0) { - children(plotly_selected_q(), plot_dataname) - } else { - table_datanames - } - }) - - tables_selected_q <- eventReactive(plotly_selected_q(), { - exprs <- as.expression( - lapply( - children_names(), - function(childname) { - join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] - substitute( - expr = { - childname <- dplyr::right_join(childname, spiderplot_selected, by = by) - }, - list( - childname = str2lang(childname), - by = join_cols - ) - ) - } - ) - ) - eval_code(plotly_selected_q(), exprs) - }) + tables_selected_q <- .plotly_selected_filter_children( + data = plotly_q, + plot_dataname = plot_dataname, + xvar = time_var, + yvar = value_var, + plotly_selected = plotly_selected, + children_datanames = table_datanames + ) srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } + +spiderplotly <- function(data, time_var, value_var, subject_var, event_var, color_var, colors, symbols, height) { + subject_var_label <- attr(data[[subject_var]], "label") + time_var_label <- attr(data[[time_var]], "label") + event_var_label <- attr(data[[event_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + if (!length(time_var_label)) time_var_label <- time_var + if (!length(event_var_label)) event_var_label <- event_var + + data %>% + arrange(!!as.name(subject_var), !!as.name(time_var)) %>% + group_by(!!as.name(subject_var)) %>% + mutate( + x = dplyr::lag(!!as.name(time_var), default = 0), + y = dplyr:::lag(!!as.name(value_var), default = 0), + tooltip = sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var), + time_var_label, !!as.name(time_var), + event_var_label, !!as.name(value_var) * 100 + ) + ) %>% + ungroup() %>% + plotly::plot_ly( + source = "spiderplot", + height = height, + color = as.formula(sprintf("~%s", color_var)), + colors = colors, + symbols = symbols + ) %>% + plotly::add_segments( + x = ~x, + y = ~y, + xend = as.formula(sprintf("~%s", time_var)), + yend = as.formula(sprintf("~%s", value_var)) + ) %>% + plotly::add_markers( + x = as.formula(sprintf("~%s", time_var)), + y = as.formula(sprintf("~%s", value_var)), + symbol = as.formula(sprintf("~%s", color_var)), + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = event_var_label), + title = title, + dragmode = "select" + ) %>% + plotly::config(displaylogo = FALSE) +} diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 70c1aafe4..bc0ef5d11 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -1,14 +1,35 @@ +#' `teal` module: Swimlane plot +#' +#' Module visualizes subjects' events in time. +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. +#' @param time_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as x-axis. +#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to be used as y-axis. +#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to name and color subject events in time. +#' @param group_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to categorize type of event. +#' (legend is sorted according to this variable, and used in toolip to display type of the event) +#' todo: this can be fixed by ordering factor levels +#' @param sort_var (`character(1)` or `select_spec`) name(s) of the column in `plot_dataname` which +#' value determines order of the subjects displayed on the y-axis. +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' by levels of `color_var` column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` +#' column. #' @export tm_g_swimlane <- function(label = "Swimlane", plot_dataname, time_var, subject_var, - value_var, - event_var, + color_var, + group_var, sort_var = NULL, - group_var = NULL, - value_var_color = character(0), - value_var_symbol, + point_colors = character(0), + point_symbols, plot_height = 700, table_datanames = character(0), reactable_args = list()) { @@ -22,12 +43,11 @@ tm_g_swimlane <- function(label = "Swimlane", plot_dataname = plot_dataname, time_var = time_var, subject_var = subject_var, - value_var = value_var, - event_var = event_var, - sort_var = sort_var, + color_var = color_var, group_var = group_var, - value_var_color = value_var_color, - value_var_symbol = value_var_symbol, + sort_var = sort_var, + point_colors = point_colors, + point_symbols = point_symbols, table_datanames = table_datanames, reactable_args = reactable_args ) @@ -38,13 +58,16 @@ ui_g_swimlane <- function(id, height) { ns <- NS(id) - bslib::page_fluid( - bslib::layout_columns( + bslib::page_sidebar( + sidebar = div( selectInput(ns("sort_by"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), + colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) + bslib::page_fillable( + plotly::plotlyOutput(ns("plot"), height = "100%"), + ui_t_reactables(ns("subtables")) + ) ) } srv_g_swimlane <- function(id, @@ -52,12 +75,11 @@ srv_g_swimlane <- function(id, plot_dataname, time_var, subject_var, - value_var, - event_var, + color_var, + group_var, sort_var = time_var, - group_var = NULL, - value_var_color, - value_var_symbol, + point_colors, + point_symbols, table_datanames, reactable_args = list(), filter_panel_api) { @@ -77,101 +99,50 @@ srv_g_swimlane <- function(id, }) } } + if (length(sort_var) == 1) { isolate(sort_choices(sort_var)) isolate(sort_selected(sort_var)) shinyjs::hide("sort_by") } + color_inputs <- colour_picker_srv( + "colors", + x = reactive(data()[[plot_dataname]][[color_var]]), + default_colors = point_colors + ) plotly_q <- reactive({ - req(data(), sort_selected()) - adjusted_colors <- .color_palette_discrete( - levels = unique(data()[[plot_dataname]][[value_var]]), - color = value_var_color - ) + req(data(), sort_selected(), color_inputs()) adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[plot_dataname]][[value_var]]), - symbol = value_var_symbol + levels = unique(data()[[plot_dataname]][[color_var]]), + symbol = point_symbols + ) + within( + data(), + dataname = str2lang(plot_dataname), + time_var = time_var, + subject_var = subject_var, + color_var = color_var, + group_var = group_var, + sort_var = sort_selected(), + colors = color_inputs(), + symbols = adjusted_symbols, + height = input$plot_height, + expr = { + p <- swimlanely( + data = dataname, + time_var = time_var, + subject_var = subject_var, + color_var = color_var, + group_var = group_var, + sort_var = sort_var, + colors = colors, + symbols = symbols, + height = height + ) + } ) - subject_var_label <- c(attr(data()[[plot_dataname]][[subject_var]], "label"), "Subject")[1] - time_var_label <- c(attr(data()[[plot_dataname]][[time_var]], "label"), "Study Day")[1] - data() |> - within( - dataname = str2lang(plot_dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", plot_dataname)), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - event_var = str2lang(event_var), - sort_var = str2lang(sort_selected()), - group_var = if (length(group_var)) group_var, - subject_var_label = sprintf("%s:", subject_var_label), - time_var_label = sprintf("%s:", time_var_label), - colors = adjusted_colors, - symbols = adjusted_symbols, - height = input$plot_height, - subject_axis_label = subject_var_label, - time_axis_label = time_var_label, - expr = { - # todo: forcats::fct_reorder didn't work. - plotly_fun <- function(data) { - data %>% - plotly::plot_ly( - source = "swimlane", - colors = colors, - symbols = symbols, - height = height - ) %>% - plotly::add_markers( - x = ~time_var, - y = ~subject_var_ordered, - color = ~value_var, - symbol = ~value_var, - text = ~tooltip, - legendgroup = ~event_var, - hoverinfo = "text" - ) %>% - plotly::add_segments( - x = ~0, xend = ~study_day, - y = ~subject_var_ordered, yend = ~subject_var_ordered, - data = data |> group_by(subject_var_ordered, event_var) |> summarise(study_day = max(time_var)), - line = list(width = 2, color = "grey"), - showlegend = FALSE - ) %>% - plotly::layout( - xaxis = list(title = time_axis_label), - yaxis = list(title = subject_axis_label) - ) %>% - plotly::layout(dragmode = "select") %>% - plotly::config(displaylogo = FALSE) - } - - levels <- dataname %>% - group_by(subject_var, group_var) %>% - summarize(v = max(sort_var)) %>% - ungroup() %>% - arrange(group_var, v) %>% - pull(subject_var) - - p <- dataname %>% - mutate(subject_var_ordered = factor(subject_var, levels = levels)) %>% - group_by(subject_var, time_var) %>% - mutate( - tooltip = paste( - unique( - c( - paste(subject_var_label, subject_var), - paste(time_var_label, time_var), - sprintf("%s: %s", tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", event_var)), value_var) - ) - ), - collapse = "
" - ) - ) %>% - plotly_fun() - } - ) }) output$plot <- plotly::renderPlotly({ @@ -185,57 +156,84 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) - plotly_selected_q <- reactive({ - req(plotly_selected()) - # todo: change it to foreign keys needed to merge with table_datanames - primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) - req(primary_keys) - within( - plotly_q(), - expr = { - swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% - dplyr::select(primary_keys) - }, - dataname = str2lang(plot_dataname), - xvar = str2lang(time_var), - yvar = str2lang(subject_var), - xvals = plotly_selected()$x, - yvals = plotly_selected()$y, - primary_keys = primary_keys - ) - }) - - children_names <- reactive({ - if (length(table_datanames) == 0) { - children(plotly_selected_q(), plot_dataname) - } else { - table_datanames - } - }) - - tables_selected_q <- eventReactive(plotly_selected_q(), { - exprs <- as.expression( - lapply( - children_names(), - function(childname) { - join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] - substitute( - expr = { - childname <- dplyr::right_join(childname, swimlane_selected, by = by) - }, - list( - childname = str2lang(childname), - by = join_cols - ) - ) - } - ) - ) - eval_code(plotly_selected_q(), exprs) - }) + tables_selected_q <- .plotly_selected_filter_children( + data = plotly_q, + plot_dataname = plot_dataname, + xvar = time_var, + yvar = subject_var, + plotly_selected = plotly_selected, + children_datanames = table_datanames + ) srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } + +swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_var, colors, symbols, height) { + subject_var_label <- attr(data[[subject_var]], "label") + time_var_label <- attr(data[[time_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + if (!length(time_var_label)) time_var_label <- time_var + + # forcats::fct_reorder doesn't seem to work here + subject_levels <- data %>% + group_by(!!as.name(subject_var)) %>% + summarize(v = max(!!as.name(sort_var))) %>% + ungroup() %>% + arrange(v) %>% + pull(!!as.name(subject_var)) + data[[subject_var]] <- factor(data[[subject_var]], levels = subject_levels) + + data %>% + mutate( + !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), + ) %>% + group_by(!!as.name(subject_var), !!as.name(time_var)) %>% + mutate( + tooltip = paste( + unique( + c( + paste(subject_var_label, !!as.name(subject_var)), + paste(time_var_label, !!as.name(time_var)), + sprintf( + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), + !!as.name(color_var) + ) + ) + ), + collapse = "
" + ) + ) %>% + plotly::plot_ly( + source = "swimlane", + colors = colors, + symbols = symbols, + height = height + ) %>% + plotly::add_markers( + x = as.formula(sprintf("~%s", time_var)), + y = as.formula(sprintf("~%s", subject_var)), + color = as.formula(sprintf("~%s", color_var)), + symbol = as.formula(sprintf("~%s", color_var)), + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::add_segments( + x = ~0, xend = ~study_day, + y = as.formula(sprintf("~%s", subject_var)), yend = as.formula(sprintf("~%s", subject_var)), + data = data |> + group_by(!!as.name(subject_var), !!as.name(group_var)) |> + summarise(study_day = max(!!as.name(time_var))), + line = list(width = 2, color = "grey"), + showlegend = FALSE + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = subject_var_label) + ) %>% + plotly::layout(dragmode = "select") %>% + plotly::config(displaylogo = FALSE) +} diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 41ae0e99d..c39530c5f 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,3 +1,19 @@ +#' `teal` module: Waterfall plot +#' +#' Module visualizes subjects sorted decreasingly by y-values. +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. +#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to be used as x-axis. +#' @param value_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as y-axis. +#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' to be used to differentiate bar colors. +#' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' by levels of `color_var` column. +#' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal +#' lines on the plot. #' @export tm_g_waterfall <- function(label = "Waterfall", plot_dataname, @@ -32,13 +48,17 @@ tm_g_waterfall <- function(label = "Waterfall", ui_g_waterfall <- function(id, height) { ns <- NS(id) - bslib::page_fluid( - fluidRow( - column(6, uiOutput(ns("color_by_output"))), - column(6, sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) + + bslib::page_sidebar( + sidebar = div( + uiOutput(ns("color_by_output")), + colour_picker_ui(ns("colors")), + sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) + bslib::page_fillable( + plotly::plotlyOutput(ns("plot"), height = "100%"), + ui_t_reactables(ns("subtables")) + ) ) } srv_g_waterfall <- function(id, @@ -63,168 +83,116 @@ srv_g_waterfall <- function(id, } else { shinyjs::hide("color_by") } + + color_inputs <- colour_picker_srv( + "colors", + x = reactive({ + req(data(), input$color_by) + data()[[plot_dataname]][[input$color_by]] + }), + default_colors = bar_colors + ) + plotly_q <- reactive({ - req(data(), input$color_by) + req(data(), input$color_by, color_inputs()) - adjusted_colors <- .color_palette_discrete( - levels = unique(data()[[plot_dataname]][[input$color_by]]), - color = bar_colors[[input$color_by]] - ) - - subject_var_label <- c( - attr(data()[[plot_dataname]][[subject_var]], "label"), - subject_var - )[1] + within( + data(), + dataname = str2lang(plot_dataname), + subject_var = subject_var, + value_var = value_var, + color_var = input$color_by, + colors = color_inputs(), + value_arbitrary_hlines = value_arbitrary_hlines, + height = input$plot_height, + title = sprintf("Waterfall plot"), + expr = { + p <- waterfally( + dataname, + subject_var = subject_var, + value_var = value_var, + color_var = color_var, + colors = colors, + value_arbitrary_hlines = value_arbitrary_hlines, + height = height + ) %>% + plotly::layout(title = title) - value_var_label <- c( - attr(data()[[plot_dataname]][[value_var]], "label"), - value_var - )[1] - - color_var_label <- c( - attr(data()[[plot_dataname]][[input$color_by]], "label"), - input$color_by - )[1] - - - data() |> - within( - dataname = str2lang(plot_dataname), - dataname_filtered = str2lang(sprintf("%s_filtered", plot_dataname)), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - color_var = str2lang(input$color_by), - colors = adjusted_colors, - value_arbitrary_hlines = value_arbitrary_hlines, - subject_var_label = subject_var_label, - value_var_label = value_var_label, - color_var_label = color_var_label, - title = paste0(value_var_label, " (Waterfall plot)"), - height = input$plot_height, - expr = { - p <- dataname %>% - dplyr::mutate( - subject_var_ordered = forcats::fct_reorder(as.factor(subject_var), value_var, .fun = max, .desc = TRUE), - tooltip = sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, subject_var, - value_var_label, value_var, - color_var_label, color_var - ) - ) %>% - - dplyr::filter(!duplicated(subject_var)) %>% - # todo: one value for x, y: distinct or summarize(value = foo(value_var)) [foo: summarize_fun] - plotly::plot_ly( - source = "waterfall", - height = height - ) %>% - plotly::add_bars( - x = ~subject_var_ordered, - y = ~value_var, - color = ~color_var, - colors = colors, - text = ~ tooltip, - hoverinfo = "text" - ) %>% - plotly::layout( - shapes = lapply(value_arbitrary_hlines, function(y) { - list( - type = "line", - x0 = 0, - x1 = 1, - xref = "paper", - y0 = y, - y1 = y, - line = list(color = "black", dash = "dot") - ) - }), - title = title, - xaxis = list(title = subject_var_label, tickangle = -45), - yaxis = list(title = value_var_label), - legend = list(title = list(text = "Color by:")), - barmode = "relative" - ) %>% - plotly::layout( dragmode = "select") %>% - plotly::config(displaylogo = FALSE) - }, - height = input$plot_height - ) + }, + height = input$plot_height + ) }) output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) - plotly_selected_q <- reactive({ - req(plotly_selected()) - primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) - req(primary_keys) - within( - plotly_q(), - expr = { - waterfall_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% - dplyr::select(primary_keys) - }, - dataname = str2lang(plot_dataname), - xvar = str2lang(subject_var), - yvar = str2lang(value_var), - xvals = plotly_selected()$x, - yvals = plotly_selected()$y, - primary_keys = primary_keys - ) - }) - - children_names <- reactive({ - if (length(table_datanames) == 0) { - children(plotly_selected_q(), plot_dataname) - } else { - table_datanames - } - }) - - tables_selected_q <- eventReactive(plotly_selected_q(), { - exprs <- as.expression( - lapply( - children_names(), - function(childname) { - join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] - substitute( - expr = { - childname <- dplyr::right_join(childname, waterfall_selected, by = by) - }, - list( - childname = str2lang(childname), - by = join_cols - ) - ) - } - ) - ) - eval_code(plotly_selected_q(), exprs) - }) + tables_selected_q <- .plotly_selected_filter_children( + data = plotly_q, + plot_dataname = plot_dataname, + xvar = subject_var, + yvar = value_var, + plotly_selected = plotly_selected, + children_datanames = table_datanames + ) srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) }) } -# todo: to teal_data -children <- function(x, dataset_name = character(0)) { - checkmate::assert_multi_class(x, c("teal_data", "join_keys")) - checkmate::assert_character(dataset_name, max.len = 1) - if (length(dataset_name)) { - names( - Filter( - function(parent) parent == dataset_name, - parents(x) +waterfally <- function(data, subject_var, value_var, color_var, colors, value_arbitrary_hlines, height) { + subject_var_label <- attr(data[[subject_var]], "label") + value_var_label <- attr(data[[value_var]], "label") + color_var_label <- attr(data[[color_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + if (!length(value_var_label)) value_var_label <- value_var + if (!length(color_var_label)) color_var_label <- color_var + + data %>% + dplyr::mutate( + !!as.name(subject_var) := forcats::fct_reorder( + as.factor(!!as.name(subject_var)), + !!as.name(value_var), + .fun = max, + .desc = TRUE + ), + tooltip = sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), + value_var_label, !!as.name(value_var), + color_var_label, !!as.name(color_var) ) - ) - } else { - all_parents <- unique(unlist(parents(x))) - names(all_parents) <- all_parents - lapply( - all_parents, - function(parent) children(x = x, dataset_name = parent) - ) - } + ) %>% + dplyr::filter(!duplicated(!!as.name(subject_var))) %>% + plotly::plot_ly( + source = "waterfall", + height = height + ) %>% + plotly::add_bars( + x = as.formula(sprintf("~%s", subject_var)), + y = as.formula(sprintf("~%s", value_var)), + color = as.formula(sprintf("~%s", color_var)), + colors = colors, + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::layout( + shapes = lapply(value_arbitrary_hlines, function(y) { + list( + type = "line", + x0 = 0, + x1 = 1, + xref = "paper", + y0 = y, + y1 = y, + line = list(color = "black", dash = "dot") + ) + }), + xaxis = list(title = subject_var_label, tickangle = -45), + yaxis = list(title = value_var_label), + legend = list(title = list(text = "Color by:")), + barmode = "relative" + ) %>% + plotly::layout( dragmode = "select") %>% + plotly::config(displaylogo = FALSE) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 08ee2eb4d..2f899a247 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,3 +1,10 @@ +#' `teal` module: Reactable +#' +#' Wrapper module on [reactable::reactable()] +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @param reactable_args (`list`) any argument of [reactable::reactable()]. #' @export tm_t_reactables <- function(label = "Table", datanames = "all", @@ -23,7 +30,7 @@ tm_t_reactables <- function(label = "Table", ui_t_reactables <- function(id, decorators = list()) { ns <- NS(id) - uiOutput(ns("subtables"), container = bslib::page_fluid) + uiOutput(ns("subtables"), container = div) } srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), reactable_args = list()) { @@ -127,6 +134,8 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco req(data()) teal.data::col_labels(data()[[dataname]], fill = TRUE) }) + + reactable_args_r <- if (is.reactive(reactable_args)) reactable_args else reactive(reactable_args) cols_choices <- reactiveVal() cols_selected <- reactiveVal() @@ -170,7 +179,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco reactable_call <- .make_reactable_call( dataset = data()[[dataname]][cols_selected()], dataname = dataname, - args = reactable_args + args = reactable_args_r() ) data() |> @@ -200,6 +209,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco table_q() } }) + table_selected_q }) } diff --git a/R/utils.R b/R/utils.R index ad198658f..92a62bdb6 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,51 +1,3 @@ -#' Shared parameters documentation -#' -#' Defines common arguments shared across multiple functions in the package -#' to avoid repetition by using `inheritParams`. -#' -#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of -#' `value`, `min`, and `max` intended for use with a slider UI element. -#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of -#' `value`, `min`, and `max` for a slider encoding the plot width. -#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not -#' rotate by default (`FALSE`). -#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. -#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] -#' with settings for the module plot. -#' The argument is merged with options variable `teal.ggplot2_args` and default module setup. -#' -#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")` -#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] -#' with settings for the module table. -#' The argument is merged with options variable `teal.basic_table_args` and default module setup. -#' -#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")` -#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, -#' providing context or a title. -#' with text placed before the output to put the output into context. For example a title. -#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, -#' adding context or further instructions. Elements like `shiny::helpText()` are useful. -#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. -#' - When the length of `alpha` is one: the plot points will have a fixed opacity. -#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on -#' vector of `value`, `min`, and `max`. -#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. -#' - When the length of `size` is one: the plot point sizes will have a fixed size. -#' - When the length of `size` is three: the plot points size are dynamically adjusted based on -#' vector of `value`, `min`, and `max`. -#' @param decorators `r lifecycle::badge("experimental")` -#' (named `list` of lists of `teal_transform_module`) optional, -#' decorator for tables or plots included in the module output reported. -#' The decorators are applied to the respective output objects. -#' -#' See section "Decorating Module" below for more details. -#' -#' @return Object of class `teal_module` to be used in `teal` applications. -#' -#' @name shared_params -#' @keywords internal -NULL - #' Add labels for facets to a `ggplot2` object #' #' Enhances a `ggplot2` plot by adding labels that describe @@ -398,42 +350,96 @@ select_decorators <- function(decorators, scope) { } } - -#' Color palette discrete -#' -#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by -#' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels -#' as the rest will be filled automatically. -#' @param levels (`character`) values of possible variable levels -#' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`. -#' @return `character` with hex colors named by `levels`. -.color_palette_discrete <- function(levels, color) { - p <- color[names(color) %in% levels] - p_rgb_num <- col2rgb(p) - p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) - p <- setNames(p_hex, names(p)) - missing_levels <- setdiff(levels, names(p)) - N <- length(levels) - n <- length(p) - m <- N - n - if (m > 0 && n > 0) { - current_space <- rgb2hsv(col2rgb(p)) - optimal_color_space <- colorspace::qualitative_hcl(N) - color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) - optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] - furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) - missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] - p <- c(p, setNames(missing_colors, missing_levels)) - } else if (length(missing_levels)) { - colorspace::qualitative_hcl(N) +# todo: to teal_data +children <- function(x, dataset_name = character(0)) { + checkmate::assert_multi_class(x, c("teal_data", "join_keys")) + checkmate::assert_character(dataset_name, max.len = 1) + if (length(dataset_name)) { + names( + Filter( + function(parent) parent == dataset_name, + parents(x) + ) + ) } else { - p + all_parents <- unique(unlist(parents(x))) + names(all_parents) <- all_parents + lapply( + all_parents, + function(parent) children(x = x, dataset_name = parent) + ) } - p[levels] } -.shape_palette_discrete <- function(levels, symbol) { - s <- setNames(symbol[levels], levels) - s[is.na(s)] <- "circle-open" - s +.name_to_id <- function(name) { + gsub("[[:space:][:punct:]]+", "_", x = tolower(name)) +} + +#' Filter children on `plotly_selected` +#' +#' @description +#' Filters children datanames according to: +#' - selected x and y values on the plot (based on the parent dataset) +#' - [`teal.data::join_keys`] relationship between `children_datanames` +#' +#' @param data (`reactive teal_data`) +#' @param plot_dataname (`character(1)`) +#' @param xvar (`character(1)`) +#' @param yvar (`character(1)`) +#' @param plotly_selected (`reactive`) +#' @param children_datanames (`character`) +.plotly_selected_filter_children <- function(data, plot_dataname, xvar, yvar, plotly_selected, children_datanames) { + plotly_selected_q <- reactive({ + req(plotly_selected()) + # todo: change it to foreign keys needed to merge with children_datanames + primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) + if (length(primary_keys) == 0) { + primary_keys <- unique(sapply(children_datanames, USE.NAMES = FALSE, FUN = function(childname) { + names(join_keys(data())[plot_dataname, childname]) + })) + } + req(primary_keys) + within( + data(), + expr = { + swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% + dplyr::select(primary_keys) + }, + dataname = str2lang(plot_dataname), + xvar = str2lang(xvar), + yvar = str2lang(yvar), + xvals = plotly_selected()$x, + yvals = plotly_selected()$y, + primary_keys = primary_keys + ) + }) + + children_names <- reactive({ + if (length(children_datanames) == 0) { + children(plotly_selected_q(), plot_dataname) + } else { + children_datanames + } + }) + + eventReactive(plotly_selected_q(), { + exprs <- as.expression( + lapply( + children_names(), + function(childname) { + join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] + substitute( + expr = { + childname <- dplyr::right_join(childname, swimlane_selected, by = by) + }, + list( + childname = str2lang(childname), + by = join_cols + ) + ) + } + ) + ) + q <- eval_code(plotly_selected_q(), exprs) + }) } diff --git a/man/dot-color_palette_discrete.Rd b/man/dot-color_palette_discrete.Rd index ce42d0d3a..c1b3ef4b1 100644 --- a/man/dot-color_palette_discrete.Rd +++ b/man/dot-color_palette_discrete.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/module_colur_picker.R \name{.color_palette_discrete} \alias{.color_palette_discrete} \title{Color palette discrete} diff --git a/man/dot-plotly_selected_filter_children.Rd b/man/dot-plotly_selected_filter_children.Rd new file mode 100644 index 000000000..b6531a345 --- /dev/null +++ b/man/dot-plotly_selected_filter_children.Rd @@ -0,0 +1,35 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/utils.R +\name{.plotly_selected_filter_children} +\alias{.plotly_selected_filter_children} +\title{Filter children on \code{plotly_selected}} +\usage{ +.plotly_selected_filter_children( + data, + plot_dataname, + xvar, + yvar, + plotly_selected, + children_datanames +) +} +\arguments{ +\item{data}{(\verb{reactive teal_data})} + +\item{plot_dataname}{(\code{character(1)})} + +\item{xvar}{(\code{character(1)})} + +\item{yvar}{(\code{character(1)})} + +\item{plotly_selected}{(\code{reactive})} + +\item{children_datanames}{(\code{character})} +} +\description{ +Filters children datanames according to: +\itemize{ +\item selected x and y values on the plot (based on the parent dataset) +\item \code{\link[teal.data:join_keys]{teal.data::join_keys}} relationship between \code{children_datanames} +} +} diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 5e27ea0dc..979a02926 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R +% Please edit documentation in R/roxygen2_templates.R \name{shared_params} \alias{shared_params} \title{Shared parameters documentation} @@ -51,8 +51,12 @@ vector of \code{value}, \code{min}, and \code{max}. \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. +The decorators are applied to the respective output objects.} +\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot +when some data points are selected. Objects named after \code{table_datanames} will be pulled from +\code{data} so it is important that data actually contains these datasets. Please be aware that +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. See section "Decorating Module" below for more details.} } \value{ diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 2fdfdf650..5d8440667 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -79,9 +79,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 37a215e71..d401eb46a 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -103,9 +103,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 9e651dc70..c82e8f8b2 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -64,9 +64,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 09fd2e2d2..bd1f76af0 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -109,9 +109,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index a064a26fe..dd61e723d 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -71,9 +71,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 2a617112a..44ce0a985 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -89,9 +89,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 556c87b34..383eeae00 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -102,9 +102,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index f90d7cf52..f4b8bfe8c 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -43,9 +43,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd new file mode 100644 index 000000000..d0d23bb34 --- /dev/null +++ b/man/tm_g_spiderplot.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_g_spiderplot.R +\name{tm_g_spiderplot} +\alias{tm_g_spiderplot} +\title{\code{teal} module: Spider Plot} +\usage{ +tm_g_spiderplot( + label = "Spiderplot", + plot_dataname, + time_var, + value_var, + subject_var, + event_var, + color_var, + point_colors, + point_symbols, + plot_height = 600, + table_datanames = character(0), + reactable_args = list(), + transformator = transformator +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} + +\item{time_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} + +\item{value_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis. +column.} + +\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used as grouping variable for displayed lines/points.} + +\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used to differentiate colors and symbols.} + +\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} +column.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot +when some data points are selected. Objects named after \code{table_datanames} will be pulled from +\code{data} so it is important that data actually contains these datasets. Please be aware that +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. +See section "Decorating Module" below for more details.} +} +\description{ +Module visualizes value development in time grouped by subjects. +} diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd new file mode 100644 index 000000000..19c82a9be --- /dev/null +++ b/man/tm_g_swimlane.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_g_swimlane.R +\name{tm_g_swimlane} +\alias{tm_g_swimlane} +\title{\code{teal} module: Swimlane plot} +\usage{ +tm_g_swimlane( + label = "Swimlane", + plot_dataname, + time_var, + subject_var, + color_var, + group_var, + sort_var = NULL, + point_colors = character(0), + point_symbols, + plot_height = 700, + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} + +\item{time_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} + +\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used as y-axis.} + +\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to name and color subject events in time.} + +\item{group_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to categorize type of event. +(legend is sorted according to this variable, and used in toolip to display type of the event) +todo: this can be fixed by ordering factor levels} + +\item{sort_var}{(\code{character(1)} or \code{select_spec}) name(s) of the column in \code{plot_dataname} which +value determines order of the subjects displayed on the y-axis.} + +\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} +column.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot +when some data points are selected. Objects named after \code{table_datanames} will be pulled from +\code{data} so it is important that data actually contains these datasets. Please be aware that +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. +See section "Decorating Module" below for more details.} +} +\description{ +Module visualizes subjects' events in time. +} diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd new file mode 100644 index 000000000..660825bf3 --- /dev/null +++ b/man/tm_g_waterfall.Rd @@ -0,0 +1,52 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_g_waterfall.R +\name{tm_g_waterfall} +\alias{tm_g_waterfall} +\title{\code{teal} module: Waterfall plot} +\usage{ +tm_g_waterfall( + label = "Waterfall", + plot_dataname, + subject_var, + value_var, + color_var = NULL, + bar_colors = list(), + value_arbitrary_hlines = c(0.2, -0.3), + plot_title = "Waterfall plot", + plot_height = 700, + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} + +\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used as x-axis.} + +\item{value_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis.} + +\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used to differentiate bar colors.} + +\item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal +lines on the plot.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot +when some data points are selected. Objects named after \code{table_datanames} will be pulled from +\code{data} so it is important that data actually contains these datasets. Please be aware that +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. +See section "Decorating Module" below for more details.} +} +\description{ +Module visualizes subjects sorted decreasingly by y-values. +} diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index 6d2f03824..80634f956 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -64,9 +64,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index f8c15278d..888a972bc 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -55,9 +55,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index c761018da..8a47037f8 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -58,9 +58,7 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects. - -See section "Decorating Module" below for more details.} +The decorators are applied to the respective output objects.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd new file mode 100644 index 000000000..6257d9d2f --- /dev/null +++ b/man/tm_t_reactables.Rd @@ -0,0 +1,41 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_t_reactable.R +\name{tm_t_reactables} +\alias{tm_t_reactables} +\title{\code{teal} module: Reactable} +\usage{ +tm_t_reactables( + label = "Table", + datanames = "all", + colnames = list(), + transformators = list(), + decorators = list(), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + +\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +(named \code{list} of lists of \code{teal_transform_module}) optional, +decorator for tables or plots included in the module output reported. +The decorators are applied to the respective output objects.} + +\item{reactable_args}{(\code{list}) any argument of \code{\link[reactable:reactable]{reactable::reactable()}}.} +} +\description{ +Wrapper module on \code{\link[reactable:reactable]{reactable::reactable()}} +} From ae795f8959fda0ea1f9a9e2699293d87ca9f9610 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 25 Mar 2025 11:43:27 +0000 Subject: [PATCH 071/158] minor fix --- R/tm_a_spiderplot_mdr.R | 250 ---------------------------------------- 1 file changed, 250 deletions(-) delete mode 100644 R/tm_a_spiderplot_mdr.R diff --git a/R/tm_a_spiderplot_mdr.R b/R/tm_a_spiderplot_mdr.R deleted file mode 100644 index 6be6b7904..000000000 --- a/R/tm_a_spiderplot_mdr.R +++ /dev/null @@ -1,250 +0,0 @@ -#' @export -tm_a_spiderplot_mdr <- function(label = "Spiderplot", - dataname, - time_var, - subject_var, - value_var, - event_var, - resp_cols = c( - "subject", "raise_query", "visit_name", "rspdn", "rspd", "rspd_study_day", - "orsp", "bma", "bmb", "comnts" - ), - spep_cols = c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lrspep1", "mprte_raw", "mprtec" - ), - sflc_cols = c( - "subject", "visit_name", "visit_date", "form_name", "source_system_url_link", "rspdn", "rspd", - "rspd_study_day", "orsp", "bma", "bmb", "comnts", "asmntdn", "blq", "coldr", "cold_study_day", - "coltm", "coltmu", "lchfrc", "lchfr_raw", "klchf_raw", "llchf_raw", - "klchp_raw", "mprte_raw", "mprtec" - ), - plot_height = 600) { - module( - label = label, - ui = ui_a_spiderplot_mdr, - server = srv_a_spiderplot_mdr, - ui_args = list(height = plot_height), - server_args = list( - dataname = dataname, - time_var = time_var, - subject_var = subject_var, - value_var = value_var, - event_var = event_var, - resp_cols = resp_cols, - spep_cols = spep_cols, - sflc_cols = sflc_cols - ), - datanames = dataname, - ) -} - - -ui_a_spiderplot_mdr <- function(id, height) { - ns <- NS(id) - tagList( - - tagList( - div( - style = "display: flex", - div( - class = "simple-card", - style = "width: 50%", - tagList( - h4("Most Recent Resp and Best Resp"), - ui_t_reactable(ns("recent_resp")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - ui_g_spiderplot(ns("spiderplot"), height = height) - ) - ) - ), - div( - style = "display: flex", - div( - style = "width: 50%", - div( - class = "simple-card", - h4("Disease Assessment - SFLC"), - ui_t_reactable(ns("sflc_listing")) - ), - div( - class = "simple-card", - h4("Disease Assessment - SPEP"), - ui_t_reactable(ns("spep_listing")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - h4("Multiple Myeloma Response"), - ui_t_reactable(ns("all_resp")) - ) - ) - ) -} - -srv_a_spiderplot_mdr <- function(id, - data, - dataname, - time_var, - subject_var, - value_var, - event_var, - resp_cols, - spep_cols, - sflc_cols, - filter_panel_api, - plot_height = 600) { - moduleServer(id, function(input, output, session) { - # todo: plotly_excl_events should be a positive selection or tidyselect - # and exposed as arg - plotly_excl_events <- c("response_assessment", "latest_response_assessment") - plotly_data <- reactive({ - req(data()) - within( - data(), - dataname = str2lang(dataname), - event_var = str2lang(event_var), - plotly_excl_events = plotly_excl_events, - expr = spiderplot_data <- dplyr::filter(dataname, !event_var %in% plotly_excl_events) - ) - }) - plotly_selected_q <- srv_g_spiderplot( - "spiderplot", - data = plotly_data, - dataname = "spiderplot_data", - time_var = time_var, - subject_var = subject_var, - value_var = value_var, - event_var = event_var, - filter_panel_api = filter_panel_api, - plot_height = plot_height - ) - - recent_resp_q <- reactive({ - req(plotly_selected_q()) - within( - plotly_selected_q(), - dataname = str2lang(dataname), - time_var = str2lang(time_var), - subject_var = str2lang(subject_var), - value_var = str2lang(value_var), - subject_var_char = subject_var, - event_var = str2lang(event_var), - recent_resp_event = "latest_response_assessment", # todo: whattodo? - resp_cols = resp_cols, - expr = { - brushed_subjects <- dplyr::filter( - dataname, - time_var %in% plotly_brushed_time, - value_var %in% plotly_brushed_value - )[[subject_var_char]] - recent_resp <- dplyr::filter( - dataname, - event_var %in% recent_resp_event, - subject_var %in% brushed_subjects - ) |> - select(all_of(resp_cols)) - } - ) - }) - - recent_resp_selected_q <- srv_t_reactable( - "recent_resp", data = recent_resp_q, dataname = "recent_resp", selection = "single" - ) - - # todo: these tables do have the same filters and select. It is just a matter of parametrising - # to named list: - # - (table) label - # - event_level for filter - # - columns - all_resp_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - event_var = str2lang(event_var), - all_resp_events = "response_assessment", - resp_cols = resp_cols, - expr = { - all_resp <- dplyr::filter( - dataname, - event_var %in% all_resp_events, - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(resp_cols)) - } - ) - }) - - spep_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - event_var = str2lang(event_var), - spep_events = "Serum M-protein", - spep_cols = spep_cols, - expr = { - spep <- dplyr::filter( - dataname, - event_var %in% spep_events, - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(spep_cols)) - } - ) - }) - - sflc_q <- reactive({ - req(nrow(recent_resp_selected_q()[["recent_resp_selected"]])) - within( - recent_resp_selected_q(), - dataname = str2lang(dataname), - subject_var = str2lang(subject_var), - subject_var_char = subject_var, - event_var = str2lang(event_var), - sflc_events = c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" - ), - sflc_cols = sflc_cols, - expr = { - sflc <- dplyr::filter( - dataname, - event_var %in% sflc_events, - subject_var %in% unique(recent_resp_selected[[subject_var_char]]) - ) |> - select(all_of(sflc_cols)) - } - ) - }) - - #todo: show all_resp only if recent_resp is selected - all_resp_selected_q <- srv_t_reactable("all_resp", data = all_resp_q, dataname = "all_resp", selection = NULL) - spep_selected_d <- srv_t_reactable("spep_listing", data = spep_q, dataname = "spep", selection = NULL) - sflc_selected_d <- srv_t_reactable("sflc_listing", data = sflc_q, dataname = "sflc", selection = NULL) - - all_q <- reactive({ - req(recent_resp_selected_q(), all_resp_selected_q()) - # all_resp_selected_q could be nothing and `c` won't work because the result is unavailable before clicking subjects in the table - c(recent_resp_selected_q(), all_resp_selected_q()) - }) - - observeEvent(all_q(), { - cat(teal.code::get_code(all_q())) - }) - - - }) -} From c6e44f5538f12d829e79b0d98157938824961694 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 25 Mar 2025 11:45:07 +0000 Subject: [PATCH 072/158] major cleaning --- NAMESPACE | 1 - 1 file changed, 1 deletion(-) diff --git a/NAMESPACE b/NAMESPACE index 8edbf3232..80948c4be 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -12,7 +12,6 @@ export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) export(tm_a_regression) -export(tm_a_spiderplot_mdr) export(tm_data_table) export(tm_file_viewer) export(tm_front_page) From 08465f652bb62c47391ad310b328b1c18d65b8fd Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 25 Mar 2025 11:56:16 +0000 Subject: [PATCH 073/158] add graphs to the namespace --- NAMESPACE | 3 +++ R/tm_g_spiderplot.R | 2 ++ R/tm_g_swimlane.R | 2 ++ R/tm_g_waterfall.R | 3 +++ 4 files changed, 10 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 80948c4be..d37836710 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,6 +10,8 @@ S3method(create_sparklines,logical) S3method(create_sparklines,numeric) export(add_facet_labels) export(get_scatterplotmatrix_stats) +export(spiderplotly) +export(swimlanely) export(tm_a_pca) export(tm_a_regression) export(tm_data_table) @@ -29,6 +31,7 @@ export(tm_outliers) export(tm_t_crosstable) export(tm_t_reactables) export(tm_variable_browser) +export(waterfally) import(ggmosaic) import(ggplot2) import(shiny) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 4b4129e50..f86a23fdb 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -153,6 +153,8 @@ srv_g_spiderplot <- function(id, }) } +# todo: export is temporary, this should go to a new package teal.graphs or another bird species +#' @export spiderplotly <- function(data, time_var, value_var, subject_var, event_var, color_var, colors, symbols, height) { subject_var_label <- attr(data[[subject_var]], "label") time_var_label <- attr(data[[time_var]], "label") diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index bc0ef5d11..64518f772 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -171,6 +171,8 @@ srv_g_swimlane <- function(id, } +# todo: export is temporary, this should go to a new package teal.graphs or another bird species +#' @export swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_var, colors, symbols, height) { subject_var_label <- attr(data[[subject_var]], "label") time_var_label <- attr(data[[time_var]], "label") diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index c39530c5f..b5af546a8 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -140,6 +140,9 @@ srv_g_waterfall <- function(id, }) } + +# todo: export is temporary, this should go to a new package teal.graphs or another bird species +#' @export waterfally <- function(data, subject_var, value_var, color_var, colors, value_arbitrary_hlines, height) { subject_var_label <- attr(data[[subject_var]], "label") value_var_label <- attr(data[[value_var]], "label") From b6ed6539af026c809d9377ae8b0eb0dbc0ecca8a Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 28 Mar 2025 11:16:02 +0000 Subject: [PATCH 074/158] tm_rmarkdown --- DESCRIPTION | 9 ++++- NAMESPACE | 2 + R/module_colur_picker.R | 14 +++---- R/plotly_with_settings.R | 10 +++++ R/tm_data_table.R | 2 +- R/tm_g_spiderplot.R | 22 +++++------ R/tm_g_swimlane.R | 51 +++++++++++++------------ R/tm_g_waterfall.R | 8 ++-- R/tm_markdown.R | 80 ++++++++++++++++++++++++++++++++++++++++ R/tm_t_reactable.R | 6 +-- R/tm_variable_browser.R | 2 +- R/utils.R | 12 +++--- R/zzz.R | 1 + man/tm_rmarkdown.Rd | 58 +++++++++++++++++++++++++++++ 14 files changed, 219 insertions(+), 58 deletions(-) create mode 100644 R/plotly_with_settings.R create mode 100644 R/tm_markdown.R create mode 100644 man/tm_rmarkdown.Rd diff --git a/DESCRIPTION b/DESCRIPTION index cfd5caacf..a69bec3fa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -32,6 +32,7 @@ Depends: Imports: bslib (>= 0.8.0), checkmate (>= 2.1.0), + colorspace, colourpicker (>= 1.3.0), dplyr (>= 1.0.5), DT (>= 0.13), @@ -42,6 +43,8 @@ Imports: ggpp (>= 0.5.8-1), ggrepel (>= 0.9.6), goftest (>= 1.2-3), + graphics, + grDevices, grid, gridExtra (>= 2.3), htmlwidgets (>= 1.6.4), @@ -49,6 +52,10 @@ Imports: lattice (>= 0.18-4), lifecycle (>= 0.2.0), MASS (>= 7.3-60), + plotly, + reactable, + rlang (>= 1.0.0), + rmarkdown (>= 2.23), rtables (>= 0.6.11), scales (>= 1.3.0), shinyjs (>= 2.1.0), @@ -73,8 +80,6 @@ Suggests: logger (>= 0.2.0), nestcolor (>= 0.1.0), pkgload, - rlang (>= 1.0.0), - rmarkdown (>= 2.23), roxy.shinylive, rvest, shinytest2, diff --git a/NAMESPACE b/NAMESPACE index d37836710..d85616edb 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,6 +28,7 @@ export(tm_g_swimlane) export(tm_g_waterfall) export(tm_missing_data) export(tm_outliers) +export(tm_rmarkdown) export(tm_t_crosstable) export(tm_t_reactables) export(tm_variable_browser) @@ -39,3 +40,4 @@ import(teal) import(teal.transform) importFrom(dplyr,"%>%") importFrom(lifecycle,deprecated) +importFrom(rlang,":=") diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 2d363e371..7d5fd7602 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -69,21 +69,21 @@ colour_picker_srv <- function(id, x, default_colors) { #' @return `character` with hex colors named by `levels`. .color_palette_discrete <- function(levels, color) { p <- color[names(color) %in% levels] - p_rgb_num <- col2rgb(p) - p_hex <- rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) - p <- setNames(p_hex, names(p)) + p_rgb_num <- grDevices::col2rgb(p) + p_hex <- grDevices::rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) + p <- stats::setNames(p_hex, names(p)) missing_levels <- setdiff(levels, names(p)) N <- length(levels) n <- length(p) m <- N - n if (m > 0 && n > 0) { - current_space <- rgb2hsv(col2rgb(p)) + current_space <- grDevices::rgb2hsv(grDevices::col2rgb(p)) optimal_color_space <- colorspace::qualitative_hcl(N) - color_distances <- dist(t(cbind(current_space, rgb2hsv(col2rgb(optimal_color_space))))) + color_distances <- stats::dist(t(cbind(current_space, grDevices::rgb2hsv(grDevices::col2rgb(optimal_color_space))))) optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] - p <- c(p, setNames(missing_colors, missing_levels)) + p <- c(p, stats::setNames(missing_colors, missing_levels)) } else if (length(missing_levels)) { colorspace::qualitative_hcl(N) } else { @@ -93,7 +93,7 @@ colour_picker_srv <- function(id, x, default_colors) { } .shape_palette_discrete <- function(levels, symbol) { - s <- setNames(symbol[levels], levels) + s <- stats::setNames(symbol[levels], levels) s[is.na(s)] <- "circle-open" s } diff --git a/R/plotly_with_settings.R b/R/plotly_with_settings.R new file mode 100644 index 000000000..7c00559a2 --- /dev/null +++ b/R/plotly_with_settings.R @@ -0,0 +1,10 @@ +plotly_with_settings_ui <- function(id, height) { + ns <- NS(id) + plotly::plotlyOutput(ns("plot"), height = height) +} + +plotly_with_settings_srv <- function(id, plot) { + moduleServer(id, function(input, output, session) { + output$plot <- plotly::renderPlotly(plot()) + }) +} \ No newline at end of file diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 724254aa8..7670a9337 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -377,7 +377,7 @@ srv_dataset_table <- function(id, id = "brush_filter" )) shinyjs::hide("apply_brush_filter") - set_filter_state(filter_panel_api, slice) + teal.slice::set_filter_state(filter_panel_api, slice) }) }) } diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index f86a23fdb..ecc79c07a 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -149,7 +149,7 @@ srv_g_spiderplot <- function(id, children_datanames = table_datanames ) - srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) + srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) }) } @@ -164,9 +164,9 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo if (!length(event_var_label)) event_var_label <- event_var data %>% - arrange(!!as.name(subject_var), !!as.name(time_var)) %>% - group_by(!!as.name(subject_var)) %>% - mutate( + dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% + dplyr::group_by(!!as.name(subject_var)) %>% + dplyr::mutate( x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), tooltip = sprintf( @@ -176,24 +176,24 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo event_var_label, !!as.name(value_var) * 100 ) ) %>% - ungroup() %>% + dplyr::ungroup() %>% plotly::plot_ly( source = "spiderplot", height = height, - color = as.formula(sprintf("~%s", color_var)), + color = stats::as.formula(sprintf("~%s", color_var)), colors = colors, symbols = symbols ) %>% plotly::add_segments( x = ~x, y = ~y, - xend = as.formula(sprintf("~%s", time_var)), - yend = as.formula(sprintf("~%s", value_var)) + xend = stats::as.formula(sprintf("~%s", time_var)), + yend = stats::as.formula(sprintf("~%s", value_var)) ) %>% plotly::add_markers( - x = as.formula(sprintf("~%s", time_var)), - y = as.formula(sprintf("~%s", value_var)), - symbol = as.formula(sprintf("~%s", color_var)), + x = stats::as.formula(sprintf("~%s", time_var)), + y = stats::as.formula(sprintf("~%s", value_var)), + symbol = stats::as.formula(sprintf("~%s", color_var)), text = ~tooltip, hoverinfo = "text" ) %>% diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 64518f772..063dfe467 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -65,7 +65,7 @@ ui_g_swimlane <- function(id, height) { sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), bslib::page_fillable( - plotly::plotlyOutput(ns("plot"), height = "100%"), + plotly_with_settings_ui(ns("plot"), height = "100"), ui_t_reactables(ns("subtables")) ) ) @@ -145,11 +145,14 @@ srv_g_swimlane <- function(id, ) }) - output$plot <- plotly::renderPlotly({ - plotly_q()$p |> - plotly::event_register("plotly_selected") |> - plotly::event_register("plotly_deselect") # todo: deselect doesn't work - }) + output$plot <- plotly_with_settings_srv( + "plot", + plot = reactive({ + plotly_q()$p |> + plotly::event_register("plotly_selected") |> + plotly::event_register("plotly_deselect") # todo: deselect doesn't work + }) + ) plotly_selected <- reactive({ plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work @@ -165,7 +168,7 @@ srv_g_swimlane <- function(id, children_datanames = table_datanames ) - srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) + srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) }) } @@ -181,19 +184,19 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v # forcats::fct_reorder doesn't seem to work here subject_levels <- data %>% - group_by(!!as.name(subject_var)) %>% - summarize(v = max(!!as.name(sort_var))) %>% - ungroup() %>% - arrange(v) %>% - pull(!!as.name(subject_var)) + dplyr::group_by(!!as.name(subject_var)) %>% + dplyr::summarize(v = max(!!as.name(sort_var))) %>% + dplyr::ungroup() %>% + dplyr::arrange(v) %>% + dplyr::pull(!!as.name(subject_var)) data[[subject_var]] <- factor(data[[subject_var]], levels = subject_levels) data %>% - mutate( + dplyr::mutate( !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), ) %>% - group_by(!!as.name(subject_var), !!as.name(time_var)) %>% - mutate( + dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% + dplyr::mutate( tooltip = paste( unique( c( @@ -216,19 +219,21 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v height = height ) %>% plotly::add_markers( - x = as.formula(sprintf("~%s", time_var)), - y = as.formula(sprintf("~%s", subject_var)), - color = as.formula(sprintf("~%s", color_var)), - symbol = as.formula(sprintf("~%s", color_var)), + x = stats::as.formula(sprintf("~%s", time_var)), + y = stats::as.formula(sprintf("~%s", subject_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + symbol = stats::as.formula(sprintf("~%s", color_var)), text = ~tooltip, hoverinfo = "text" ) %>% plotly::add_segments( - x = ~0, xend = ~study_day, - y = as.formula(sprintf("~%s", subject_var)), yend = as.formula(sprintf("~%s", subject_var)), + x = ~0, + xend = ~study_day, + y = stats::as.formula(sprintf("~%s", subject_var)), + yend = stats::as.formula(sprintf("~%s", subject_var)), data = data |> - group_by(!!as.name(subject_var), !!as.name(group_var)) |> - summarise(study_day = max(!!as.name(time_var))), + dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> + dplyr::summarise(study_day = max(!!as.name(time_var))), line = list(width = 2, color = "grey"), showlegend = FALSE ) %>% diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index b5af546a8..a83cfc58c 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -136,7 +136,7 @@ srv_g_waterfall <- function(id, children_datanames = table_datanames ) - srv_t_reactables("subtables", data = tables_selected_q, dataname = table_datanames, reactable_args = reactable_args) + srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) }) } @@ -172,9 +172,9 @@ waterfally <- function(data, subject_var, value_var, color_var, colors, value_ar height = height ) %>% plotly::add_bars( - x = as.formula(sprintf("~%s", subject_var)), - y = as.formula(sprintf("~%s", value_var)), - color = as.formula(sprintf("~%s", color_var)), + x = stats::as.formula(sprintf("~%s", subject_var)), + y = stats::as.formula(sprintf("~%s", value_var)), + color = stats::as.formula(sprintf("~%s", color_var)), colors = colors, text = ~tooltip, hoverinfo = "text" diff --git a/R/tm_markdown.R b/R/tm_markdown.R new file mode 100644 index 000000000..53d6d489e --- /dev/null +++ b/R/tm_markdown.R @@ -0,0 +1,80 @@ +#' `teal` module: Rmarkdown page +#' +#' Render arbitrary Rmarkdown code. `data` provided to teal application are available in the +#' rendered document. +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @inheritParams rmarkdown::render +#' @param text (`character`) arbitrary Rmd code +#' +#' @inherit shared_params return +#' +#' @examplesShinylive +#' library(teal.modules.general) +#' interactive <- function() TRUE +#' {{ next_example }} +#' @examples +#' data <- teal_data() |> +#' within({ +#' iris <- iris +#' mtcars <- mtcars +#' }) +# +#' +#' @export +#' +tm_rmarkdown <- function(label = "App Info", + text = character(0), + params = list(title = "Document", output = "html_output"), + datanames = "all") { + message("Initializing tm_front_page") + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_character(text, min.len = 0, any.missing = FALSE) + checkmate::assert_list(params) + + + ans <- module( + label = label, + server = srv_rmarkdown, + ui = ui_rmarkdown, + server_args = list(text = text, params = params), + datanames = datanames + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the front page module +ui_rmarkdown <- function(id, ...) { + args <- list(...) + ns <- NS(id) + uiOutput(ns("output")) +} + +# Server function for the front page module +srv_rmarkdown <- function(id, data, text, params) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + file <- tempfile(fileext = ".Rmd") + if (!file.exists(file)) { + cat(text, file = file) + } + + rmd_out <- reactive({ + rmarkdown::render( + file, + envir = data(), + params = utils::modifyList(params, list(output = "html_document")) # html_document always as we renderUI below + ) + }) + + output$output <- renderUI({ + on.exit(unlink(rmd_out())) + shiny::HTML(paste(readLines(rmd_out()), collpse = "\n")) + }) + }) +} diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 2f899a247..1f2a5ff13 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -147,7 +147,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco names(dataset_labels()) } labels_choices <- dataset_labels()[choices] - cols_choices_new <- setNames(choices, labels_choices) + cols_choices_new <- stats::setNames(choices, labels_choices) if (!identical(cols_choices_new, cols_choices())) { logger::log_debug("srv_t_reactable@1 update column choices") shinyWidgets::updatePickerInput( @@ -216,7 +216,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco .make_reactable_call <- function(dataset, dataname, args) { columns <- .make_reactable_columns_call(dataset = dataset, col_defs = args$columns) - call_args <- modifyList( + call_args <- utils::modifyList( list(columns = columns, onClick = "select"), args[!names(args) %in% "columns"] ) @@ -248,7 +248,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco is_labelled <- length(label) == 1 && !is.na(label) && !identical(label, "") default_col_def <- if (is_labelled) list(name = label) else list() col_def_override <- if (!is.null(col_defs[[i]])) col_defs[[i]] else list() - col_def_args <- modifyList(default_col_def, col_def_override) + col_def_args <- utils::modifyList(default_col_def, col_def_override) if (length(col_def_args)) { as.call( c( diff --git a/R/tm_variable_browser.R b/R/tm_variable_browser.R index c6819fadb..a48148dfa 100644 --- a/R/tm_variable_browser.R +++ b/R/tm_variable_browser.R @@ -956,7 +956,7 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, join_keys <- teal.data::join_keys(data()) if (!is.null(join_keys)) { - icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" + icons[intersect(teal.data::join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" } icons <- variable_type_icons(icons) diff --git a/R/utils.R b/R/utils.R index 92a62bdb6..7d32953ed 100644 --- a/R/utils.R +++ b/R/utils.R @@ -358,11 +358,11 @@ children <- function(x, dataset_name = character(0)) { names( Filter( function(parent) parent == dataset_name, - parents(x) + teal.data::parents(x) ) ) } else { - all_parents <- unique(unlist(parents(x))) + all_parents <- unique(unlist(teal.data::parents(x))) names(all_parents) <- all_parents lapply( all_parents, @@ -392,10 +392,10 @@ children <- function(x, dataset_name = character(0)) { plotly_selected_q <- reactive({ req(plotly_selected()) # todo: change it to foreign keys needed to merge with children_datanames - primary_keys <- unname(join_keys(data())[plot_dataname, plot_dataname]) + primary_keys <- unname(teal.data::join_keys(data())[plot_dataname, plot_dataname]) if (length(primary_keys) == 0) { primary_keys <- unique(sapply(children_datanames, USE.NAMES = FALSE, FUN = function(childname) { - names(join_keys(data())[plot_dataname, childname]) + names(teal.data::join_keys(data())[plot_dataname, childname]) })) } req(primary_keys) @@ -427,7 +427,7 @@ children <- function(x, dataset_name = character(0)) { lapply( children_names(), function(childname) { - join_cols <- join_keys(plotly_selected_q())[childname, plot_dataname] + join_cols <- teal.data::join_keys(plotly_selected_q())[childname, plot_dataname] substitute( expr = { childname <- dplyr::right_join(childname, swimlane_selected, by = by) @@ -440,6 +440,6 @@ children <- function(x, dataset_name = character(0)) { } ) ) - q <- eval_code(plotly_selected_q(), exprs) + q <- teal.code::eval_code(plotly_selected_q(), exprs) }) } diff --git a/R/zzz.R b/R/zzz.R index 2ccb87747..fcc99baf1 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -7,4 +7,5 @@ ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void") #' @importFrom lifecycle deprecated +#' @importFrom rlang := interactive <- NULL diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd new file mode 100644 index 000000000..fcd41be03 --- /dev/null +++ b/man/tm_rmarkdown.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_markdown.R +\name{tm_rmarkdown} +\alias{tm_rmarkdown} +\title{\code{teal} module: Rmarkdown page} +\usage{ +tm_rmarkdown( + label = "App Info", + text = character(0), + params = list(title = "Document", output = "html_output"), + datanames = "all" +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{text}{(\code{character}) arbitrary Rmd code} + +\item{params}{A list of named parameters that override custom params +specified within the YAML front-matter (e.g. specifying a dataset to read or +a date range to confine output to). Pass \code{"ask"} to start an +application that helps guide parameter configuration.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} +} +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} +\description{ +Render arbitrary Rmarkdown code. \code{data} provided to teal application are available in the +rendered document. +} +\examples{ +data <- teal_data() |> + within({ + iris <- iris + mtcars <- mtcars + }) + +} +\section{Examples in Shinylive}{ +\describe{ + \item{example-1}{ + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG10AHwA+JV1dAHdaUgALFXYQKOjdWkZaUR8MrNE06JhSAhYco11i0sYCiGiAX0UIMHqAXSA}{Open in Shinylive} + \if{html}{\out{}} + \if{html}{\out{}} + } +} +} + From a128ff7a24f55c368044ae675d9ec45c897c133d Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 28 Mar 2025 11:46:07 +0000 Subject: [PATCH 075/158] tm_rmarkdown --- DESCRIPTION | 1 + R/tm_markdown.R | 22 +++++++++++++--------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a69bec3fa..fc1849a59 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -47,6 +47,7 @@ Imports: grDevices, grid, gridExtra (>= 2.3), + htmltools, htmlwidgets (>= 1.6.4), jsonlite (>= 1.8.9), lattice (>= 0.18-4), diff --git a/R/tm_markdown.R b/R/tm_markdown.R index 53d6d489e..fd7947d37 100644 --- a/R/tm_markdown.R +++ b/R/tm_markdown.R @@ -26,9 +26,9 @@ #' tm_rmarkdown <- function(label = "App Info", text = character(0), - params = list(title = "Document", output = "html_output"), + params = list(title = "Document"), datanames = "all") { - message("Initializing tm_front_page") + message("Initializing tm_rmarkdown") # Start of assertions checkmate::assert_string(label) @@ -59,22 +59,26 @@ srv_rmarkdown <- function(id, data, text, params) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { - file <- tempfile(fileext = ".Rmd") - if (!file.exists(file)) { - cat(text, file = file) - } - rmd_out <- reactive({ + file <- tempfile(fileext = ".Rmd") + if (!file.exists(file)) { + cat(text, file = file) + } rmarkdown::render( file, envir = data(), - params = utils::modifyList(params, list(output = "html_document")) # html_document always as we renderUI below + params = utils::modifyList( + params, + list(output = list(github_document = list(html_preview = FALSE))) # html_document always as we renderUI below + ) ) }) output$output <- renderUI({ on.exit(unlink(rmd_out())) - shiny::HTML(paste(readLines(rmd_out()), collpse = "\n")) + # todo: includeMarkdown breaks css of the app + # https://stackoverflow.com/questions/42422771/including-markdown-tables-in-shiny-app-seems-to-break-css + shiny::includeMarkdown(rmd_out()) }) }) } From bc1b4adcc06eaba05729d47817ab8d80515314c6 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 28 Mar 2025 13:00:17 +0000 Subject: [PATCH 076/158] tm_rmarkdown --- R/tm_g_swimlane.R | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 063dfe467..d49f64b3d 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -65,7 +65,7 @@ ui_g_swimlane <- function(id, height) { sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), bslib::page_fillable( - plotly_with_settings_ui(ns("plot"), height = "100"), + plotly::plotlyOutput(ns("plot"), height = "100%"), ui_t_reactables(ns("subtables")) ) ) @@ -145,14 +145,7 @@ srv_g_swimlane <- function(id, ) }) - output$plot <- plotly_with_settings_srv( - "plot", - plot = reactive({ - plotly_q()$p |> - plotly::event_register("plotly_selected") |> - plotly::event_register("plotly_deselect") # todo: deselect doesn't work - }) - ) + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) plotly_selected <- reactive({ plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work From 2bbbb96d5d0d76f682b3edb3f05351d2eae41ce1 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 2 Apr 2025 08:26:26 +0000 Subject: [PATCH 077/158] choices selected --- R/tm_g_spiderplot.R | 78 +++++++++++++++++++++++++----------- R/tm_g_swimlane.R | 86 ++++++++++++++++++++------------------- R/tm_g_waterfall.R | 91 +++++++++++++++++++++++++----------------- R/utils.R | 20 ++++++++-- man/tm_g_spiderplot.Rd | 10 ++--- man/tm_g_swimlane.Rd | 12 +++--- man/tm_g_waterfall.Rd | 7 ++-- man/tm_rmarkdown.Rd | 2 +- 8 files changed, 185 insertions(+), 121 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index ecc79c07a..5653e0dda 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -4,13 +4,13 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as x-axis. -#' @param value_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as y-axis. +#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. +#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as x-axis. +#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as y-axis. #' column. -#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used as grouping variable for displayed lines/points. -#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate colors and symbols. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. @@ -30,6 +30,22 @@ tm_g_spiderplot <- function(label = "Spiderplot", table_datanames = character(0), reactable_args = list(), transformator = transformator) { + if (is.character(time_var)) { + time_var <- choices_selected(choices = time_var, selected = time_var) + } + if (is.character(value_var)) { + value_var <- choices_selected(choices = value_var, selected = value_var) + } + if (is.character(subject_var)) { + subject_var <- choices_selected(choices = subject_var, selected = subject_var) + } + if (is.character(color_var)) { + color_var <- choices_selected(choices = color_var, selected = color_var) + } + if (is.character(event_var)) { + event_var <- choices_selected(choices = event_var, selected = event_var) + } + module( label = label, ui = ui_g_spiderplot, @@ -56,7 +72,12 @@ ui_g_spiderplot <- function(id, height) { ns <- NS(id) bslib::page_sidebar( sidebar = div( - selectInput(ns("select_event"), "Select Y Axis", NULL), + selectInput(ns("time_var"), label = "Time variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("value_var"), label = "Value variable (y-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("subject_var"), label = "Subject variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("evant_var_level"), "Select an event:", NULL), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), @@ -82,42 +103,51 @@ srv_g_spiderplot <- function(id, reactable_args = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { - event_levels <- reactive({ - req(data()) - unique(data()[[plot_dataname]][[event_var]]) + .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) + .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) + .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) + .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) + .update_cs_input(inputId = "event_var", data = reactive(data()[[dataname]]), cs = event_var) + + evant_var_levels <- reactive({ + req(data(), input$event_var) + unique(data()[[plot_dataname]][[input$event_var]]) }) - observeEvent(event_levels(), { - updateSelectInput(inputId = "select_event", choices = event_levels(), selected = event_levels()[1]) + observeEvent(evant_var_levels(), { + updateSelectInput(inputId = "evant_var_level", choices = evant_var_levels(), selected = evant_var_levels()[1]) }) color_inputs <- colour_picker_srv( "colors", - x = reactive(data()[[plot_dataname]][[color_var]]), + x = reactive({ + req(input$color_var) + data()[[plot_dataname]][[input$color_var]] + }), default_colors = point_colors ) plotly_q <- reactive({ - req(input$select_event, color_inputs()) + req(input$evant_var_level, input$time_var, input$value_var, input$subject_var, input$event_var, input$color_var, color_inputs()) adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[plot_dataname]][[color_var]]), + levels = unique(data()[[plot_dataname]][[input$color_var]]), symbol = point_symbols ) within( data(), dataname = str2lang(plot_dataname), - event_var_lang = str2lang(event_var), - time_var = time_var, - value_var = value_var, - subject_var = subject_var, - event_var = event_var, - color_var = color_var, - selected_event = input$select_event, + event_var_lang = str2lang(input$event_var), + time_var = input$time_var, + value_var = input$value_var, + subject_var = input$subject_var, + event_var = input$event_var, + selected_event = input$evant_var_level, + color_var = input$color_var, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - title = sprintf("%s over time", input$selected_event), + title = sprintf("%s over time", input$evant_var_level), expr = { p <- dataname %>% filter(event_var_lang == selected_event) %>% @@ -143,8 +173,8 @@ srv_g_spiderplot <- function(id, tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, - xvar = time_var, - yvar = value_var, + xvar = reactive(input$time_var), + yvar = reactive(input$value_var), plotly_selected = plotly_selected, children_datanames = table_datanames ) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index d49f64b3d..4d6d767f3 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -4,17 +4,17 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as x-axis. -#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. +#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as x-axis. +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used as y-axis. -#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to name and color subject events in time. -#' @param group_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param group_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to categorize type of event. #' (legend is sorted according to this variable, and used in toolip to display type of the event) #' todo: this can be fixed by ordering factor levels -#' @param sort_var (`character(1)` or `select_spec`) name(s) of the column in `plot_dataname` which +#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which #' value determines order of the subjects displayed on the y-axis. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. @@ -33,6 +33,21 @@ tm_g_swimlane <- function(label = "Swimlane", plot_height = 700, table_datanames = character(0), reactable_args = list()) { + if (is.character(time_var)) { + time_var <- choices_selected(choices = time_var, selected = time_var) + } + if (is.character(subject_var)) { + subject_var <- choices_selected(choices = subject_var, selected = subject_var) + } + if (is.character(color_var)) { + color_var <- choices_selected(choices = color_var, selected = color_var) + } + if (is.character(group_var)) { + group_var <- choices_selected(choices = group_var, selected = group_var) + } + if (is.character(sort_var)) { + sort_var <- choices_selected(choices = sort_var, selected = sort_var) + } module( label = label, ui = ui_g_swimlane, @@ -55,12 +70,14 @@ tm_g_swimlane <- function(label = "Swimlane", } ui_g_swimlane <- function(id, height) { - - ns <- NS(id) bslib::page_sidebar( sidebar = div( - selectInput(ns("sort_by"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("time_var"), label = "Time variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("subject_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), @@ -84,48 +101,35 @@ srv_g_swimlane <- function(id, reactable_args = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { - - sort_choices <- reactiveVal() - sort_selected <- reactiveVal() - if (inherits(sort_var, c("choices_selected", "select_spec"))) { - if (length(sort_var$choices) == 1) { - sort_var <- sort_var$choices - } else { - updateSelectInput(inputId = "sort_by", choices = sort_var$choices, selected = sort_var$selected) - observeEvent(input$sort_by, { - if (!identical(input$sort_by, sort_selected())) { - sort_selected(input$sort_by) - } - }) - } - } - - if (length(sort_var) == 1) { - isolate(sort_choices(sort_var)) - isolate(sort_selected(sort_var)) - shinyjs::hide("sort_by") - } - + .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) + .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) + .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) + .update_cs_input(inputId = "group_var", data = reactive(data()[[dataname]]), cs = group_var) + .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) + color_inputs <- colour_picker_srv( "colors", - x = reactive(data()[[plot_dataname]][[color_var]]), + x = reactive({ + req(input$color_var) + data()[[plot_dataname]][[input$color_var]] + }), default_colors = point_colors ) plotly_q <- reactive({ - req(data(), sort_selected(), color_inputs()) + req(data(), input$time_var, input$subject_var, input$color_var, input$group_var, input$sort_var, color_inputs()) adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[plot_dataname]][[color_var]]), + levels = unique(data()[[plot_dataname]][[input$color_var]]), symbol = point_symbols ) within( data(), dataname = str2lang(plot_dataname), - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_selected(), + time_var = input$time_var, + subject_var = input$subject_var, + color_var = input$color_var, + group_var = input$group_var, + sort_var = input$sort_var, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, @@ -155,8 +159,8 @@ srv_g_swimlane <- function(id, tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, - xvar = time_var, - yvar = subject_var, + xvar = reactive(input$time_var), + yvar = reactive(input$subject_var), plotly_selected = plotly_selected, children_datanames = table_datanames ) diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index a83cfc58c..751528a18 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -5,10 +5,10 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. -#' @param subject_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used as x-axis. -#' @param value_var (`character(1)`) name of the `numeric` column in `plot_dataname` to be used as y-axis. -#' @param color_var (`character(1)`) name of the `factor` or `character` column in `plot_dataname` +#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as y-axis. +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate bar colors. #' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. @@ -19,6 +19,7 @@ tm_g_waterfall <- function(label = "Waterfall", plot_dataname, subject_var, value_var, + sort_var = NULL, color_var = NULL, bar_colors = list(), value_arbitrary_hlines = c(0.2, -0.3), @@ -26,6 +27,19 @@ tm_g_waterfall <- function(label = "Waterfall", plot_height = 700, table_datanames = character(0), reactable_args = list()) { + if (is.character(subject_var)) { + subject_var <- choices_selected(choices = subject_var, selected = subject_var) + } + if (is.character(value_var)) { + value_var <- choices_selected(choices = value_var, selected = value_var) + } + if (is.character(sort_var)) { + sort_var <- choices_selected(choices = sort_var, selected = sort_var) + } + if (is.character(color_var)) { + color_var <- choices_selected(choices = color_var, selected = color_var) + } + module( label = label, ui = ui_g_waterfall, @@ -37,6 +51,7 @@ tm_g_waterfall <- function(label = "Waterfall", table_datanames = table_datanames, subject_var = subject_var, value_var = value_var, + sort_var = sort_var, color_var = color_var, bar_colors = bar_colors, value_arbitrary_hlines = value_arbitrary_hlines, @@ -51,7 +66,10 @@ ui_g_waterfall <- function(id, height) { bslib::page_sidebar( sidebar = div( - uiOutput(ns("color_by_output")), + selectInput(ns("subject_var"), label = "Subject variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("value_var"), label = "Value variable (y-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), @@ -66,6 +84,7 @@ srv_g_waterfall <- function(id, plot_dataname, subject_var, value_var, + sort_var, color_var, bar_colors, value_arbitrary_hlines, @@ -75,33 +94,30 @@ srv_g_waterfall <- function(id, reactable_args = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { - output$color_by_output <- renderUI({ - selectInput(session$ns("color_by"), label = "Color by:", choices = color_var$choices, selected = color_var$selected) - }) - if (length(color_var$choices) > 1) { - shinyjs::show("color_by") - } else { - shinyjs::hide("color_by") - } + .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) + .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) + .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) + .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) color_inputs <- colour_picker_srv( "colors", x = reactive({ - req(data(), input$color_by) - data()[[plot_dataname]][[input$color_by]] + req(data(), input$color_var) + data()[[plot_dataname]][[input$color_var]] }), default_colors = bar_colors ) plotly_q <- reactive({ - req(data(), input$color_by, color_inputs()) + req(data(), input$subject_var, input$value_var, input$sort_var, input$color_var, color_inputs()) within( data(), dataname = str2lang(plot_dataname), - subject_var = subject_var, - value_var = value_var, - color_var = input$color_by, + subject_var = input$subject_var, + value_var = input$value_var, + sort_var = input$sort_var, + color_var = input$color_var, colors = color_inputs(), value_arbitrary_hlines = value_arbitrary_hlines, height = input$plot_height, @@ -110,7 +126,8 @@ srv_g_waterfall <- function(id, p <- waterfally( dataname, subject_var = subject_var, - value_var = value_var, + value_var = value_var, + sort_var = sort_var, color_var = color_var, colors = colors, value_arbitrary_hlines = value_arbitrary_hlines, @@ -130,8 +147,8 @@ srv_g_waterfall <- function(id, tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, - xvar = subject_var, - yvar = value_var, + xvar = reactive(input$subject_var), + yvar = reactive(input$value_var), plotly_selected = plotly_selected, children_datanames = table_datanames ) @@ -143,29 +160,29 @@ srv_g_waterfall <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export -waterfally <- function(data, subject_var, value_var, color_var, colors, value_arbitrary_hlines, height) { +waterfally <- function(data, subject_var, value_var, sort_var, color_var, colors, value_arbitrary_hlines, height) { subject_var_label <- attr(data[[subject_var]], "label") value_var_label <- attr(data[[value_var]], "label") color_var_label <- attr(data[[color_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var if (!length(value_var_label)) value_var_label <- value_var if (!length(color_var_label)) color_var_label <- color_var - data %>% - dplyr::mutate( - !!as.name(subject_var) := forcats::fct_reorder( - as.factor(!!as.name(subject_var)), - !!as.name(value_var), - .fun = max, - .desc = TRUE - ), - tooltip = sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), - value_var_label, !!as.name(value_var), - color_var_label, !!as.name(color_var) - ) - ) %>% + dplyr::mutate( + if (identical(sort_var, value_var) || is.null(sort_var)) { + dplyr::arrange(data, desc(!!as.name(value_var))) + } else { + dplyr::arrange(data, !!as.name(sort_var), desc(!!as.name(value_var))) + }, + !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), + tooltip = sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), + value_var_label, !!as.name(value_var), + color_var_label, !!as.name(color_var) + ) + ) %>% dplyr::filter(!duplicated(!!as.name(subject_var))) %>% plotly::plot_ly( source = "waterfall", diff --git a/R/utils.R b/R/utils.R index 7d32953ed..565cfa6a7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -389,9 +389,11 @@ children <- function(x, dataset_name = character(0)) { #' @param plotly_selected (`reactive`) #' @param children_datanames (`character`) .plotly_selected_filter_children <- function(data, plot_dataname, xvar, yvar, plotly_selected, children_datanames) { + xvar_r <- if (is.reactive(xvar)) xvar else reactive(xvar) + yvar_r <- if (is.reactive(yvar)) yvar else reactive(yvar) + plotly_selected_q <- reactive({ - req(plotly_selected()) - # todo: change it to foreign keys needed to merge with children_datanames + req(plotly_selected(), xvar_r(), yvar_r()) primary_keys <- unname(teal.data::join_keys(data())[plot_dataname, plot_dataname]) if (length(primary_keys) == 0) { primary_keys <- unique(sapply(children_datanames, USE.NAMES = FALSE, FUN = function(childname) { @@ -406,8 +408,8 @@ children <- function(x, dataset_name = character(0)) { dplyr::select(primary_keys) }, dataname = str2lang(plot_dataname), - xvar = str2lang(xvar), - yvar = str2lang(yvar), + xvar = str2lang(xvar_r()), + yvar = str2lang(yvar_r()), xvals = plotly_selected()$x, yvals = plotly_selected()$y, primary_keys = primary_keys @@ -443,3 +445,13 @@ children <- function(x, dataset_name = character(0)) { q <- teal.code::eval_code(plotly_selected_q(), exprs) }) } + + +.update_cs_input <- function(inputId, data, cs) { + if (!missing(data) && !length(names(cs))) { + labels <- teal.data::col_labels(isolate(data()))[cs$choices] + names(cs$choices) <- labels + } + updateSelectInput(inputId = inputId, choices = cs$choices, selected = cs$selected) + if (length(cs$choices) < 2) shinyjs::hide(inputId) +} \ No newline at end of file diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index d0d23bb34..50d98e99a 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -24,17 +24,17 @@ tm_g_spiderplot( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} +\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} -\item{time_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} -\item{value_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis. +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis. column.} -\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} -\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate colors and symbols.} \item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index 19c82a9be..9e8afa574 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -23,22 +23,22 @@ tm_g_swimlane( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} +\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} -\item{time_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} -\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as y-axis.} -\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to name and color subject events in time.} -\item{group_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to categorize type of event. (legend is sorted according to this variable, and used in toolip to display type of the event) todo: this can be fixed by ordering factor levels} -\item{sort_var}{(\code{character(1)} or \code{select_spec}) name(s) of the column in \code{plot_dataname} which +\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which value determines order of the subjects displayed on the y-axis.} \item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index 660825bf3..c79898159 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -9,6 +9,7 @@ tm_g_waterfall( plot_dataname, subject_var, value_var, + sort_var = NULL, color_var = NULL, bar_colors = list(), value_arbitrary_hlines = c(0.2, -0.3), @@ -24,12 +25,12 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} -\item{subject_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as x-axis.} -\item{value_var}{(\code{character(1)}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis.} +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis.} -\item{color_var}{(\code{character(1)}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate bar colors.} \item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index fcd41be03..3609ef8b4 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -7,7 +7,7 @@ tm_rmarkdown( label = "App Info", text = character(0), - params = list(title = "Document", output = "html_output"), + params = list(title = "Document"), datanames = "all" ) } From 8234f77ca4ae3b314ffe4b63756bcc9036a84a47 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 2 Apr 2025 08:57:48 +0000 Subject: [PATCH 078/158] update --- R/tm_g_spiderplot.R | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 5653e0dda..ab9a17ce7 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -77,7 +77,7 @@ ui_g_spiderplot <- function(id, height) { selectInput(ns("subject_var"), label = "Subject variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("evant_var_level"), "Select an event:", NULL), + selectInput(ns("event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), @@ -109,12 +109,22 @@ srv_g_spiderplot <- function(id, .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) .update_cs_input(inputId = "event_var", data = reactive(data()[[dataname]]), cs = event_var) - evant_var_levels <- reactive({ + event_var_levels <- reactive({ req(data(), input$event_var) + # comment: + # i don't know if it makes sense. I think it will be rare that dataset would have multiple + # category variables. There would rather be another dataset (consider responses, interventions etc.) unique(data()[[plot_dataname]][[input$event_var]]) }) - observeEvent(evant_var_levels(), { - updateSelectInput(inputId = "evant_var_level", choices = evant_var_levels(), selected = evant_var_levels()[1]) + observeEvent(event_var_levels(), { + label <- attr(data()[[plot_dataname]][[input$event_var]], "label") + updateSelectInput( + inputId = "event_var_level", + label = sprintf("Select %s:", if (length(label)) label else "en event:"), + choices = event_var_levels(), + selected = event_var_levels()[1] + ) + if (length(event_var_levels()) < 2) shinyjs::hide("event_var_level") }) color_inputs <- colour_picker_srv( @@ -127,7 +137,7 @@ srv_g_spiderplot <- function(id, ) plotly_q <- reactive({ - req(input$evant_var_level, input$time_var, input$value_var, input$subject_var, input$event_var, input$color_var, color_inputs()) + req(input$event_var_level, input$time_var, input$value_var, input$subject_var, input$event_var, input$color_var, color_inputs()) adjusted_symbols <- .shape_palette_discrete( levels = unique(data()[[plot_dataname]][[input$color_var]]), @@ -142,12 +152,12 @@ srv_g_spiderplot <- function(id, value_var = input$value_var, subject_var = input$subject_var, event_var = input$event_var, - selected_event = input$evant_var_level, + selected_event = input$event_var_level, color_var = input$color_var, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - title = sprintf("%s over time", input$evant_var_level), + title = sprintf("%s over time", input$event_var_level), expr = { p <- dataname %>% filter(event_var_lang == selected_event) %>% From 7a2658900efdb1b5aceb3db2da181f503db623a2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 2 May 2025 12:53:23 +0530 Subject: [PATCH 079/158] chore: format package --- R/module_colur_picker.R | 20 ++++---- R/tm_g_spiderplot.R | 83 ++++++++++++++++++------------- R/tm_g_swimlane.R | 107 +++++++++++++++++++++------------------- R/tm_g_waterfall.R | 73 ++++++++++++++++----------- R/tm_t_reactable.R | 45 ++++++++--------- R/utils.R | 17 ++++--- man/tm_g_spiderplot.Rd | 11 +++-- man/tm_g_swimlane.Rd | 11 +++-- man/tm_g_waterfall.Rd | 7 +-- 9 files changed, 205 insertions(+), 169 deletions(-) diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 7d5fd7602..460f9365e 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -17,14 +17,14 @@ colour_picker_srv <- function(id, x, default_colors) { color = default_colors ) }) - - color_values <- reactiveVal() + + color_values <- reactiveVal() observeEvent(default_colors_adjusted(), { if (!identical(default_colors_adjusted(), color_values())) { color_values(default_colors_adjusted()) } }) - + output$module <- renderUI({ tagList( lapply( @@ -35,10 +35,10 @@ colour_picker_srv <- function(id, x, default_colors) { inputId = session$ns(.name_to_id(level)), label = level, value = color_values()[level] - ) + ) ) } - ) + ) ) }) @@ -52,7 +52,7 @@ colour_picker_srv <- function(id, x, default_colors) { isolate(color_input_values(new_input_values)) } }) - + color_input_values }) } @@ -60,17 +60,17 @@ colour_picker_srv <- function(id, x, default_colors) { #' Color palette discrete -#' -#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by +#' +#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by #' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels #' as the rest will be filled automatically. #' @param levels (`character`) values of possible variable levels #' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`. #' @return `character` with hex colors named by `levels`. -.color_palette_discrete <- function(levels, color) { +.color_palette_discrete <- function(levels, color) { p <- color[names(color) %in% levels] p_rgb_num <- grDevices::col2rgb(p) - p_hex <- grDevices::rgb(p_rgb_num[1,]/255, p_rgb_num[2,]/255, p_rgb_num[3,]/255) + p_hex <- grDevices::rgb(p_rgb_num[1, ] / 255, p_rgb_num[2, ] / 255, p_rgb_num[3, ] / 255) p <- stats::setNames(p_hex, names(p)) missing_levels <- setdiff(levels, names(p)) N <- length(levels) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index ab9a17ce7..4d6a7f055 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -1,20 +1,21 @@ #' `teal` module: Spider Plot #' #' Module visualizes value development in time grouped by subjects. -#' +#' #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as x-axis. -#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as y-axis. -#' column. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to be used as grouping variable for displayed lines/points. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` +#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' in `plot_dataname` to be used as x-axis. +#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' in `plot_dataname` to be used as y-axis. +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to be used as grouping variable for displayed lines/points. +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate colors and symbols. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` #' column. #' @export tm_g_spiderplot <- function(label = "Spiderplot", @@ -28,7 +29,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", point_symbols, plot_height = 600, table_datanames = character(0), - reactable_args = list(), + reactable_args = list(), transformator = transformator) { if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) @@ -73,7 +74,11 @@ ui_g_spiderplot <- function(id, height) { bslib::page_sidebar( sidebar = div( selectInput(ns("time_var"), label = "Time variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("value_var"), label = "Value variable (y-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput( + ns("value_var"), + label = "Value variable (y-axis):", + choices = NULL, selected = NULL, multiple = FALSE + ), selectInput(ns("subject_var"), label = "Subject variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), @@ -83,7 +88,7 @@ ui_g_spiderplot <- function(id, height) { ), bslib::page_fillable( plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) + ui_t_reactables(ns("subtables")) ) ) } @@ -108,11 +113,11 @@ srv_g_spiderplot <- function(id, .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) .update_cs_input(inputId = "event_var", data = reactive(data()[[dataname]]), cs = event_var) - + event_var_levels <- reactive({ req(data(), input$event_var) - # comment: - # i don't know if it makes sense. I think it will be rare that dataset would have multiple + # comment: + # i don't know if it makes sense. I think it will be rare that dataset would have multiple # category variables. There would rather be another dataset (consider responses, interventions etc.) unique(data()[[plot_dataname]][[input$event_var]]) }) @@ -121,29 +126,32 @@ srv_g_spiderplot <- function(id, updateSelectInput( inputId = "event_var_level", label = sprintf("Select %s:", if (length(label)) label else "en event:"), - choices = event_var_levels(), + choices = event_var_levels(), selected = event_var_levels()[1] ) if (length(event_var_levels()) < 2) shinyjs::hide("event_var_level") }) - + color_inputs <- colour_picker_srv( - "colors", + "colors", x = reactive({ req(input$color_var) data()[[plot_dataname]][[input$color_var]] }), default_colors = point_colors ) - + plotly_q <- reactive({ - req(input$event_var_level, input$time_var, input$value_var, input$subject_var, input$event_var, input$color_var, color_inputs()) - + req( + input$event_var_level, input$time_var, input$value_var, + input$subject_var, input$event_var, input$color_var, color_inputs() + ) + adjusted_symbols <- .shape_palette_discrete( levels = unique(data()[[plot_dataname]][[input$color_var]]), symbol = point_symbols ) - + within( data(), dataname = str2lang(plot_dataname), @@ -177,19 +185,24 @@ srv_g_spiderplot <- function(id, }) output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - + tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, + data = plotly_q, plot_dataname = plot_dataname, - xvar = reactive(input$time_var), - yvar = reactive(input$value_var), - plotly_selected = plotly_selected, + xvar = reactive(input$time_var), + yvar = reactive(input$value_var), + plotly_selected = plotly_selected, children_datanames = table_datanames ) - - srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) + + srv_t_reactables( + "subtables", + data = tables_selected_q, + datanames = table_datanames, + reactable_args = reactable_args + ) }) } @@ -202,7 +215,7 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo if (!length(subject_var_label)) subject_var_label <- subject_var if (!length(time_var_label)) time_var_label <- time_var if (!length(event_var_label)) event_var_label <- event_var - + data %>% dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::group_by(!!as.name(subject_var)) %>% @@ -210,15 +223,15 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), tooltip = sprintf( - "%s: %s
%s: %s
%s: %s%%
", + "%s: %s
%s: %s
%s: %s%%
", subject_var_label, !!as.name(subject_var), - time_var_label, !!as.name(time_var), + time_var_label, !!as.name(time_var), event_var_label, !!as.name(value_var) * 100 ) ) %>% dplyr::ungroup() %>% plotly::plot_ly( - source = "spiderplot", + source = "spiderplot", height = height, color = stats::as.formula(sprintf("~%s", color_var)), colors = colors, @@ -227,7 +240,7 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo plotly::add_segments( x = ~x, y = ~y, - xend = stats::as.formula(sprintf("~%s", time_var)), + xend = stats::as.formula(sprintf("~%s", time_var)), yend = stats::as.formula(sprintf("~%s", value_var)) ) %>% plotly::add_markers( diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 4d6d767f3..16a747c15 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -1,32 +1,33 @@ #' `teal` module: Swimlane plot #' #' Module visualizes subjects' events in time. -#' +#' #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as x-axis. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to be used as y-axis. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to name and color subject events in time. +#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' in `plot_dataname` to be used as x-axis. +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to be used as y-axis. +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to name and color subject events in time. #' @param group_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to categorize type of event. +#' to categorize type of event. #' (legend is sorted according to this variable, and used in toolip to display type of the event) #' todo: this can be fixed by ordering factor levels -#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which +#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which #' value determines order of the subjects displayed on the y-axis. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` -#' column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` +#' column. #' @export -tm_g_swimlane <- function(label = "Swimlane", - plot_dataname, - time_var, - subject_var, +tm_g_swimlane <- function(label = "Swimlane", + plot_dataname, + time_var, + subject_var, color_var, - group_var, + group_var, sort_var = NULL, point_colors = character(0), point_symbols, @@ -83,12 +84,12 @@ ui_g_swimlane <- function(id, height) { ), bslib::page_fillable( plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) + ui_t_reactables(ns("subtables")) ) ) } -srv_g_swimlane <- function(id, - data, +srv_g_swimlane <- function(id, + data, plot_dataname, time_var, subject_var, @@ -97,7 +98,7 @@ srv_g_swimlane <- function(id, sort_var = time_var, point_colors, point_symbols, - table_datanames, + table_datanames, reactable_args = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { @@ -108,14 +109,14 @@ srv_g_swimlane <- function(id, .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) color_inputs <- colour_picker_srv( - "colors", + "colors", x = reactive({ req(input$color_var) data()[[plot_dataname]][[input$color_var]] }), default_colors = point_colors ) - + plotly_q <- reactive({ req(data(), input$time_var, input$subject_var, input$color_var, input$group_var, input$sort_var, color_inputs()) adjusted_symbols <- .shape_palette_discrete( @@ -135,38 +136,42 @@ srv_g_swimlane <- function(id, height = input$plot_height, expr = { p <- swimlanely( - data = dataname, - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_var, - colors = colors, - symbols = symbols, + data = dataname, + time_var = time_var, + subject_var = subject_var, + color_var = color_var, + group_var = group_var, + sort_var = sort_var, + colors = colors, + symbols = symbols, height = height ) } ) }) - + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - + plotly_selected <- reactive({ plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work plotly::event_data("plotly_selected", source = "swimlane") }) - + tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, + data = plotly_q, plot_dataname = plot_dataname, - xvar = reactive(input$time_var), - yvar = reactive(input$subject_var), - plotly_selected = plotly_selected, + xvar = reactive(input$time_var), + yvar = reactive(input$subject_var), + plotly_selected = plotly_selected, children_datanames = table_datanames ) - - srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) + srv_t_reactables( + "subtables", + data = tables_selected_q, + datanames = table_datanames, + reactable_args = reactable_args + ) }) } @@ -178,7 +183,7 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v time_var_label <- attr(data[[time_var]], "label") if (!length(subject_var_label)) subject_var_label <- subject_var if (!length(time_var_label)) time_var_label <- time_var - + # forcats::fct_reorder doesn't seem to work here subject_levels <- data %>% dplyr::group_by(!!as.name(subject_var)) %>% @@ -187,12 +192,12 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v dplyr::arrange(v) %>% dplyr::pull(!!as.name(subject_var)) data[[subject_var]] <- factor(data[[subject_var]], levels = subject_levels) - + data %>% dplyr::mutate( !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), ) %>% - dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% + dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( tooltip = paste( unique( @@ -200,8 +205,8 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v paste(subject_var_label, !!as.name(subject_var)), paste(time_var_label, !!as.name(time_var)), sprintf( - "%s: %s", - tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), !!as.name(color_var) ) ) @@ -218,24 +223,24 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v plotly::add_markers( x = stats::as.formula(sprintf("~%s", time_var)), y = stats::as.formula(sprintf("~%s", subject_var)), - color = stats::as.formula(sprintf("~%s", color_var)), + color = stats::as.formula(sprintf("~%s", color_var)), symbol = stats::as.formula(sprintf("~%s", color_var)), text = ~tooltip, hoverinfo = "text" ) %>% plotly::add_segments( - x = ~0, - xend = ~study_day, - y = stats::as.formula(sprintf("~%s", subject_var)), + x = ~0, + xend = ~study_day, + y = stats::as.formula(sprintf("~%s", subject_var)), yend = stats::as.formula(sprintf("~%s", subject_var)), - data = data |> - dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> + data = data |> + dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> dplyr::summarise(study_day = max(!!as.name(time_var))), line = list(width = 2, color = "grey"), showlegend = FALSE ) %>% plotly::layout( - xaxis = list(title = time_var_label), + xaxis = list(title = time_var_label), yaxis = list(title = subject_var_label) ) %>% plotly::layout(dragmode = "select") %>% diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 751528a18..d7aaf1f0f 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -1,16 +1,17 @@ #' `teal` module: Waterfall plot #' #' Module visualizes subjects sorted decreasingly by y-values. -#' +#' #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to be used as x-axis. -#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column in `plot_dataname` to be used as y-axis. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to be used as x-axis. +#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' in `plot_dataname` to be used as y-axis. +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate bar colors. -#' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. #' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal #' lines on the plot. @@ -63,11 +64,19 @@ tm_g_waterfall <- function(label = "Waterfall", ui_g_waterfall <- function(id, height) { ns <- NS(id) - + bslib::page_sidebar( sidebar = div( - selectInput(ns("subject_var"), label = "Subject variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("value_var"), label = "Value variable (y-axis):", choices = NULL, selected = NULL, multiple = FALSE), + selectInput( + ns("subject_var"), + label = "Subject variable (x-axis):", + choices = NULL, selected = NULL, multiple = FALSE + ), + selectInput( + ns("value_var"), + label = "Value variable (y-axis):", + choices = NULL, selected = NULL, multiple = FALSE + ), selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), @@ -75,7 +84,7 @@ ui_g_waterfall <- function(id, height) { ), bslib::page_fillable( plotly::plotlyOutput(ns("plot"), height = "100%"), - ui_t_reactables(ns("subtables")) + ui_t_reactables(ns("subtables")) ) ) } @@ -98,19 +107,19 @@ srv_g_waterfall <- function(id, .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) - + color_inputs <- colour_picker_srv( - "colors", + "colors", x = reactive({ req(data(), input$color_var) data()[[plot_dataname]][[input$color_var]] }), default_colors = bar_colors ) - + plotly_q <- reactive({ req(data(), input$subject_var, input$value_var, input$sort_var, input$color_var, color_inputs()) - + within( data(), dataname = str2lang(plot_dataname), @@ -124,8 +133,8 @@ srv_g_waterfall <- function(id, title = sprintf("Waterfall plot"), expr = { p <- waterfally( - dataname, - subject_var = subject_var, + dataname, + subject_var = subject_var, value_var = value_var, sort_var = sort_var, color_var = color_var, @@ -134,7 +143,6 @@ srv_g_waterfall <- function(id, height = height ) %>% plotly::layout(title = title) - }, height = input$plot_height ) @@ -143,17 +151,22 @@ srv_g_waterfall <- function(id, output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) - + tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, + data = plotly_q, plot_dataname = plot_dataname, - xvar = reactive(input$subject_var), - yvar = reactive(input$value_var), - plotly_selected = plotly_selected, + xvar = reactive(input$subject_var), + yvar = reactive(input$value_var), + plotly_selected = plotly_selected, children_datanames = table_datanames ) - - srv_t_reactables("subtables", data = tables_selected_q, datanames = table_datanames, reactable_args = reactable_args) + + srv_t_reactables( + "subtables", + data = tables_selected_q, + datanames = table_datanames, + reactable_args = reactable_args + ) }) } @@ -164,21 +177,21 @@ waterfally <- function(data, subject_var, value_var, sort_var, color_var, colors subject_var_label <- attr(data[[subject_var]], "label") value_var_label <- attr(data[[value_var]], "label") color_var_label <- attr(data[[color_var]], "label") - + if (!length(subject_var_label)) subject_var_label <- subject_var if (!length(value_var_label)) value_var_label <- value_var if (!length(color_var_label)) color_var_label <- color_var - + dplyr::mutate( if (identical(sort_var, value_var) || is.null(sort_var)) { - dplyr::arrange(data, desc(!!as.name(value_var))) + dplyr::arrange(data, desc(!!as.name(value_var))) } else { dplyr::arrange(data, !!as.name(sort_var), desc(!!as.name(value_var))) }, !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), tooltip = sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), value_var_label, !!as.name(value_var), color_var_label, !!as.name(color_var) ) @@ -213,6 +226,6 @@ waterfally <- function(data, subject_var, value_var, sort_var, color_var, colors legend = list(title = list(text = "Color by:")), barmode = "relative" ) %>% - plotly::layout( dragmode = "select") %>% + plotly::layout(dragmode = "select") %>% plotly::config(displaylogo = FALSE) } diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 1f2a5ff13..07e0950a7 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,10 +1,10 @@ #' `teal` module: Reactable #' #' Wrapper module on [reactable::reactable()] -#' +#' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param reactable_args (`list`) any argument of [reactable::reactable()]. +#' @param reactable_args (`list`) any argument of [reactable::reactable()]. #' @export tm_t_reactables <- function(label = "Table", datanames = "all", @@ -18,8 +18,8 @@ tm_t_reactables <- function(label = "Table", server = srv_t_reactables, ui_args = list(decorators = decorators), server_args = list( - datanames = datanames, - colnames = colnames, + datanames = datanames, + colnames = colnames, reactable_args = reactable_args, decorators = decorators ), @@ -33,7 +33,9 @@ ui_t_reactables <- function(id, decorators = list()) { uiOutput(ns("subtables"), container = div) } -srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = list(), decorators = list(), reactable_args = list()) { +srv_t_reactables <- function( + id, data, filter_panel_api, datanames, + colnames = list(), decorators = list(), reactable_args = list()) { moduleServer(id, function(input, output, session) { datanames_r <- .validate_datanames(datanames = datanames, data = data) colnames_r <- reactive({ @@ -101,7 +103,7 @@ srv_t_reactables <- function(id, data, filter_panel_api, datanames, colnames = l ui_t_reactable <- function(id) { ns <- NS(id) - + input <- shinyWidgets::pickerInput( ns("colnames"), label = NULL, @@ -116,7 +118,7 @@ ui_t_reactable <- function(id) { liveSearch = TRUE ) ) - + # input <- actionButton(ns("show_select_colnames"), "Nothing selected", class = "rounded-pill btn-sm primary") |> # bslib::popover(input) bslib::page_fluid( @@ -134,7 +136,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco req(data()) teal.data::col_labels(data()[[dataname]], fill = TRUE) }) - + reactable_args_r <- if (is.reactive(reactable_args)) reactable_args else reactive(reactable_args) cols_choices <- reactiveVal() @@ -162,7 +164,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco observeEvent(input$colnames_open, `if`(!isTruthy(input$colnames_open), cols_selected(input$colnames))) observeEvent(cols_selected(), { updateActionButton( - inputId = "show_select_colnames", + inputId = "show_select_colnames", label = paste(substring(toString(cols_selected()), 1, 100), "...") ) }) @@ -175,23 +177,22 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco lapply(unname(cols_selected()), str2lang) ) ) - + reactable_call <- .make_reactable_call( - dataset = data()[[dataname]][cols_selected()], - dataname = dataname, + dataset = data()[[dataname]][cols_selected()], + dataname = dataname, args = reactable_args_r() ) - + data() |> within(lhs <- rhs, lhs = str2lang(dataname), rhs = select_call) |> within(lhs <- rhs, lhs = str2lang(dataname_reactable), rhs = reactable_call) - }) output$table <- reactable::renderReactable({ logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") table_q()[[dataname_reactable]] }) - + # todo: add select -> show children table table_selected_q <- reactive({ selected_row <- reactable::getReactableState("table", "selected") @@ -209,7 +210,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco table_q() } }) - + table_selected_q }) } @@ -217,7 +218,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco .make_reactable_call <- function(dataset, dataname, args) { columns <- .make_reactable_columns_call(dataset = dataset, col_defs = args$columns) call_args <- utils::modifyList( - list(columns = columns, onClick = "select"), + list(columns = columns, onClick = "select"), args[!names(args) %in% "columns"] ) as.call( @@ -225,7 +226,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco list( name = quote(reactable), data = str2lang(dataname) - ), + ), call_args ) ) @@ -272,12 +273,12 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco req(data()) names( Filter( - function(dataset) inherits(dataset, class), + function(dataset) inherits(dataset, class), as.list(data()) ) ) }) - + this_datanames_r <- reactive({ if (is.reactive(datanames)) { datanames() @@ -285,9 +286,9 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco datanames } }) - + datanames_r <- reactiveVal() - + observeEvent(all_datanames_r(), { new_datanames <- if (identical(this_datanames_r(), "all")) { all_datanames_r() diff --git a/R/utils.R b/R/utils.R index 565cfa6a7..17095fee0 100644 --- a/R/utils.R +++ b/R/utils.R @@ -365,7 +365,7 @@ children <- function(x, dataset_name = character(0)) { all_parents <- unique(unlist(teal.data::parents(x))) names(all_parents) <- all_parents lapply( - all_parents, + all_parents, function(parent) children(x = x, dataset_name = parent) ) } @@ -381,17 +381,18 @@ children <- function(x, dataset_name = character(0)) { #' Filters children datanames according to: #' - selected x and y values on the plot (based on the parent dataset) #' - [`teal.data::join_keys`] relationship between `children_datanames` -#' +#' #' @param data (`reactive teal_data`) #' @param plot_dataname (`character(1)`) #' @param xvar (`character(1)`) #' @param yvar (`character(1)`) #' @param plotly_selected (`reactive`) #' @param children_datanames (`character`) -.plotly_selected_filter_children <- function(data, plot_dataname, xvar, yvar, plotly_selected, children_datanames) { +.plotly_selected_filter_children <- function( + data, plot_dataname, xvar, yvar, plotly_selected, children_datanames) { xvar_r <- if (is.reactive(xvar)) xvar else reactive(xvar) yvar_r <- if (is.reactive(yvar)) yvar else reactive(yvar) - + plotly_selected_q <- reactive({ req(plotly_selected(), xvar_r(), yvar_r()) primary_keys <- unname(teal.data::join_keys(data())[plot_dataname, plot_dataname]) @@ -404,7 +405,7 @@ children <- function(x, dataset_name = character(0)) { within( data(), expr = { - swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% + swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% dplyr::select(primary_keys) }, dataname = str2lang(plot_dataname), @@ -415,7 +416,7 @@ children <- function(x, dataset_name = character(0)) { primary_keys = primary_keys ) }) - + children_names <- reactive({ if (length(children_datanames) == 0) { children(plotly_selected_q(), plot_dataname) @@ -423,7 +424,7 @@ children <- function(x, dataset_name = character(0)) { children_datanames } }) - + eventReactive(plotly_selected_q(), { exprs <- as.expression( lapply( @@ -454,4 +455,4 @@ children <- function(x, dataset_name = character(0)) { } updateSelectInput(inputId = inputId, choices = cs$choices, selected = cs$selected) if (length(cs$choices) < 2) shinyjs::hide(inputId) -} \ No newline at end of file +} diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index 50d98e99a..19477e291 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -26,13 +26,14 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as x-axis.} -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis. -column.} +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as y-axis.} -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used as grouping variable for displayed lines/points.} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} \item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate colors and symbols.} diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index 9e8afa574..fdea953fd 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -25,13 +25,14 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as x-axis.} -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used as y-axis.} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as y-axis.} -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to name and color subject events in time.} +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to name and color subject events in time.} \item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to categorize type of event. diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index c79898159..5ee97b703 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -25,10 +25,11 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used as x-axis.} +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as x-axis.} -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis.} +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as y-axis.} \item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate bar colors.} From 0c2e874ee558126ef2f2fe4f1e04ba63f047657d Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 2 May 2025 18:38:57 +0530 Subject: [PATCH 080/158] fix: handle color and shape edge cases + rename `event_var` param in `tm_g_spiderplot` --- R/module_colur_picker.R | 62 ++++++++++++++++++++++++++++---------- R/tm_g_spiderplot.R | 67 +++++++++++++++++++++-------------------- R/tm_g_swimlane.R | 2 +- R/tm_g_waterfall.R | 2 +- man/tm_g_spiderplot.Rd | 10 ++++-- man/tm_g_swimlane.Rd | 2 +- man/tm_g_waterfall.Rd | 2 +- 7 files changed, 92 insertions(+), 55 deletions(-) diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 460f9365e..137deed1e 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -69,31 +69,61 @@ colour_picker_srv <- function(id, x, default_colors) { #' @return `character` with hex colors named by `levels`. .color_palette_discrete <- function(levels, color) { p <- color[names(color) %in% levels] - p_rgb_num <- grDevices::col2rgb(p) - p_hex <- grDevices::rgb(p_rgb_num[1, ] / 255, p_rgb_num[2, ] / 255, p_rgb_num[3, ] / 255) - p <- stats::setNames(p_hex, names(p)) + + if (length(p) > 0) { + p_rgb_num <- grDevices::col2rgb(p) + p_hex <- grDevices::rgb(p_rgb_num[1, ] / 255, p_rgb_num[2, ] / 255, p_rgb_num[3, ] / 255) + p <- stats::setNames(p_hex, names(p)) + } + missing_levels <- setdiff(levels, names(p)) N <- length(levels) n <- length(p) m <- N - n + if (m > 0 && n > 0) { - current_space <- grDevices::rgb2hsv(grDevices::col2rgb(p)) - optimal_color_space <- colorspace::qualitative_hcl(N) - color_distances <- stats::dist(t(cbind(current_space, grDevices::rgb2hsv(grDevices::col2rgb(optimal_color_space))))) - optimal_to_current_dist <- as.matrix(color_distances)[seq_len(n), -seq_len(n)] - furthest_neighbours_idx <- order(apply(optimal_to_current_dist, 2, min), decreasing = TRUE) - missing_colors <- optimal_color_space[furthest_neighbours_idx][seq_len(m)] + all_colors <- colorspace::qualitative_hcl(N) + + if (n == 1) { + current_color_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(p)) + all_colors_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(all_colors)) + + distances <- numeric(length(all_colors)) + for (i in seq_along(all_colors)) { + h_diff <- min( + abs(current_color_hsv[1] - all_colors_hsv[1, i]), + 1 - abs(current_color_hsv[1] - all_colors_hsv[1, i]) + ) + s_diff <- abs(current_color_hsv[2] - all_colors_hsv[2, i]) + v_diff <- abs(current_color_hsv[3] - all_colors_hsv[3, i]) + distances[i] <- sqrt(h_diff^2 + s_diff^2 + v_diff^2) + } + + idx <- order(distances, decreasing = TRUE)[seq_len(m)] + missing_colors <- all_colors[idx] + } else { + remaining_colors <- all_colors[seq_len(m)] + missing_colors <- remaining_colors + } + p <- c(p, stats::setNames(missing_colors, missing_levels)) - } else if (length(missing_levels)) { - colorspace::qualitative_hcl(N) - } else { - p + } else if (m > 0) { + missing_colors <- colorspace::qualitative_hcl(m) + p <- stats::setNames(missing_colors, missing_levels) } - p[names(p) %in% levels] + + result <- p[match(levels, names(p))] + stats::setNames(result, levels) } + .shape_palette_discrete <- function(levels, symbol) { - s <- stats::setNames(symbol[levels], levels) - s[is.na(s)] <- "circle-open" + if (length(symbol) == 0) { + s <- rep("circle-open", length(levels)) + s <- stats::setNames(s, levels) + } else { + s <- stats::setNames(symbol[levels], levels) + s[is.na(s)] <- "circle-open" + } s } diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 4d6a7f055..292ee8f97 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -15,6 +15,9 @@ #' to be used to differentiate colors and symbols. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. +#' @param filter_event_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to be used to filter the data. +#' The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` #' column. #' @export @@ -23,10 +26,10 @@ tm_g_spiderplot <- function(label = "Spiderplot", time_var, value_var, subject_var, - event_var, + filter_event_var, color_var, - point_colors, - point_symbols, + point_colors = character(0), + point_symbols = character(0), plot_height = 600, table_datanames = character(0), reactable_args = list(), @@ -43,8 +46,8 @@ tm_g_spiderplot <- function(label = "Spiderplot", if (is.character(color_var)) { color_var <- choices_selected(choices = color_var, selected = color_var) } - if (is.character(event_var)) { - event_var <- choices_selected(choices = event_var, selected = event_var) + if (is.character(filter_event_var)) { + filter_event_var <- choices_selected(choices = filter_event_var, selected = filter_event_var) } module( @@ -57,7 +60,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", time_var = time_var, value_var = value_var, subject_var = subject_var, - event_var = event_var, + filter_event_var = filter_event_var, color_var = color_var, point_colors = point_colors, point_symbols = point_symbols, @@ -81,8 +84,8 @@ ui_g_spiderplot <- function(id, height) { ), selectInput(ns("subject_var"), label = "Subject variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("filter_event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("filter_event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), @@ -99,7 +102,7 @@ srv_g_spiderplot <- function(id, time_var, value_var, subject_var, - event_var, + filter_event_var, color_var, point_colors, point_symbols, @@ -112,24 +115,24 @@ srv_g_spiderplot <- function(id, .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) - .update_cs_input(inputId = "event_var", data = reactive(data()[[dataname]]), cs = event_var) + .update_cs_input(inputId = "filter_event_var", data = reactive(data()[[dataname]]), cs = filter_event_var) - event_var_levels <- reactive({ - req(data(), input$event_var) + filter_event_var_levels <- reactive({ + req(data(), input$filter_event_var) # comment: # i don't know if it makes sense. I think it will be rare that dataset would have multiple # category variables. There would rather be another dataset (consider responses, interventions etc.) - unique(data()[[plot_dataname]][[input$event_var]]) + unique(data()[[plot_dataname]][[input$filter_event_var]]) }) - observeEvent(event_var_levels(), { - label <- attr(data()[[plot_dataname]][[input$event_var]], "label") + observeEvent(filter_event_var_levels(), { + label <- attr(data()[[plot_dataname]][[input$filter_event_var]], "label") updateSelectInput( - inputId = "event_var_level", + inputId = "filter_event_var_level", label = sprintf("Select %s:", if (length(label)) label else "en event:"), - choices = event_var_levels(), - selected = event_var_levels()[1] + choices = filter_event_var_levels(), + selected = filter_event_var_levels()[1] ) - if (length(event_var_levels()) < 2) shinyjs::hide("event_var_level") + if (length(filter_event_var_levels()) < 2) shinyjs::hide("filter_event_var_level") }) color_inputs <- colour_picker_srv( @@ -143,8 +146,8 @@ srv_g_spiderplot <- function(id, plotly_q <- reactive({ req( - input$event_var_level, input$time_var, input$value_var, - input$subject_var, input$event_var, input$color_var, color_inputs() + input$filter_event_var_level, input$time_var, input$value_var, + input$subject_var, input$filter_event_var, input$color_var, color_inputs() ) adjusted_symbols <- .shape_palette_discrete( @@ -155,25 +158,25 @@ srv_g_spiderplot <- function(id, within( data(), dataname = str2lang(plot_dataname), - event_var_lang = str2lang(input$event_var), + filter_event_var_lang = str2lang(input$filter_event_var), time_var = input$time_var, value_var = input$value_var, subject_var = input$subject_var, - event_var = input$event_var, - selected_event = input$event_var_level, + filter_event_var = input$filter_event_var, + selected_event = input$filter_event_var_level, color_var = input$color_var, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - title = sprintf("%s over time", input$event_var_level), + title = sprintf("%s over time", input$filter_event_var_level), expr = { p <- dataname %>% - filter(event_var_lang == selected_event) %>% + dplyr::filter(filter_event_var_lang == selected_event) %>% spiderplotly( time_var = time_var, value_var = value_var, subject_var = subject_var, - event_var = event_var, + filter_event_var = filter_event_var, color_var = color_var, colors = colors, symbols = symbols, @@ -208,13 +211,13 @@ srv_g_spiderplot <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export -spiderplotly <- function(data, time_var, value_var, subject_var, event_var, color_var, colors, symbols, height) { +spiderplotly <- function(data, time_var, value_var, subject_var, filter_event_var, color_var, colors, symbols, height) { subject_var_label <- attr(data[[subject_var]], "label") time_var_label <- attr(data[[time_var]], "label") - event_var_label <- attr(data[[event_var]], "label") + filter_event_var_label <- attr(data[[filter_event_var]], "label") if (!length(subject_var_label)) subject_var_label <- subject_var if (!length(time_var_label)) time_var_label <- time_var - if (!length(event_var_label)) event_var_label <- event_var + if (!length(filter_event_var_label)) filter_event_var_label <- filter_event_var data %>% dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% @@ -226,7 +229,7 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo "%s: %s
%s: %s
%s: %s%%
", subject_var_label, !!as.name(subject_var), time_var_label, !!as.name(time_var), - event_var_label, !!as.name(value_var) * 100 + filter_event_var_label, !!as.name(value_var) * 100 ) ) %>% dplyr::ungroup() %>% @@ -252,7 +255,7 @@ spiderplotly <- function(data, time_var, value_var, subject_var, event_var, colo ) %>% plotly::layout( xaxis = list(title = time_var_label), - yaxis = list(title = event_var_label), + yaxis = list(title = filter_event_var_label), title = title, dragmode = "select" ) %>% diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 16a747c15..8523a989c 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -30,7 +30,7 @@ tm_g_swimlane <- function(label = "Swimlane", group_var, sort_var = NULL, point_colors = character(0), - point_symbols, + point_symbols = character(0), plot_height = 700, table_datanames = character(0), reactable_args = list()) { diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index d7aaf1f0f..71fceee17 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -22,7 +22,7 @@ tm_g_waterfall <- function(label = "Waterfall", value_var, sort_var = NULL, color_var = NULL, - bar_colors = list(), + bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", plot_height = 700, diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index 19477e291..2653b3ba3 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -10,10 +10,10 @@ tm_g_spiderplot( time_var, value_var, subject_var, - event_var, + filter_event_var, color_var, - point_colors, - point_symbols, + point_colors = character(0), + point_symbols = character(0), plot_height = 600, table_datanames = character(0), reactable_args = list(), @@ -35,6 +35,10 @@ in \code{plot_dataname} to be used as y-axis.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} +\item{filter_event_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used to filter the data. +The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu.} + \item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate colors and symbols.} diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index fdea953fd..10182c11a 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -13,7 +13,7 @@ tm_g_swimlane( group_var, sort_var = NULL, point_colors = character(0), - point_symbols, + point_symbols = character(0), plot_height = 700, table_datanames = character(0), reactable_args = list() diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index 5ee97b703..9b9af3369 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -11,7 +11,7 @@ tm_g_waterfall( value_var, sort_var = NULL, color_var = NULL, - bar_colors = list(), + bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", plot_height = 700, From a065bf51c0127451d2924e22cf78dadb0116d48f Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 2 May 2025 19:17:45 +0530 Subject: [PATCH 081/158] docs: add examples --- R/tm_g_spiderplot.R | 59 ++++++++++++++++++++++++++++++++++++++++++ R/tm_g_swimlane.R | 46 ++++++++++++++++++++++++++++++++ R/tm_g_waterfall.R | 42 ++++++++++++++++++++++++++++++ man/tm_g_spiderplot.Rd | 59 ++++++++++++++++++++++++++++++++++++++++++ man/tm_g_swimlane.Rd | 46 ++++++++++++++++++++++++++++++++ man/tm_g_waterfall.Rd | 42 ++++++++++++++++++++++++++++++ 6 files changed, 294 insertions(+) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 292ee8f97..bea9da899 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -20,6 +20,65 @@ #' The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` #' column. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' subjects <- data.frame( +#' subject_var = c("A", "B", "C"), +#' AGE = sample(30:100, 3), +#' ARM = c("Combination", "Combination", "Placebo") +#' ) +#' +#' swimlane_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' time_var = sample(1:100, 10, replace = TRUE), +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) +#' ) +#' +#' spiderplot_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' time_var = 1:10, +#' filter_event_var = "response", +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), +#' value_var = sample(-50:100, 10, replace = TRUE) +#' ) +#' +#' waterfall_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' value_var = sample(-20:90, 10, replace = TRUE), +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) +#' ) +#' }) +#' join_keys(data) <- join_keys( +#' join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) +#' ) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_g_spiderplot( +#' plot_dataname = "spiderplot_ds", +#' table_datanames = "subjects", +#' time_var = "time_var", +#' value_var = "value_var", +#' subject_var = "subject_var", +#' filter_event_var = "filter_event_var", +#' color_var = "color_var", +#' point_colors = c( +#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' ), +#' point_symbols = c( +#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" +#' ) +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_g_spiderplot <- function(label = "Spiderplot", plot_dataname, diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 8523a989c..0d882c6db 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -21,6 +21,52 @@ #' by levels of `color_var` column. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` #' column. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' subjects <- data.frame( +#' subject_var = c("A", "B", "C"), +#' AGE = sample(30:100, 3), +#' ARM = c("Combination", "Combination", "Placebo") +#' ) +#' +#' swimlane_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' time_var = sample(1:100, 10, replace = TRUE), +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) +#' ) +#' }) +#' join_keys(data) <- join_keys( +#' join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) +#' ) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_g_swimlane( +#' plot_dataname = "swimlane_ds", +#' table_datanames = "subjects", +#' time_var = "time_var", +#' subject_var = "subject_var", +#' color_var = "color_var", +#' group_var = "color_var", +#' sort_var = "time_var", +#' plot_height = 400, +#' point_colors = c( +#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' ), +#' point_symbols = c( +#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" +#' ) +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_g_swimlane <- function(label = "Swimlane", plot_dataname, diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 71fceee17..052af041d 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -15,6 +15,48 @@ #' by levels of `color_var` column. #' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal #' lines on the plot. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' subjects <- data.frame( +#' subject_var = c("A", "B", "C"), +#' AGE = sample(30:100, 3), +#' ARM = c("Combination", "Combination", "Placebo") +#' ) +#' +#' waterfall_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' value_var = sample(-20:90, 10, replace = TRUE), +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) +#' ) +#' }) +#' join_keys(data) <- join_keys( +#' join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) +#' ) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_g_waterfall( +#' plot_dataname = "waterfall_ds", +#' table_datanames = "subjects", +#' subject_var = "subject_var", +#' value_var = "value_var", +#' sort_var = "value_var", +#' color_var = "color_var", +#' value_arbitrary_hlines = c(20, -30), +#' bar_colors = c( +#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' ) +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_g_waterfall <- function(label = "Waterfall", plot_dataname, diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index 2653b3ba3..366a54bf2 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -60,3 +60,62 @@ See section "Decorating Module" below for more details.} \description{ Module visualizes value development in time grouped by subjects. } +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + swimlane_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = sample(1:100, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + + spiderplot_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = 1:10, + filter_event_var = "response", + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), + value_var = sample(-50:100, 10, replace = TRUE) + ) + + waterfall_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + value_var = sample(-20:90, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_g_spiderplot( + plot_dataname = "spiderplot_ds", + table_datanames = "subjects", + time_var = "time_var", + value_var = "value_var", + subject_var = "subject_var", + filter_event_var = "filter_event_var", + color_var = "color_var", + point_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ), + point_symbols = c( + CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index 10182c11a..6ffe9dc82 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -60,3 +60,49 @@ See section "Decorating Module" below for more details.} \description{ Module visualizes subjects' events in time. } +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + swimlane_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = sample(1:100, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_g_swimlane( + plot_dataname = "swimlane_ds", + table_datanames = "subjects", + time_var = "time_var", + subject_var = "subject_var", + color_var = "color_var", + group_var = "color_var", + sort_var = "time_var", + plot_height = 400, + point_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ), + point_symbols = c( + CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index 9b9af3369..aa84a8fae 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -52,3 +52,45 @@ See section "Decorating Module" below for more details.} \description{ Module visualizes subjects sorted decreasingly by y-values. } +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + waterfall_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + value_var = sample(-20:90, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_g_waterfall( + plot_dataname = "waterfall_ds", + table_datanames = "subjects", + subject_var = "subject_var", + value_var = "value_var", + sort_var = "value_var", + color_var = "color_var", + value_arbitrary_hlines = c(20, -30), + bar_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} From 589afce7eea09601fc3fad9ce8e9b976cb5a24e8 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 5 May 2025 12:25:09 +0530 Subject: [PATCH 082/158] feat: allow the app developer to customize tooltips using column names --- R/tm_g_spiderplot.R | 42 +++++++++++++++++++++-------------- R/tm_g_swimlane.R | 53 +++++++++++++++++++++++++++------------------ R/tm_g_waterfall.R | 43 +++++++++++++++++++++--------------- R/utils.R | 20 +++++++++++++++++ 4 files changed, 104 insertions(+), 54 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index bea9da899..cca7d859d 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -92,6 +92,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", plot_height = 600, table_datanames = character(0), reactable_args = list(), + tooltip_cols = NULL, transformator = transformator) { if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) @@ -124,7 +125,8 @@ tm_g_spiderplot <- function(label = "Spiderplot", point_colors = point_colors, point_symbols = point_symbols, table_datanames = table_datanames, - reactable_args = reactable_args + reactable_args = reactable_args, + tooltip_cols = tooltip_cols ), datanames = union(plot_dataname, table_datanames) ) @@ -168,6 +170,7 @@ srv_g_spiderplot <- function(id, plot_height = 600, table_datanames = character(0), reactable_args = list(), + tooltip_cols = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) @@ -228,6 +231,7 @@ srv_g_spiderplot <- function(id, symbols = adjusted_symbols, height = input$plot_height, title = sprintf("%s over time", input$filter_event_var_level), + tooltip_cols = tooltip_cols, expr = { p <- dataname %>% dplyr::filter(filter_event_var_lang == selected_event) %>% @@ -239,7 +243,8 @@ srv_g_spiderplot <- function(id, color_var = color_var, colors = colors, symbols = symbols, - height = height + height = height, + tooltip_cols = tooltip_cols ) %>% plotly::layout(title = title) } @@ -270,13 +275,12 @@ srv_g_spiderplot <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export -spiderplotly <- function(data, time_var, value_var, subject_var, filter_event_var, color_var, colors, symbols, height) { - subject_var_label <- attr(data[[subject_var]], "label") - time_var_label <- attr(data[[time_var]], "label") - filter_event_var_label <- attr(data[[filter_event_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - if (!length(time_var_label)) time_var_label <- time_var - if (!length(filter_event_var_label)) filter_event_var_label <- filter_event_var +spiderplotly <- function( + data, time_var, value_var, subject_var, filter_event_var, + color_var, colors, symbols, height, tooltip_cols = NULL) { + subject_var_label <- .get_column_label(data, subject_var) + time_var_label <- .get_column_label(data, time_var) + value_var_label <- .get_column_label(data, value_var) data %>% dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% @@ -284,12 +288,18 @@ spiderplotly <- function(data, time_var, value_var, subject_var, filter_event_va dplyr::mutate( x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), - tooltip = sprintf( - "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var), - time_var_label, !!as.name(time_var), - filter_event_var_label, !!as.name(value_var) * 100 - ) + tooltip = { + if (is.null(tooltip_cols)) { + sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var), + time_var_label, !!as.name(time_var), + value_var_label, !!as.name(value_var) * 100 + ) + } else { + .generate_tooltip(.data, tooltip_cols) + } + } ) %>% dplyr::ungroup() %>% plotly::plot_ly( @@ -314,7 +324,7 @@ spiderplotly <- function(data, time_var, value_var, subject_var, filter_event_va ) %>% plotly::layout( xaxis = list(title = time_var_label), - yaxis = list(title = filter_event_var_label), + yaxis = list(title = value_var_label), title = title, dragmode = "select" ) %>% diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 0d882c6db..2b1d42ab5 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -79,7 +79,8 @@ tm_g_swimlane <- function(label = "Swimlane", point_symbols = character(0), plot_height = 700, table_datanames = character(0), - reactable_args = list()) { + reactable_args = list(), + tooltip_cols = NULL) { if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) } @@ -111,7 +112,8 @@ tm_g_swimlane <- function(label = "Swimlane", point_colors = point_colors, point_symbols = point_symbols, table_datanames = table_datanames, - reactable_args = reactable_args + reactable_args = reactable_args, + tooltip_cols = tooltip_cols ) ) } @@ -146,6 +148,7 @@ srv_g_swimlane <- function(id, point_symbols, table_datanames, reactable_args = list(), + tooltip_cols = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) @@ -180,6 +183,7 @@ srv_g_swimlane <- function(id, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, + tooltip_cols = tooltip_cols, expr = { p <- swimlanely( data = dataname, @@ -190,7 +194,8 @@ srv_g_swimlane <- function(id, sort_var = sort_var, colors = colors, symbols = symbols, - height = height + height = height, + tooltip_cols = tooltip_cols ) } ) @@ -224,11 +229,11 @@ srv_g_swimlane <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export -swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_var, colors, symbols, height) { - subject_var_label <- attr(data[[subject_var]], "label") - time_var_label <- attr(data[[time_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - if (!length(time_var_label)) time_var_label <- time_var +swimlanely <- function( + data, time_var, subject_var, color_var, group_var, + sort_var, colors, symbols, height, tooltip_cols = NULL) { + subject_var_label <- .get_column_label(data, subject_var) + time_var_label <- .get_column_label(data, time_var) # forcats::fct_reorder doesn't seem to work here subject_levels <- data %>% @@ -245,20 +250,26 @@ swimlanely <- function(data, time_var, subject_var, color_var, group_var, sort_v ) %>% dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( - tooltip = paste( - unique( - c( - paste(subject_var_label, !!as.name(subject_var)), - paste(time_var_label, !!as.name(time_var)), - sprintf( - "%s: %s", - tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), - !!as.name(color_var) - ) + tooltip = { + if (is.null(tooltip_cols)) { + paste( + unique( + c( + paste(subject_var_label, !!as.name(subject_var)), + paste(time_var_label, !!as.name(time_var)), + sprintf( + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), + !!as.name(color_var) + ) + ) + ), + collapse = "
" ) - ), - collapse = "
" - ) + } else { + .generate_tooltip(.data, tooltip_cols) + } + } ) %>% plotly::plot_ly( source = "swimlane", diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index 052af041d..c4e24e87a 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -69,7 +69,8 @@ tm_g_waterfall <- function(label = "Waterfall", plot_title = "Waterfall plot", plot_height = 700, table_datanames = character(0), - reactable_args = list()) { + reactable_args = list(), + tooltip_cols = NULL) { if (is.character(subject_var)) { subject_var <- choices_selected(choices = subject_var, selected = subject_var) } @@ -99,7 +100,8 @@ tm_g_waterfall <- function(label = "Waterfall", bar_colors = bar_colors, value_arbitrary_hlines = value_arbitrary_hlines, plot_title = plot_title, - reactable_args = reactable_args + reactable_args = reactable_args, + tooltip_cols = tooltip_cols ) ) } @@ -143,6 +145,7 @@ srv_g_waterfall <- function(id, plot_height = 600, table_datanames = character(0), reactable_args = list(), + tooltip_cols = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) @@ -173,6 +176,7 @@ srv_g_waterfall <- function(id, value_arbitrary_hlines = value_arbitrary_hlines, height = input$plot_height, title = sprintf("Waterfall plot"), + tooltip_cols = tooltip_cols, expr = { p <- waterfally( dataname, @@ -182,7 +186,8 @@ srv_g_waterfall <- function(id, color_var = color_var, colors = colors, value_arbitrary_hlines = value_arbitrary_hlines, - height = height + height = height, + tooltip_cols = tooltip_cols ) %>% plotly::layout(title = title) }, @@ -215,14 +220,12 @@ srv_g_waterfall <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export -waterfally <- function(data, subject_var, value_var, sort_var, color_var, colors, value_arbitrary_hlines, height) { - subject_var_label <- attr(data[[subject_var]], "label") - value_var_label <- attr(data[[value_var]], "label") - color_var_label <- attr(data[[color_var]], "label") - - if (!length(subject_var_label)) subject_var_label <- subject_var - if (!length(value_var_label)) value_var_label <- value_var - if (!length(color_var_label)) color_var_label <- color_var +waterfally <- function( + data, subject_var, value_var, sort_var, color_var, colors, + value_arbitrary_hlines, height, tooltip_cols = NULL) { + subject_var_label <- .get_column_label(data, subject_var) + value_var_label <- .get_column_label(data, value_var) + color_var_label <- .get_column_label(data, color_var) dplyr::mutate( if (identical(sort_var, value_var) || is.null(sort_var)) { @@ -231,12 +234,18 @@ waterfally <- function(data, subject_var, value_var, sort_var, color_var, colors dplyr::arrange(data, !!as.name(sort_var), desc(!!as.name(value_var))) }, !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), - tooltip = sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), - value_var_label, !!as.name(value_var), - color_var_label, !!as.name(color_var) - ) + tooltip = { + if (is.null(tooltip_cols)) { + sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), + value_var_label, !!as.name(value_var), + color_var_label, !!as.name(color_var) + ) + } else { + .generate_tooltip(.data, tooltip_cols) + } + } ) %>% dplyr::filter(!duplicated(!!as.name(subject_var))) %>% plotly::plot_ly( diff --git a/R/utils.R b/R/utils.R index 17095fee0..80b60b975 100644 --- a/R/utils.R +++ b/R/utils.R @@ -456,3 +456,23 @@ children <- function(x, dataset_name = character(0)) { updateSelectInput(inputId = inputId, choices = cs$choices, selected = cs$selected) if (length(cs$choices) < 2) shinyjs::hide(inputId) } + +.get_column_label <- function(data, column) { + column_label <- attr(data[[column]], "label") + if (!length(column_label)) column_label <- column + column_label +} + + +.generate_tooltip <- function(data, tooltip_cols) { + tooltip_lines <- sapply(tooltip_cols, function(col) { + label <- .get_column_label(data, col) + value <- data[[col]] + paste0(label, ": ", value) + }) + if (is.vector(tooltip_lines)) { + paste(tooltip_lines, collapse = "
") + } else { + apply(tooltip_lines, 1, function(row) paste(row, collapse = "
")) + } +} From 4dd1b595f9b43e2523852b3bb1019f359d49af80 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 7 May 2025 14:40:00 +0530 Subject: [PATCH 083/158] feat: allow custome siize based on a column + expand cards --- R/tm_g_spiderplot.R | 23 ++++++++++++++++++++--- R/tm_g_swimlane.R | 25 +++++++++++++++++++++---- R/tm_g_waterfall.R | 9 +++++++-- R/tm_t_reactable.R | 12 +++++++++--- inst/css/reactable.css | 7 +++++++ 5 files changed, 64 insertions(+), 12 deletions(-) create mode 100644 inst/css/reactable.css diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index cca7d859d..8a13d263c 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -87,6 +87,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", subject_var, filter_event_var, color_var, + size_var = NULL, point_colors = character(0), point_symbols = character(0), plot_height = 600, @@ -122,6 +123,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", subject_var = subject_var, filter_event_var = filter_event_var, color_var = color_var, + size_var = size_var, point_colors = point_colors, point_symbols = point_symbols, table_datanames = table_datanames, @@ -150,8 +152,13 @@ ui_g_spiderplot <- function(id, height) { colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - bslib::page_fillable( - plotly::plotlyOutput(ns("plot"), height = "100%"), + tags$div( + bslib::card( + full_screen = TRUE, + tags$div( + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ), ui_t_reactables(ns("subtables")) ) ) @@ -167,6 +174,7 @@ srv_g_spiderplot <- function(id, color_var, point_colors, point_symbols, + size_var = NULL, plot_height = 600, table_datanames = character(0), reactable_args = list(), @@ -229,6 +237,7 @@ srv_g_spiderplot <- function(id, color_var = input$color_var, colors = color_inputs(), symbols = adjusted_symbols, + size_var = size_var, height = input$plot_height, title = sprintf("%s over time", input$filter_event_var_level), tooltip_cols = tooltip_cols, @@ -243,6 +252,7 @@ srv_g_spiderplot <- function(id, color_var = color_var, colors = colors, symbols = symbols, + size_var = size_var, height = height, tooltip_cols = tooltip_cols ) %>% @@ -277,11 +287,17 @@ srv_g_spiderplot <- function(id, #' @export spiderplotly <- function( data, time_var, value_var, subject_var, filter_event_var, - color_var, colors, symbols, height, tooltip_cols = NULL) { + color_var, colors, symbols, height, tooltip_cols = NULL, size_var = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) value_var_label <- .get_column_label(data, value_var) + if (is.null(size_var)) { + size <- point_size + } else { + size <- stats::as.formula(sprintf("~%s", size_var)) + } + data %>% dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::group_by(!!as.name(subject_var)) %>% @@ -319,6 +335,7 @@ spiderplotly <- function( x = stats::as.formula(sprintf("~%s", time_var)), y = stats::as.formula(sprintf("~%s", value_var)), symbol = stats::as.formula(sprintf("~%s", color_var)), + size = size, text = ~tooltip, hoverinfo = "text" ) %>% diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 2b1d42ab5..6e36a9814 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -74,6 +74,7 @@ tm_g_swimlane <- function(label = "Swimlane", subject_var, color_var, group_var, + size_var = NULL, sort_var = NULL, point_colors = character(0), point_symbols = character(0), @@ -109,6 +110,7 @@ tm_g_swimlane <- function(label = "Swimlane", color_var = color_var, group_var = group_var, sort_var = sort_var, + size_var = size_var, point_colors = point_colors, point_symbols = point_symbols, table_datanames = table_datanames, @@ -130,8 +132,13 @@ ui_g_swimlane <- function(id, height) { colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - bslib::page_fillable( - plotly::plotlyOutput(ns("plot"), height = "100%"), + tags$div( + bslib::card( + full_screen = TRUE, + tags$div( + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ), ui_t_reactables(ns("subtables")) ) ) @@ -144,6 +151,7 @@ srv_g_swimlane <- function(id, color_var, group_var, sort_var = time_var, + size_var = NULL, point_colors, point_symbols, table_datanames, @@ -180,6 +188,7 @@ srv_g_swimlane <- function(id, color_var = input$color_var, group_var = input$group_var, sort_var = input$sort_var, + size_var = size_var, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, @@ -192,6 +201,7 @@ srv_g_swimlane <- function(id, color_var = color_var, group_var = group_var, sort_var = sort_var, + size_var = size_var, colors = colors, symbols = symbols, height = height, @@ -230,11 +240,17 @@ srv_g_swimlane <- function(id, # todo: export is temporary, this should go to a new package teal.graphs or another bird species #' @export swimlanely <- function( - data, time_var, subject_var, color_var, group_var, - sort_var, colors, symbols, height, tooltip_cols = NULL) { + data, time_var, subject_var, color_var, group_var, sort_var, + colors, symbols, height, tooltip_cols = NULL, size_var = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) + if (is.null(size_var)) { + size <- point_size + } else { + size <- stats::as.formula(sprintf("~%s", size_var)) + } + # forcats::fct_reorder doesn't seem to work here subject_levels <- data %>% dplyr::group_by(!!as.name(subject_var)) %>% @@ -282,6 +298,7 @@ swimlanely <- function( y = stats::as.formula(sprintf("~%s", subject_var)), color = stats::as.formula(sprintf("~%s", color_var)), symbol = stats::as.formula(sprintf("~%s", color_var)), + size = size, text = ~tooltip, hoverinfo = "text" ) %>% diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index c4e24e87a..f1849637a 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -126,8 +126,13 @@ ui_g_waterfall <- function(id, height) { colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) ), - bslib::page_fillable( - plotly::plotlyOutput(ns("plot"), height = "100%"), + tags$div( + bslib::card( + full_screen = TRUE, + tags$div( + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ), ui_t_reactables(ns("subtables")) ) ) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 07e0950a7..a55ae6d0f 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -63,10 +63,11 @@ srv_t_reactables <- function( return(NULL) } div( + include_css_files("reactable.css"), do.call( bslib::accordion, c( - list(id = session$ns("reactables")), + list(id = session$ns("reactables"), class = "teal-modules-general reactable-accordion"), lapply( datanames_r(), function(dataname) { @@ -115,7 +116,8 @@ ui_t_reactable <- function(id) { actionsBox = TRUE, `show-subtext` = TRUE, countSelectedText = TRUE, - liveSearch = TRUE + liveSearch = TRUE, + container = "body" ) ) @@ -123,7 +125,11 @@ ui_t_reactable <- function(id) { # bslib::popover(input) bslib::page_fluid( input, - reactable::reactableOutput(ns("table")) + bslib::card( + class = "teal-modules-general reactable-card", + full_screen = TRUE, + reactable::reactableOutput(ns("table")) + ) ) } diff --git a/inst/css/reactable.css b/inst/css/reactable.css new file mode 100644 index 000000000..1b0c523aa --- /dev/null +++ b/inst/css/reactable.css @@ -0,0 +1,7 @@ +.teal-modules-general.reactable-accordion .accordion-body { + padding: 0; +} + +.teal-modules-general.reactable-card { + margin-bottom: 0; +} From ce441c3655484bed222bb5b0f6d4f49893a5183a Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 7 May 2025 15:59:39 +0530 Subject: [PATCH 084/158] docs: update roxygen docs for new params --- R/tm_g_spiderplot.R | 38 +++++++++++++++++++++----------------- R/tm_g_swimlane.R | 41 +++++++++++++++++++++++++++-------------- R/tm_g_waterfall.R | 29 +++++++++++++++++------------ man/tm_g_spiderplot.Rd | 30 +++++++++++++++++------------- man/tm_g_swimlane.Rd | 24 ++++++++++++++++-------- man/tm_g_waterfall.Rd | 16 ++++++++++------ 6 files changed, 108 insertions(+), 70 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 8a13d263c..1410951c9 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -13,13 +13,18 @@ #' in `plot_dataname` to be used as grouping variable for displayed lines/points. #' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate colors and symbols. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named -#' by levels of `color_var` column. #' @param filter_event_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column #' in `plot_dataname` to be used to filter the data. #' The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` -#' column. +#' @param size_var (`character(1)` or `NULL`) If provided, this numeric column from the `plot_dataname` +#' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created. +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' by levels of `color_var` column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var`column. +#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. +#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples #' data <- teal_data() |> @@ -85,16 +90,15 @@ tm_g_spiderplot <- function(label = "Spiderplot", time_var, value_var, subject_var, - filter_event_var, color_var, + filter_event_var, size_var = NULL, + tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = 600, + plot_height = c(600, 400, 1200), table_datanames = character(0), - reactable_args = list(), - tooltip_cols = NULL, - transformator = transformator) { + reactable_args = list()) { if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) } @@ -128,7 +132,7 @@ tm_g_spiderplot <- function(label = "Spiderplot", point_symbols = point_symbols, table_datanames = table_datanames, reactable_args = reactable_args, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ), datanames = union(plot_dataname, table_datanames) ) @@ -150,7 +154,7 @@ ui_g_spiderplot <- function(id, height) { selectInput(ns("filter_event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("filter_event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), tags$div( bslib::card( @@ -178,7 +182,7 @@ srv_g_spiderplot <- function(id, plot_height = 600, table_datanames = character(0), reactable_args = list(), - tooltip_cols = NULL, + tooltip_vars = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) @@ -240,7 +244,7 @@ srv_g_spiderplot <- function(id, size_var = size_var, height = input$plot_height, title = sprintf("%s over time", input$filter_event_var_level), - tooltip_cols = tooltip_cols, + tooltip_vars = tooltip_vars, expr = { p <- dataname %>% dplyr::filter(filter_event_var_lang == selected_event) %>% @@ -254,7 +258,7 @@ srv_g_spiderplot <- function(id, symbols = symbols, size_var = size_var, height = height, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ) %>% plotly::layout(title = title) } @@ -287,7 +291,7 @@ srv_g_spiderplot <- function(id, #' @export spiderplotly <- function( data, time_var, value_var, subject_var, filter_event_var, - color_var, colors, symbols, height, tooltip_cols = NULL, size_var = NULL, point_size = 10) { + color_var, colors, symbols, height, tooltip_vars = NULL, size_var = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) value_var_label <- .get_column_label(data, value_var) @@ -305,7 +309,7 @@ spiderplotly <- function( x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), tooltip = { - if (is.null(tooltip_cols)) { + if (is.null(tooltip_vars)) { sprintf( "%s: %s
%s: %s
%s: %s%%
", subject_var_label, !!as.name(subject_var), @@ -313,7 +317,7 @@ spiderplotly <- function( value_var_label, !!as.name(value_var) * 100 ) } else { - .generate_tooltip(.data, tooltip_cols) + .generate_tooltip(.data, tooltip_vars) } } ) %>% diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 6e36a9814..c4c573a09 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -17,10 +17,16 @@ #' todo: this can be fixed by ordering factor levels #' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which #' value determines order of the subjects displayed on the y-axis. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created. +#' @param size_var (`character(1)` or `NULL`) If provided, this numeric column from the `plot_dataname` +#' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. +#' @param point_size (`numeric(1)`) Default point size of the points in the plot. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` -#' column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. +#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. +#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples #' data <- teal_data() |> @@ -74,14 +80,17 @@ tm_g_swimlane <- function(label = "Swimlane", subject_var, color_var, group_var, - size_var = NULL, sort_var = NULL, + tooltip_vars = NULL, + size_var = NULL, + point_size = 10, point_colors = character(0), point_symbols = character(0), - plot_height = 700, + plot_height = c(700, 400, 1200), table_datanames = character(0), - reactable_args = list(), - tooltip_cols = NULL) { + reactable_args = list()) { + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) } @@ -111,11 +120,12 @@ tm_g_swimlane <- function(label = "Swimlane", group_var = group_var, sort_var = sort_var, size_var = size_var, + point_size = point_size, point_colors = point_colors, point_symbols = point_symbols, table_datanames = table_datanames, reactable_args = reactable_args, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ) ) } @@ -130,7 +140,7 @@ ui_g_swimlane <- function(id, height) { selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), tags$div( bslib::card( @@ -152,11 +162,12 @@ srv_g_swimlane <- function(id, group_var, sort_var = time_var, size_var = NULL, + point_size = 10, point_colors, point_symbols, table_datanames, reactable_args = list(), - tooltip_cols = NULL, + tooltip_vars = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) @@ -189,10 +200,11 @@ srv_g_swimlane <- function(id, group_var = input$group_var, sort_var = input$sort_var, size_var = size_var, + point_size = point_size, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - tooltip_cols = tooltip_cols, + tooltip_vars = tooltip_vars, expr = { p <- swimlanely( data = dataname, @@ -202,10 +214,11 @@ srv_g_swimlane <- function(id, group_var = group_var, sort_var = sort_var, size_var = size_var, + point_size = point_size, colors = colors, symbols = symbols, height = height, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ) } ) @@ -241,7 +254,7 @@ srv_g_swimlane <- function(id, #' @export swimlanely <- function( data, time_var, subject_var, color_var, group_var, sort_var, - colors, symbols, height, tooltip_cols = NULL, size_var = NULL, point_size = 10) { + colors, symbols, height, tooltip_vars = NULL, size_var = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) @@ -267,7 +280,7 @@ swimlanely <- function( dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( tooltip = { - if (is.null(tooltip_cols)) { + if (is.null(tooltip_vars)) { paste( unique( c( @@ -283,7 +296,7 @@ swimlanely <- function( collapse = "
" ) } else { - .generate_tooltip(.data, tooltip_cols) + .generate_tooltip(.data, tooltip_vars) } } ) %>% diff --git a/R/tm_g_waterfall.R b/R/tm_g_waterfall.R index f1849637a..da71cb2e9 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_g_waterfall.R @@ -11,10 +11,15 @@ #' in `plot_dataname` to be used as y-axis. #' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate bar colors. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created. #' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. #' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal #' lines on the plot. +#' @param plot_title (`character`) Title of the plot. +#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. +#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples #' data <- teal_data() |> @@ -64,13 +69,13 @@ tm_g_waterfall <- function(label = "Waterfall", value_var, sort_var = NULL, color_var = NULL, + tooltip_vars = NULL, bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = 700, + plot_height = c(600, 400, 1200), table_datanames = character(0), - reactable_args = list(), - tooltip_cols = NULL) { + reactable_args = list()) { if (is.character(subject_var)) { subject_var <- choices_selected(choices = subject_var, selected = subject_var) } @@ -101,7 +106,7 @@ tm_g_waterfall <- function(label = "Waterfall", value_arbitrary_hlines = value_arbitrary_hlines, plot_title = plot_title, reactable_args = reactable_args, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ) ) } @@ -124,7 +129,7 @@ ui_g_waterfall <- function(id, height) { selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height) + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), tags$div( bslib::card( @@ -147,10 +152,10 @@ srv_g_waterfall <- function(id, bar_colors, value_arbitrary_hlines, plot_title, - plot_height = 600, + plot_height = c(600, 400, 1200), table_datanames = character(0), reactable_args = list(), - tooltip_cols = NULL, + tooltip_vars = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) @@ -181,7 +186,7 @@ srv_g_waterfall <- function(id, value_arbitrary_hlines = value_arbitrary_hlines, height = input$plot_height, title = sprintf("Waterfall plot"), - tooltip_cols = tooltip_cols, + tooltip_vars = tooltip_vars, expr = { p <- waterfally( dataname, @@ -192,7 +197,7 @@ srv_g_waterfall <- function(id, colors = colors, value_arbitrary_hlines = value_arbitrary_hlines, height = height, - tooltip_cols = tooltip_cols + tooltip_vars = tooltip_vars ) %>% plotly::layout(title = title) }, @@ -227,7 +232,7 @@ srv_g_waterfall <- function(id, #' @export waterfally <- function( data, subject_var, value_var, sort_var, color_var, colors, - value_arbitrary_hlines, height, tooltip_cols = NULL) { + value_arbitrary_hlines, height, tooltip_vars = NULL) { subject_var_label <- .get_column_label(data, subject_var) value_var_label <- .get_column_label(data, value_var) color_var_label <- .get_column_label(data, color_var) @@ -240,7 +245,7 @@ waterfally <- function( }, !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), tooltip = { - if (is.null(tooltip_cols)) { + if (is.null(tooltip_vars)) { sprintf( "%s: %s
%s: %s%%
%s: %s", subject_var_label, !!as.name(subject_var), @@ -248,7 +253,7 @@ waterfally <- function( color_var_label, !!as.name(color_var) ) } else { - .generate_tooltip(.data, tooltip_cols) + .generate_tooltip(.data, tooltip_vars) } } ) %>% diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd index 366a54bf2..bd45f3360 100644 --- a/man/tm_g_spiderplot.Rd +++ b/man/tm_g_spiderplot.Rd @@ -10,14 +10,15 @@ tm_g_spiderplot( time_var, value_var, subject_var, - filter_event_var, color_var, + filter_event_var, + size_var = NULL, + tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = 600, + plot_height = c(600, 400, 1200), table_datanames = character(0), - reactable_args = list(), - transformator = transformator + reactable_args = list() ) } \arguments{ @@ -35,27 +36,30 @@ in \code{plot_dataname} to be used as y-axis.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used to differentiate colors and symbols.} + \item{filter_event_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to filter the data. The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu.} -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used to differentiate colors and symbols.} +\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} +will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} \item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by levels of \code{color_var} column.} -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} -column.} +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var}column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot -when some data points are selected. Objects named after \code{table_datanames} will be pulled from -\code{data} so it is important that data actually contains these datasets. Please be aware that -table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. -See section "Decorating Module" below for more details.} +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} } \description{ Module visualizes value development in time grouped by subjects. diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index 6ffe9dc82..daf534c55 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -12,9 +12,12 @@ tm_g_swimlane( color_var, group_var, sort_var = NULL, + tooltip_vars = NULL, + size_var = NULL, + point_size = 10, point_colors = character(0), point_symbols = character(0), - plot_height = 700, + plot_height = c(700, 400, 1200), table_datanames = character(0), reactable_args = list() ) @@ -42,20 +45,25 @@ todo: this can be fixed by ordering factor levels} \item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which value determines order of the subjects displayed on the y-axis.} +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + +\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} +will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} + +\item{point_size}{(\code{numeric(1)}) Default point size of the points in the plot.} + \item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by levels of \code{color_var} column.} -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} -column.} +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot -when some data points are selected. Objects named after \code{table_datanames} will be pulled from -\code{data} so it is important that data actually contains these datasets. Please be aware that -table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. -See section "Decorating Module" below for more details.} +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} } \description{ Module visualizes subjects' events in time. diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd index aa84a8fae..4afb01ecd 100644 --- a/man/tm_g_waterfall.Rd +++ b/man/tm_g_waterfall.Rd @@ -11,10 +11,11 @@ tm_g_waterfall( value_var, sort_var = NULL, color_var = NULL, + tooltip_vars = NULL, bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = 700, + plot_height = c(600, 400, 1200), table_datanames = character(0), reactable_args = list() ) @@ -34,20 +35,23 @@ in \code{plot_dataname} to be used as y-axis.} \item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate bar colors.} +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + \item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by levels of \code{color_var} column.} \item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal lines on the plot.} +\item{plot_title}{(\code{character}) Title of the plot.} + \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot -when some data points are selected. Objects named after \code{table_datanames} will be pulled from -\code{data} so it is important that data actually contains these datasets. Please be aware that -table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. -See section "Decorating Module" below for more details.} +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} } \description{ Module visualizes subjects sorted decreasingly by y-values. From a840f295a0489881f1659afa8292daac75236feb Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 9 May 2025 16:37:23 +0530 Subject: [PATCH 085/158] feat: add the show selected tooltips module --- R/tm_g_spiderplot.R | 3 +++ R/tm_g_swimlane.R | 3 +++ R/utils.R | 50 ++++++++++++++++++++++++++++++++++++++ inst/js/triggerTooltips.js | 8 ++++++ 4 files changed, 64 insertions(+) create mode 100644 inst/js/triggerTooltips.js diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 1410951c9..f918efd84 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -160,6 +160,7 @@ ui_g_spiderplot <- function(id, height) { bslib::card( full_screen = TRUE, tags$div( + ui_trigger_tooltips(ns("show_tooltips")), plotly::plotlyOutput(ns("plot"), height = "100%") ) ), @@ -269,6 +270,8 @@ srv_g_spiderplot <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) + srv_trigger_tooltips("show_tooltips", plotly_selected, session$ns("plot")) + tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index c4c573a09..a2e65d9d1 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -146,6 +146,7 @@ ui_g_swimlane <- function(id, height) { bslib::card( full_screen = TRUE, tags$div( + ui_trigger_tooltips(ns("show_tooltips")), plotly::plotlyOutput(ns("plot"), height = "100%") ) ), @@ -231,6 +232,8 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) + srv_trigger_tooltips("show_tooltips", plotly_selected, session$ns("plot")) + tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, diff --git a/R/utils.R b/R/utils.R index 80b60b975..f467b19c5 100644 --- a/R/utils.R +++ b/R/utils.R @@ -476,3 +476,53 @@ children <- function(x, dataset_name = character(0)) { apply(tooltip_lines, 1, function(row) paste(row, collapse = "
")) } } + + +#' @keywords internal +#' @noRd +trigger_tooltips_deps <- function() { + htmltools::htmlDependency( + name = "teal-modules-general-trigger-tooltips", + version = utils::packageVersion("teal.modules.general"), + package = "teal.modules.general", + src = "js", + script = "triggerTooltips.js" + ) +} + +#' @keywords internal +#' @noRd +ui_trigger_tooltips <- function(id) { + ns <- NS(id) + tags$div( + trigger_tooltips_deps(), + actionButton(ns("show_tooltips"), "Show Selected Tooltips") + ) +} + +#' @keywords internal +#' @noRd +srv_trigger_tooltips <- function(id, plotly_selected, plot_id) { + moduleServer(id, function(input, output, session) { + observeEvent(input$show_tooltips, { + sel <- plotly_selected() + + if (!is.null(sel) && nrow(sel) > 0) { + tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { + list( + curve = sel$curveNumber[i], + index = sel$pointNumber[i] + ) + }) + + session$sendCustomMessage( + "triggerTooltips", + list( + plotID = plot_id, + tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) + ) + ) + } + }) + }) +} diff --git a/inst/js/triggerTooltips.js b/inst/js/triggerTooltips.js new file mode 100644 index 000000000..bd1072f89 --- /dev/null +++ b/inst/js/triggerTooltips.js @@ -0,0 +1,8 @@ +Shiny.addCustomMessageHandler("triggerTooltips", function (message) { + const plotDiv = document.getElementById(message.plotID); + const hoverPoints = message.tooltipPoints.map((point) => ({ + curveNumber: point.curve || 0, + pointNumber: point.index, + })); + Plotly.Fx.hover(plotDiv, hoverPoints); +}); From 68d212f5f6f65700a4c33976ce45a6db763af052 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 14 May 2025 12:21:18 +0530 Subject: [PATCH 086/158] feat: improve the trigger tooltips --- R/tm_g_spiderplot.R | 31 +++++- R/tm_g_swimlane.R | 87 ++++++++++++++-- R/utils.R | 98 +++++++++++++------ inst/triggerTooltips/triggerTooltips.css | 46 +++++++++ .../triggerTooltips.js | 0 5 files changed, 223 insertions(+), 39 deletions(-) create mode 100644 inst/triggerTooltips/triggerTooltips.css rename inst/{js => triggerTooltips}/triggerTooltips.js (100%) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index f918efd84..8ea43f8bc 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -160,7 +160,7 @@ ui_g_spiderplot <- function(id, height) { bslib::card( full_screen = TRUE, tags$div( - ui_trigger_tooltips(ns("show_tooltips")), + trigger_tooltips_deps(), plotly::plotlyOutput(ns("plot"), height = "100%") ) ), @@ -266,11 +266,36 @@ srv_g_spiderplot <- function(id, ) }) - output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + output$plot <- output$plot <- plotly::renderPlotly(plotly::event_register( + { + plotly_q()$p |> + setup_trigger_tooltips(session$ns, input) + }, + "plotly_selected" + )) plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - srv_trigger_tooltips("show_tooltips", plotly_selected, session$ns("plot")) + observeEvent(input$show_tooltips, { + sel <- plotly_selected() + + if (!is.null(sel) && nrow(sel) > 0) { + tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { + list( + curve = sel$curveNumber[i], + index = sel$pointNumber[i] + ) + }) + + session$sendCustomMessage( + "triggerTooltips", + list( + plotID = session$ns("plot"), + tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) + ) + ) + } + }) tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index a2e65d9d1..f77fc73e5 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -140,13 +140,15 @@ ui_g_swimlane <- function(id, height) { selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]), + selectInput(ns("subjects"), "Subjects", choices = NULL, selected = NULL, multiple = TRUE), + actionButton(ns("subject_tooltips"), "Show Subject Tooltips") ), tags$div( bslib::card( full_screen = TRUE, tags$div( - ui_trigger_tooltips(ns("show_tooltips")), + trigger_tooltips_deps(), plotly::plotlyOutput(ns("plot"), height = "100%") ) ), @@ -188,6 +190,7 @@ srv_g_swimlane <- function(id, plotly_q <- reactive({ req(data(), input$time_var, input$subject_var, input$color_var, input$group_var, input$sort_var, color_inputs()) + print(input$subject_var) adjusted_symbols <- .shape_palette_discrete( levels = unique(data()[[plot_dataname]][[input$color_var]]), symbol = point_symbols @@ -225,14 +228,69 @@ srv_g_swimlane <- function(id, ) }) - output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + output$plot <- plotly::renderPlotly(plotly::event_register( + { + plotly_q()$p |> + set_plot_data(session$ns("plot_data")) |> + setup_trigger_tooltips(session$ns) + }, + "plotly_selected" + )) + + plotly_data <- reactive({ + data.frame( + x = unlist(input$plot_data$x), + y = unlist(input$plot_data$y), + customdata = unlist(input$plot_data$customdata), + curve = unlist(input$plot_data$curveNumber), + index = unlist(input$plot_data$pointNumber) + ) + }) plotly_selected <- reactive({ plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work plotly::event_data("plotly_selected", source = "swimlane") }) - srv_trigger_tooltips("show_tooltips", plotly_selected, session$ns("plot")) + observeEvent(input$show_tooltips, { + sel <- plotly_selected() + + if (!is.null(sel) && nrow(sel) > 0) { + tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { + list( + curve = sel$curveNumber[i], + index = sel$pointNumber[i] + ) + }) + + session$sendCustomMessage( + "triggerTooltips", + list( + plotID = session$ns("plot"), + tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) + ) + ) + } + }) + + observeEvent(input$subject_tooltips, { + hovervalues <- data()[[plot_dataname]] |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::filter(!!rlang::sym(input$subject_var) %in% input$subjects) |> + dplyr::pull(customdata) + + + hovertips <- plotly_data() |> + dplyr::filter(customdata %in% hovervalues) + + session$sendCustomMessage( + "triggerTooltips", + list( + plotID = session$ns("plot"), + tooltipPoints = jsonlite::toJSON(hovertips) + ) + ) + }) tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, @@ -243,6 +301,19 @@ srv_g_swimlane <- function(id, children_datanames = table_datanames ) + + observeEvent(data(), { + if (class(subject_var) == "choices_selected") { + subject_col <- subject_var$selected + } else { + subject_col <- subject_var + } + updateSelectInput( + inputId = "subjects", + choices = data()[[plot_dataname]][[subject_col]] + ) + }) + srv_t_reactables( "subtables", data = tables_selected_q, @@ -260,6 +331,8 @@ swimlanely <- function( colors, symbols, height, tooltip_vars = NULL, size_var = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) + data <- data |> + dplyr::mutate(customdata = dplyr::row_number()) if (is.null(size_var)) { size <- point_size @@ -307,7 +380,8 @@ swimlanely <- function( source = "swimlane", colors = colors, symbols = symbols, - height = height + height = height, + customdata = ~customdata ) %>% plotly::add_markers( x = stats::as.formula(sprintf("~%s", time_var)), @@ -327,7 +401,8 @@ swimlanely <- function( dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> dplyr::summarise(study_day = max(!!as.name(time_var))), line = list(width = 2, color = "grey"), - showlegend = FALSE + showlegend = FALSE, + customdata = NULL ) %>% plotly::layout( xaxis = list(title = time_var_label), diff --git a/R/utils.R b/R/utils.R index f467b19c5..a0e8a79c7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -485,44 +485,82 @@ trigger_tooltips_deps <- function() { name = "teal-modules-general-trigger-tooltips", version = utils::packageVersion("teal.modules.general"), package = "teal.modules.general", - src = "js", - script = "triggerTooltips.js" + src = "triggerTooltips", + script = "triggerTooltips.js", + stylesheet = "triggerTooltips.css" ) } + #' @keywords internal #' @noRd -ui_trigger_tooltips <- function(id) { - ns <- NS(id) - tags$div( - trigger_tooltips_deps(), - actionButton(ns("show_tooltips"), "Show Selected Tooltips") +setup_trigger_tooltips <- function(plot, ns) { + htmlwidgets::onRender( + plot, + paste0( + "function(el) { + const targetDiv = document.querySelector('#", ns("plot"), " .modebar-group:nth-child(4)'); + console.log(el.data); + if (targetDiv) { + const button = document.createElement('button'); + button.setAttribute('data-count', '0'); + button.className = 'teal-modules-general trigger-tooltips-button'; + + button.onclick = function () { + const current = parseInt(this.getAttribute('data-count')); + const next = current + 1; + this.setAttribute('data-count', next); + console.log('Button clicked ' + next + ' times'); + Shiny.setInputValue('", ns("show_tooltips"), "', next); + }; + + const icon = document.createElement('i'); + icon.className = 'fas fa-message'; + icon.setAttribute('role', 'presentation'); + icon.setAttribute('aria-label', 'info icon'); + + const tooltip = document.createElement('span'); + tooltip.className = 'plotly-icon-tooltip'; + tooltip.textContent = 'Hover selection'; + + button.appendChild(icon); + button.appendChild(tooltip); + targetDiv.appendChild(button); + } + }" + ) ) } #' @keywords internal #' @noRd -srv_trigger_tooltips <- function(id, plotly_selected, plot_id) { - moduleServer(id, function(input, output, session) { - observeEvent(input$show_tooltips, { - sel <- plotly_selected() - - if (!is.null(sel) && nrow(sel) > 0) { - tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { - list( - curve = sel$curveNumber[i], - index = sel$pointNumber[i] - ) - }) - - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = plot_id, - tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) - ) - ) - } - }) - }) +set_plot_data <- function(plot, data_id) { + htmlwidgets::onRender( + plot, + paste0( + " + function(el) { + slicedData = el.data.slice(0, -1).map(({ x, y, customdata }) => ({ x, y, customdata })); + plotData = { + x: [], + y: [], + customdata: [], + curveNumber: [], + pointNumber: [] + }; + + slicedData.forEach((item, curveNumber) => { + for (let i = 0; i < item.x.length; i++) { + plotData.pointNumber.push(i); + plotData.x.push(item.x[i]); + plotData.y.push(item.y[i]); + plotData.customdata.push(item.customdata[i]); + plotData.curveNumber.push(curveNumber); + } + }); + Shiny.setInputValue('", data_id, "', plotData); + } + " + ) + ) } diff --git a/inst/triggerTooltips/triggerTooltips.css b/inst/triggerTooltips/triggerTooltips.css new file mode 100644 index 000000000..ef23f1b5b --- /dev/null +++ b/inst/triggerTooltips/triggerTooltips.css @@ -0,0 +1,46 @@ +.teal-modules-general.trigger-tooltips-button { + border: none; + background: white; + opacity: 0.2; +} + +.teal-modules-general.trigger-tooltips-button:hover { + opacity: 0.6; +} + +.teal-modules-general.trigger-tooltips-button i { + font-size: 0.85em; +} + +.teal-modules-general.trigger-tooltips-button { + position: relative; +} + +.teal-modules-general.trigger-tooltips-button > .plotly-icon-tooltip { + visibility: hidden; + position: absolute; + top: 125%; + right: 0; + transform: translateX(0); + background-color: #121f3d; + color: #fff; + padding: 6px 10px; + border-radius: 3px; + z-index: 1000; + font-size: 12px; +} + +.teal-modules-general.trigger-tooltips-button > .plotly-icon-tooltip::after { + content: ""; + position: absolute; + bottom: 100%; + right: 10px; + border-width: 5px; + border-style: solid; + border-color: transparent transparent #121f3d transparent; +} + +.teal-modules-general.trigger-tooltips-button:hover > .plotly-icon-tooltip { + visibility: visible; + opacity: 1; +} diff --git a/inst/js/triggerTooltips.js b/inst/triggerTooltips/triggerTooltips.js similarity index 100% rename from inst/js/triggerTooltips.js rename to inst/triggerTooltips/triggerTooltips.js From 8a364bd25985796792b4bd2b704550b73ce9cfeb Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 14 May 2025 12:38:43 +0530 Subject: [PATCH 087/158] fix: remove unused param --- R/tm_g_spiderplot.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index 8ea43f8bc..a5fa92f35 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -269,7 +269,7 @@ srv_g_spiderplot <- function(id, output$plot <- output$plot <- plotly::renderPlotly(plotly::event_register( { plotly_q()$p |> - setup_trigger_tooltips(session$ns, input) + setup_trigger_tooltips(session$ns) }, "plotly_selected" )) From 4d416764b1fd5fbd416337e4350dce55245561d2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 16 May 2025 09:48:56 +0530 Subject: [PATCH 088/158] feat: simplify the trigger tooltip logic --- R/tm_g_spiderplot.R | 21 --------------- R/tm_g_swimlane.R | 21 --------------- R/utils.R | 6 +---- inst/triggerTooltips/triggerTooltips.css | 15 +++++------ inst/triggerTooltips/triggerTooltips.js | 33 +++++++++++++++++++++--- 5 files changed, 36 insertions(+), 60 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index a5fa92f35..aa3356cb6 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -276,27 +276,6 @@ srv_g_spiderplot <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - observeEvent(input$show_tooltips, { - sel <- plotly_selected() - - if (!is.null(sel) && nrow(sel) > 0) { - tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { - list( - curve = sel$curveNumber[i], - index = sel$pointNumber[i] - ) - }) - - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = session$ns("plot"), - tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) - ) - ) - } - }) - tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index f77fc73e5..36378b7a8 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -252,27 +252,6 @@ srv_g_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) - observeEvent(input$show_tooltips, { - sel <- plotly_selected() - - if (!is.null(sel) && nrow(sel) > 0) { - tooltip_points <- lapply(seq_len(nrow(sel)), function(i) { - list( - curve = sel$curveNumber[i], - index = sel$pointNumber[i] - ) - }) - - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = session$ns("plot"), - tooltipPoints = jsonlite::toJSON(tooltip_points, auto_unbox = TRUE) - ) - ) - } - }) - observeEvent(input$subject_tooltips, { hovervalues <- data()[[plot_dataname]] |> dplyr::mutate(customdata = dplyr::row_number()) |> diff --git a/R/utils.R b/R/utils.R index a0e8a79c7..cf6b87ea3 100644 --- a/R/utils.R +++ b/R/utils.R @@ -507,11 +507,7 @@ setup_trigger_tooltips <- function(plot, ns) { button.className = 'teal-modules-general trigger-tooltips-button'; button.onclick = function () { - const current = parseInt(this.getAttribute('data-count')); - const next = current + 1; - this.setAttribute('data-count', next); - console.log('Button clicked ' + next + ' times'); - Shiny.setInputValue('", ns("show_tooltips"), "', next); + triggerSelectedTooltips('", ns("plot"), "') }; const icon = document.createElement('i'); diff --git a/inst/triggerTooltips/triggerTooltips.css b/inst/triggerTooltips/triggerTooltips.css index ef23f1b5b..5d639532b 100644 --- a/inst/triggerTooltips/triggerTooltips.css +++ b/inst/triggerTooltips/triggerTooltips.css @@ -22,7 +22,7 @@ top: 125%; right: 0; transform: translateX(0); - background-color: #121f3d; + background: #121f3d; color: #fff; padding: 6px 10px; border-radius: 3px; @@ -30,17 +30,14 @@ font-size: 12px; } +.teal-modules-general.trigger-tooltips-button:hover > .plotly-icon-tooltip { + visibility: visible; + opacity: 1; +} + .teal-modules-general.trigger-tooltips-button > .plotly-icon-tooltip::after { content: ""; position: absolute; bottom: 100%; right: 10px; - border-width: 5px; - border-style: solid; - border-color: transparent transparent #121f3d transparent; -} - -.teal-modules-general.trigger-tooltips-button:hover > .plotly-icon-tooltip { - visibility: visible; - opacity: 1; } diff --git a/inst/triggerTooltips/triggerTooltips.js b/inst/triggerTooltips/triggerTooltips.js index bd1072f89..59949c605 100644 --- a/inst/triggerTooltips/triggerTooltips.js +++ b/inst/triggerTooltips/triggerTooltips.js @@ -1,8 +1,33 @@ -Shiny.addCustomMessageHandler("triggerTooltips", function (message) { - const plotDiv = document.getElementById(message.plotID); +triggerTooltips = function (message) { + const plotElement = document.getElementById(message.plotID); const hoverPoints = message.tooltipPoints.map((point) => ({ curveNumber: point.curve || 0, pointNumber: point.index, })); - Plotly.Fx.hover(plotDiv, hoverPoints); -}); + Plotly.Fx.hover(plotElement, hoverPoints); +}; + +Shiny.addCustomMessageHandler("triggerTooltips", triggerTooltips); + +function triggerSelectedTooltips(plotID) { + const plotElement = document.getElementById(plotID); + const tooltipPoints = []; + + plotElement.data.forEach((trace, curveIndex) => { + if (trace.selectedpoints && Array.isArray(trace.selectedpoints)) { + trace.selectedpoints.forEach((pointIndex) => { + tooltipPoints.push({ + x: trace.x[pointIndex], + y: trace.y[pointIndex], + curve: curveIndex, + index: pointIndex, + }); + }); + } + }); + + triggerTooltips({ + plotID: plotID, + tooltipPoints: tooltipPoints, + }); +} From 00b5cf88963a68587afb93c90198fd65c64afed0 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 16 May 2025 06:07:54 +0000 Subject: [PATCH 089/158] [skip style] [skip vbump] Restyle files --- R/plotly_with_settings.R | 4 ++-- R/roxygen2_templates.R | 6 +++--- R/tm_data_table.R | 46 ++++++++++++++++++++-------------------- R/tm_markdown.R | 22 +++++++++---------- inst/poc_crf2.R | 2 +- 5 files changed, 40 insertions(+), 40 deletions(-) diff --git a/R/plotly_with_settings.R b/R/plotly_with_settings.R index 7c00559a2..b40414302 100644 --- a/R/plotly_with_settings.R +++ b/R/plotly_with_settings.R @@ -1,10 +1,10 @@ plotly_with_settings_ui <- function(id, height) { ns <- NS(id) plotly::plotlyOutput(ns("plot"), height = height) -} +} plotly_with_settings_srv <- function(id, plot) { moduleServer(id, function(input, output, session) { output$plot <- plotly::renderPlotly(plot()) }) -} \ No newline at end of file +} diff --git a/R/roxygen2_templates.R b/R/roxygen2_templates.R index d8e1145f0..7e928a97f 100644 --- a/R/roxygen2_templates.R +++ b/R/roxygen2_templates.R @@ -55,14 +55,14 @@ roxygen_ggplot2_args_param <- function(...) { #' decorator for tables or plots included in the module output reported. #' The decorators are applied to the respective output objects. #' -#' @param table_datanames (`character`) names of the datasets which should be listed below the plot +#' @param table_datanames (`character`) names of the datasets which should be listed below the plot #' when some data points are selected. Objects named after `table_datanames` will be pulled from #' `data` so it is important that data actually contains these datasets. Please be aware that -#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. +#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. #' See section "Decorating Module" below for more details. #' #' @return Object of class `teal_module` to be used in `teal` applications. #' #' @name shared_params #' @keywords internal -NULL \ No newline at end of file +NULL diff --git a/R/tm_data_table.R b/R/tm_data_table.R index 7670a9337..02e2072ee 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -170,18 +170,18 @@ ui_data_table <- function(id, pre_output = NULL, post_output = NULL) { # Server page module srv_data_table <- function(id, - data, - datanames, - variables_selected = list(), - dt_args = list(), - dt_options = list( - searching = FALSE, - pageLength = 30, - lengthMenu = c(5, 15, 30, 100), - scrollX = TRUE - ), - server_rendering = FALSE, - filter_panel_api) { + data, + datanames, + variables_selected = list(), + dt_args = list(), + dt_options = list( + searching = FALSE, + pageLength = 30, + lengthMenu = c(5, 15, 30, 100), + scrollX = TRUE + ), + server_rendering = FALSE, + filter_panel_api) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { @@ -192,7 +192,7 @@ srv_data_table <- function(id, datanames_r <- reactive({ Filter( - function(name) is.data.frame(data()[[name]]), + function(name) is.data.frame(data()[[name]]), if (identical(datanames, "all")) names(data()) else datanames ) }) @@ -241,8 +241,8 @@ srv_data_table <- function(id, }) |> bindCache(datanames_r()) |> bindEvent(datanames_r()) - - + + # server should be run only once modules_run <- reactiveVal() modules_to_run <- reactive(setdiff(datanames_r(), isolate(modules_run()))) @@ -297,14 +297,14 @@ ui_dataset_table <- function(id, choices, selected) { # Server function for the data_table module srv_dataset_table <- function(id, - data, - dataname, - if_filtered, - if_distinct, - dt_args, - dt_options, - server_rendering, - filter_panel_api) { + data, + dataname, + if_filtered, + if_distinct, + dt_args, + dt_options, + server_rendering, + filter_panel_api) { moduleServer(id, function(input, output, session) { iv <- shinyvalidate::InputValidator$new() iv$add_rule("variables", shinyvalidate::sv_required("Please select valid variable names")) diff --git a/R/tm_markdown.R b/R/tm_markdown.R index fd7947d37..0e2561c7f 100644 --- a/R/tm_markdown.R +++ b/R/tm_markdown.R @@ -20,22 +20,22 @@ #' iris <- iris #' mtcars <- mtcars #' }) -# +#' # #' #' @export #' tm_rmarkdown <- function(label = "App Info", - text = character(0), - params = list(title = "Document"), - datanames = "all") { + text = character(0), + params = list(title = "Document"), + datanames = "all") { message("Initializing tm_rmarkdown") - + # Start of assertions checkmate::assert_string(label) checkmate::assert_character(text, min.len = 0, any.missing = FALSE) checkmate::assert_list(params) - + ans <- module( label = label, server = srv_rmarkdown, @@ -65,15 +65,15 @@ srv_rmarkdown <- function(id, data, text, params) { cat(text, file = file) } rmarkdown::render( - file, - envir = data(), + file, + envir = data(), params = utils::modifyList( - params, - list(output = list(github_document = list(html_preview = FALSE))) # html_document always as we renderUI below + params, + list(output = list(github_document = list(html_preview = FALSE))) # html_document always as we renderUI below ) ) }) - + output$output <- renderUI({ on.exit(unlink(rmd_out())) # todo: includeMarkdown breaks css of the app diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R index b025610d5..6d52992f4 100644 --- a/inst/poc_crf2.R +++ b/inst/poc_crf2.R @@ -159,7 +159,7 @@ tm_swimlane <- function(label = "Swimlane", plot_height = 700) { extreme_grade ) ) - + p <- plotly::plot_ly( source = "swimlane", colors = c( From 723c084845f95c7dae2977bfc2c729bdd5191442 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 16 May 2025 06:15:00 +0000 Subject: [PATCH 090/158] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/tm_rmarkdown.Rd | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index 3609ef8b4..7b0c159ab 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -44,13 +44,14 @@ data <- teal_data() |> iris <- iris mtcars <- mtcars }) +# } \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG10AHwA+JV1dAHdaUgALFXYQKOjdWkZaUR8MrNE06JhSAhYco11i0sYCiGiAX0UIMHqAXSA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG10AHwA+JV1dAHdaUgALFXYQKOjdWkZaUR8MrNE06JhSAhYco11i0sYCiGiAX0UIAGIlMHqAXSA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } From 4126c6b02911cff66dd49f9fb6cf250426608a5c Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 16 May 2025 18:49:21 +0530 Subject: [PATCH 091/158] feat: implement the subject selection for spiider plot --- R/tm_g_spiderplot.R | 53 +++++++++++++++++++++++-- R/tm_t_reactable.R | 2 +- R/utils.R | 18 ++++----- inst/triggerTooltips/triggerTooltips.js | 2 - 4 files changed, 60 insertions(+), 15 deletions(-) diff --git a/R/tm_g_spiderplot.R b/R/tm_g_spiderplot.R index aa3356cb6..8a697446b 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_g_spiderplot.R @@ -154,7 +154,9 @@ ui_g_spiderplot <- function(id, height) { selectInput(ns("filter_event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("filter_event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]), + selectInput(ns("subjects"), "Subjects", choices = NULL, selected = NULL, multiple = TRUE), + actionButton(ns("subject_tooltips"), "Show Subject Tooltips") ), tags$div( bslib::card( @@ -269,13 +271,54 @@ srv_g_spiderplot <- function(id, output$plot <- output$plot <- plotly::renderPlotly(plotly::event_register( { plotly_q()$p |> + set_plot_data(session$ns("plot_data")) |> setup_trigger_tooltips(session$ns) }, "plotly_selected" )) + observeEvent(data(), { + if (class(subject_var) == "choices_selected") { + subject_col <- subject_var$selected + } else { + subject_col <- subject_var + } + updateSelectInput( + inputId = "subjects", + choices = data()[[plot_dataname]][[subject_col]] + ) + }) + + plotly_data <- reactive({ + data.frame( + x = unlist(input$plot_data$x), + y = unlist(input$plot_data$y), + customdata = unlist(input$plot_data$customdata), + curve = unlist(input$plot_data$curveNumber), + index = unlist(input$plot_data$pointNumber) + ) + }) + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) + observeEvent(input$subject_tooltips, { + hovervalues <- data()[[plot_dataname]] |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::filter(!!rlang::sym(input$subject_var) %in% input$subjects) |> + dplyr::pull(customdata) + + hovertips <- plotly_data() |> + dplyr::filter(customdata %in% hovervalues) + + session$sendCustomMessage( + "triggerTooltips", + list( + plotID = session$ns("plot"), + tooltipPoints = jsonlite::toJSON(hovertips) + ) + ) + }) + tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, @@ -302,6 +345,8 @@ spiderplotly <- function( subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) value_var_label <- .get_column_label(data, value_var) + data <- data |> + dplyr::mutate(customdata = dplyr::row_number()) if (is.null(size_var)) { size <- point_size @@ -340,7 +385,8 @@ spiderplotly <- function( x = ~x, y = ~y, xend = stats::as.formula(sprintf("~%s", time_var)), - yend = stats::as.formula(sprintf("~%s", value_var)) + yend = stats::as.formula(sprintf("~%s", value_var)), + customdata = NULL ) %>% plotly::add_markers( x = stats::as.formula(sprintf("~%s", time_var)), @@ -348,7 +394,8 @@ spiderplotly <- function( symbol = stats::as.formula(sprintf("~%s", color_var)), size = size, text = ~tooltip, - hoverinfo = "text" + hoverinfo = "text", + customdata = ~customdata ) %>% plotly::layout( xaxis = list(title = time_var_label), diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index a55ae6d0f..01a39fefa 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -224,7 +224,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco .make_reactable_call <- function(dataset, dataname, args) { columns <- .make_reactable_columns_call(dataset = dataset, col_defs = args$columns) call_args <- utils::modifyList( - list(columns = columns, onClick = "select"), + list(columns = columns, onClick = "select", selection = "multiple"), args[!names(args) %in% "columns"] ) as.call( diff --git a/R/utils.R b/R/utils.R index cf6b87ea3..9f6db2efa 100644 --- a/R/utils.R +++ b/R/utils.R @@ -512,8 +512,6 @@ setup_trigger_tooltips <- function(plot, ns) { const icon = document.createElement('i'); icon.className = 'fas fa-message'; - icon.setAttribute('role', 'presentation'); - icon.setAttribute('aria-label', 'info icon'); const tooltip = document.createElement('span'); tooltip.className = 'plotly-icon-tooltip'; @@ -536,7 +534,7 @@ set_plot_data <- function(plot, data_id) { paste0( " function(el) { - slicedData = el.data.slice(0, -1).map(({ x, y, customdata }) => ({ x, y, customdata })); + slicedData = el.data.slice(0, -1).map(({ x, y, customdata, mode }) => ({ x, y, customdata, mode })); plotData = { x: [], y: [], @@ -546,12 +544,14 @@ set_plot_data <- function(plot, data_id) { }; slicedData.forEach((item, curveNumber) => { - for (let i = 0; i < item.x.length; i++) { - plotData.pointNumber.push(i); - plotData.x.push(item.x[i]); - plotData.y.push(item.y[i]); - plotData.customdata.push(item.customdata[i]); - plotData.curveNumber.push(curveNumber); + if (item.mode === 'markers') { + for (let i = 0; i < item.x.length; i++) { + plotData.pointNumber.push(i); + plotData.x.push(item.x[i]); + plotData.y.push(item.y[i]); + plotData.customdata.push(item.customdata[i]); + plotData.curveNumber.push(curveNumber); + } } }); Shiny.setInputValue('", data_id, "', plotData); diff --git a/inst/triggerTooltips/triggerTooltips.js b/inst/triggerTooltips/triggerTooltips.js index 59949c605..3ac743769 100644 --- a/inst/triggerTooltips/triggerTooltips.js +++ b/inst/triggerTooltips/triggerTooltips.js @@ -17,8 +17,6 @@ function triggerSelectedTooltips(plotID) { if (trace.selectedpoints && Array.isArray(trace.selectedpoints)) { trace.selectedpoints.forEach((pointIndex) => { tooltipPoints.push({ - x: trace.x[pointIndex], - y: trace.y[pointIndex], curve: curveIndex, index: pointIndex, }); From 25f7aac8839bd5d6f468b7f64d44c54c192bedc2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 29 May 2025 12:14:31 +0530 Subject: [PATCH 092/158] feat: modify the point_size to work like point_colors and point_symbols --- R/tm_g_swimlane.R | 33 +++++++++++++++++---------------- man/tm_g_swimlane.Rd | 7 ++----- 2 files changed, 19 insertions(+), 21 deletions(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 36378b7a8..086e24eb0 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -19,9 +19,8 @@ #' value determines order of the subjects displayed on the y-axis. #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. #' If `NULL`, default tooltip is created. -#' @param size_var (`character(1)` or `NULL`) If provided, this numeric column from the `plot_dataname` -#' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. -#' @param point_size (`numeric(1)`) Default point size of the points in the plot. +#' @param point_size (`numeric(1)` or `named numeric`) Default point size of the points in the plot. +#' If `point_size` is a named numeric vector, it should be named by levels of `color_var` column. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. @@ -82,7 +81,6 @@ tm_g_swimlane <- function(label = "Swimlane", group_var, sort_var = NULL, tooltip_vars = NULL, - size_var = NULL, point_size = 10, point_colors = character(0), point_symbols = character(0), @@ -119,7 +117,6 @@ tm_g_swimlane <- function(label = "Swimlane", color_var = color_var, group_var = group_var, sort_var = sort_var, - size_var = size_var, point_size = point_size, point_colors = point_colors, point_symbols = point_symbols, @@ -164,7 +161,6 @@ srv_g_swimlane <- function(id, color_var, group_var, sort_var = time_var, - size_var = NULL, point_size = 10, point_colors, point_symbols, @@ -203,7 +199,6 @@ srv_g_swimlane <- function(id, color_var = input$color_var, group_var = input$group_var, sort_var = input$sort_var, - size_var = size_var, point_size = point_size, colors = color_inputs(), symbols = adjusted_symbols, @@ -217,7 +212,6 @@ srv_g_swimlane <- function(id, color_var = color_var, group_var = group_var, sort_var = sort_var, - size_var = size_var, point_size = point_size, colors = colors, symbols = symbols, @@ -307,18 +301,12 @@ srv_g_swimlane <- function(id, #' @export swimlanely <- function( data, time_var, subject_var, color_var, group_var, sort_var, - colors, symbols, height, tooltip_vars = NULL, size_var = NULL, point_size = 10) { + colors, symbols, height, tooltip_vars = NULL, point_size = 10) { subject_var_label <- .get_column_label(data, subject_var) time_var_label <- .get_column_label(data, time_var) data <- data |> dplyr::mutate(customdata = dplyr::row_number()) - if (is.null(size_var)) { - size <- point_size - } else { - size <- stats::as.formula(sprintf("~%s", size_var)) - } - # forcats::fct_reorder doesn't seem to work here subject_levels <- data %>% dplyr::group_by(!!as.name(subject_var)) %>% @@ -328,6 +316,19 @@ swimlanely <- function( dplyr::pull(!!as.name(subject_var)) data[[subject_var]] <- factor(data[[subject_var]], levels = subject_levels) + min_size <- min(point_size, na.rm = TRUE) + + if (length(point_size) > 1) { + data <- data %>% + dplyr::mutate( + size_var = ifelse( + as.character(color_var) %in% names(point_size), + point_size[as.character(color_var)], + min_size + ) + ) + } + data %>% dplyr::mutate( !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), @@ -367,7 +368,7 @@ swimlanely <- function( y = stats::as.formula(sprintf("~%s", subject_var)), color = stats::as.formula(sprintf("~%s", color_var)), symbol = stats::as.formula(sprintf("~%s", color_var)), - size = size, + size = ~size_var, text = ~tooltip, hoverinfo = "text" ) %>% diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd index daf534c55..61054f64b 100644 --- a/man/tm_g_swimlane.Rd +++ b/man/tm_g_swimlane.Rd @@ -13,7 +13,6 @@ tm_g_swimlane( group_var, sort_var = NULL, tooltip_vars = NULL, - size_var = NULL, point_size = 10, point_colors = character(0), point_symbols = character(0), @@ -48,10 +47,8 @@ value determines order of the subjects displayed on the y-axis.} \item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. If \code{NULL}, default tooltip is created.} -\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} -will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} - -\item{point_size}{(\code{numeric(1)}) Default point size of the points in the plot.} +\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. +If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} \item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by levels of \code{color_var} column.} From 1a828235f324ab64dcd9d77831f21206625ae4ad Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 20 Aug 2025 17:52:16 +0530 Subject: [PATCH 093/158] chore: fix errors in module --- R/tm_g_swimlane.R | 3 +++ R/tm_t_reactable.R | 8 +++++++- 2 files changed, 10 insertions(+), 1 deletion(-) diff --git a/R/tm_g_swimlane.R b/R/tm_g_swimlane.R index 086e24eb0..c9b423faf 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_g_swimlane.R @@ -327,6 +327,9 @@ swimlanely <- function( min_size ) ) + } else { + data <- data %>% + dplyr::mutate(size_var = point_size) } data %>% diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 01a39fefa..25c4e300a 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -63,7 +63,13 @@ srv_t_reactables <- function( return(NULL) } div( - include_css_files("reactable.css"), + htmltools::htmlDependency( + name = "teal-modules-general-reactable", + version = utils::packageVersion("teal.modules.general"), + package = "teal.modules.general", + src = "css", + stylesheet = "reactable.css" + ), do.call( bslib::accordion, c( From 0092add591eb6861e36493826d28f18e36db3bc9 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 27 Aug 2025 19:25:00 +0530 Subject: [PATCH 094/158] feat: decouple the plot functions and rename module functions --- R/{tm_g_spiderplot.R => tm_p_spiderplot.R} | 158 ++++++++-------- R/{tm_g_swimlane.R => tm_p_swimlane.R} | 210 ++++++++++----------- R/{tm_g_waterfall.R => tm_p_waterfall.R} | 137 ++++++-------- 3 files changed, 233 insertions(+), 272 deletions(-) rename R/{tm_g_spiderplot.R => tm_p_spiderplot.R} (80%) rename R/{tm_g_swimlane.R => tm_p_swimlane.R} (73%) rename R/{tm_g_waterfall.R => tm_p_waterfall.R} (75%) diff --git a/R/tm_g_spiderplot.R b/R/tm_p_spiderplot.R similarity index 80% rename from R/tm_g_spiderplot.R rename to R/tm_p_spiderplot.R index 8a697446b..ba2fc191d 100644 --- a/R/tm_g_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -62,7 +62,7 @@ #' app <- init( #' data = data, #' modules = modules( -#' tm_g_spiderplot( +#' tm_p_spiderplot( #' plot_dataname = "spiderplot_ds", #' table_datanames = "subjects", #' time_var = "time_var", @@ -85,7 +85,7 @@ #' } #' #' @export -tm_g_spiderplot <- function(label = "Spiderplot", +tm_p_spiderplot <- function(label = "Spiderplot", plot_dataname, time_var, value_var, @@ -246,23 +246,86 @@ srv_g_spiderplot <- function(id, symbols = adjusted_symbols, size_var = size_var, height = input$plot_height, + point_size = 10, title = sprintf("%s over time", input$filter_event_var_level), tooltip_vars = tooltip_vars, expr = { - p <- dataname %>% + plot_data <- dataname %>% dplyr::filter(filter_event_var_lang == selected_event) %>% - spiderplotly( - time_var = time_var, - value_var = value_var, - subject_var = subject_var, - filter_event_var = filter_event_var, - color_var = color_var, - colors = colors, - symbols = symbols, - size_var = size_var, + dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% + dplyr::group_by(!!as.name(subject_var)) + subject_var_label <- attr(plot_data[[subject_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + time_var_label <- attr(plot_data[[time_var]], "label") + if (!length(time_var_label)) time_var_label <- time_var + value_var_label <- attr(plot_data[[value_var]], "label") + if (!length(value_var_label)) value_var_label <- value_var + plot_data <- plot_data |> + dplyr::mutate(customdata = dplyr::row_number()) + + if (is.null(size_var)) { + size <- point_size + } else { + size <- stats::as.formula(sprintf("~%s", size_var)) + } + + p <- plot_data %>% + dplyr::mutate( + x = dplyr::lag(!!as.name(time_var), default = 0), + y = dplyr:::lag(!!as.name(value_var), default = 0), + tooltip = { + if (is.null(tooltip_vars)) { + sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var), + time_var_label, !!as.name(time_var), + value_var_label, !!as.name(value_var) * 100 + ) + } else { + tooltip_lines <- sapply(tooltip_vars, function(col) { + label <- .get_column_label(.data, col) + value <- .data[[col]] + paste0(label, ": ", value) + }) + if (is.vector(tooltip_lines)) { + paste(tooltip_lines, collapse = "
") + } else { + apply(tooltip_lines, 1, function(row) paste(row, collapse = "
")) + } + } + } + ) %>% + dplyr::ungroup() %>% + plotly::plot_ly( + source = "spiderplot", height = height, - tooltip_vars = tooltip_vars + color = stats::as.formula(sprintf("~%s", color_var)), + colors = colors, + symbols = symbols + ) %>% + plotly::add_segments( + x = ~x, + y = ~y, + xend = stats::as.formula(sprintf("~%s", time_var)), + yend = stats::as.formula(sprintf("~%s", value_var)), + customdata = NULL + ) %>% + plotly::add_markers( + x = stats::as.formula(sprintf("~%s", time_var)), + y = stats::as.formula(sprintf("~%s", value_var)), + symbol = stats::as.formula(sprintf("~%s", color_var)), + size = size, + text = ~tooltip, + hoverinfo = "text", + customdata = ~customdata + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = value_var_label), + title = title, + dragmode = "select" ) %>% + plotly::config(displaylogo = FALSE) %>% plotly::layout(title = title) } ) @@ -336,72 +399,3 @@ srv_g_spiderplot <- function(id, ) }) } - -# todo: export is temporary, this should go to a new package teal.graphs or another bird species -#' @export -spiderplotly <- function( - data, time_var, value_var, subject_var, filter_event_var, - color_var, colors, symbols, height, tooltip_vars = NULL, size_var = NULL, point_size = 10) { - subject_var_label <- .get_column_label(data, subject_var) - time_var_label <- .get_column_label(data, time_var) - value_var_label <- .get_column_label(data, value_var) - data <- data |> - dplyr::mutate(customdata = dplyr::row_number()) - - if (is.null(size_var)) { - size <- point_size - } else { - size <- stats::as.formula(sprintf("~%s", size_var)) - } - - data %>% - dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% - dplyr::group_by(!!as.name(subject_var)) %>% - dplyr::mutate( - x = dplyr::lag(!!as.name(time_var), default = 0), - y = dplyr:::lag(!!as.name(value_var), default = 0), - tooltip = { - if (is.null(tooltip_vars)) { - sprintf( - "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var), - time_var_label, !!as.name(time_var), - value_var_label, !!as.name(value_var) * 100 - ) - } else { - .generate_tooltip(.data, tooltip_vars) - } - } - ) %>% - dplyr::ungroup() %>% - plotly::plot_ly( - source = "spiderplot", - height = height, - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - symbols = symbols - ) %>% - plotly::add_segments( - x = ~x, - y = ~y, - xend = stats::as.formula(sprintf("~%s", time_var)), - yend = stats::as.formula(sprintf("~%s", value_var)), - customdata = NULL - ) %>% - plotly::add_markers( - x = stats::as.formula(sprintf("~%s", time_var)), - y = stats::as.formula(sprintf("~%s", value_var)), - symbol = stats::as.formula(sprintf("~%s", color_var)), - size = size, - text = ~tooltip, - hoverinfo = "text", - customdata = ~customdata - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = value_var_label), - title = title, - dragmode = "select" - ) %>% - plotly::config(displaylogo = FALSE) -} diff --git a/R/tm_g_swimlane.R b/R/tm_p_swimlane.R similarity index 73% rename from R/tm_g_swimlane.R rename to R/tm_p_swimlane.R index c9b423faf..1ffea25ba 100644 --- a/R/tm_g_swimlane.R +++ b/R/tm_p_swimlane.R @@ -49,7 +49,7 @@ #' app <- init( #' data = data, #' modules = modules( -#' tm_g_swimlane( +#' tm_p_swimlane( #' plot_dataname = "swimlane_ds", #' table_datanames = "subjects", #' time_var = "time_var", @@ -73,7 +73,7 @@ #' } #' #' @export -tm_g_swimlane <- function(label = "Swimlane", +tm_p_swimlane <- function(label = "Swimlane", plot_dataname, time_var, subject_var, @@ -205,19 +205,100 @@ srv_g_swimlane <- function(id, height = input$plot_height, tooltip_vars = tooltip_vars, expr = { - p <- swimlanely( - data = dataname, - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_var, - point_size = point_size, - colors = colors, - symbols = symbols, - height = height, - tooltip_vars = tooltip_vars - ) + subject_var_label <- attr(dataname[[subject_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + time_var_label <- attr(dataname[[time_var]], "label") + if (!length(time_var_label)) time_var_label <- time_var + plot_data <- dataname |> + dplyr::mutate(customdata = dplyr::row_number()) + + # forcats::fct_reorder doesn't seem to work here + subject_levels <- plot_data %>% + dplyr::group_by(!!as.name(subject_var)) %>% + dplyr::summarize(v = max(!!as.name(sort_var))) %>% + dplyr::ungroup() %>% + dplyr::arrange(v) %>% + dplyr::pull(!!as.name(subject_var)) + plot_data[[subject_var]] <- factor(plot_data[[subject_var]], levels = subject_levels) + + min_size <- min(point_size, na.rm = TRUE) + + if (length(point_size) > 1) { + plot_data <- plot_data %>% + dplyr::mutate( + size_var = ifelse( + as.character(color_var) %in% names(point_size), + point_size[as.character(color_var)], + min_size + ) + ) + } else { + plot_data <- plot_data %>% + dplyr::mutate(size_var = point_size) + } + + p <- plot_data %>% + dplyr::mutate( + !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), + ) %>% + dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars)) { + paste( + unique( + c( + paste(subject_var_label, !!as.name(subject_var)), + paste(time_var_label, !!as.name(time_var)), + sprintf( + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), + !!as.name(color_var) + ) + ) + ), + collapse = "
" + ) + } else { + .generate_tooltip(.data, tooltip_vars) + } + } + ) %>% + plotly::plot_ly( + source = "swimlane", + colors = colors, + symbols = symbols, + height = height, + customdata = ~customdata + ) %>% + plotly::add_markers( + x = stats::as.formula(sprintf("~%s", time_var)), + y = stats::as.formula(sprintf("~%s", subject_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + symbol = stats::as.formula(sprintf("~%s", color_var)), + size = ~size_var, + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::add_segments( + x = ~0, + xend = ~study_day, + y = stats::as.formula(sprintf("~%s", subject_var)), + yend = stats::as.formula(sprintf("~%s", subject_var)), + data = plot_data |> + dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> + dplyr::summarise(study_day = max(!!as.name(time_var))), + line = list(width = 2, color = "grey"), + showlegend = FALSE, + customdata = NULL + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = subject_var_label) + ) %>% + plotly::layout(dragmode = "select", title = title) %>% + plotly::config(displaylogo = FALSE) %>% + plotly::layout(title = title) } ) }) @@ -295,102 +376,3 @@ srv_g_swimlane <- function(id, ) }) } - - -# todo: export is temporary, this should go to a new package teal.graphs or another bird species -#' @export -swimlanely <- function( - data, time_var, subject_var, color_var, group_var, sort_var, - colors, symbols, height, tooltip_vars = NULL, point_size = 10) { - subject_var_label <- .get_column_label(data, subject_var) - time_var_label <- .get_column_label(data, time_var) - data <- data |> - dplyr::mutate(customdata = dplyr::row_number()) - - # forcats::fct_reorder doesn't seem to work here - subject_levels <- data %>% - dplyr::group_by(!!as.name(subject_var)) %>% - dplyr::summarize(v = max(!!as.name(sort_var))) %>% - dplyr::ungroup() %>% - dplyr::arrange(v) %>% - dplyr::pull(!!as.name(subject_var)) - data[[subject_var]] <- factor(data[[subject_var]], levels = subject_levels) - - min_size <- min(point_size, na.rm = TRUE) - - if (length(point_size) > 1) { - data <- data %>% - dplyr::mutate( - size_var = ifelse( - as.character(color_var) %in% names(point_size), - point_size[as.character(color_var)], - min_size - ) - ) - } else { - data <- data %>% - dplyr::mutate(size_var = point_size) - } - - data %>% - dplyr::mutate( - !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), - ) %>% - dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% - dplyr::mutate( - tooltip = { - if (is.null(tooltip_vars)) { - paste( - unique( - c( - paste(subject_var_label, !!as.name(subject_var)), - paste(time_var_label, !!as.name(time_var)), - sprintf( - "%s: %s", - tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), - !!as.name(color_var) - ) - ) - ), - collapse = "
" - ) - } else { - .generate_tooltip(.data, tooltip_vars) - } - } - ) %>% - plotly::plot_ly( - source = "swimlane", - colors = colors, - symbols = symbols, - height = height, - customdata = ~customdata - ) %>% - plotly::add_markers( - x = stats::as.formula(sprintf("~%s", time_var)), - y = stats::as.formula(sprintf("~%s", subject_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - symbol = stats::as.formula(sprintf("~%s", color_var)), - size = ~size_var, - text = ~tooltip, - hoverinfo = "text" - ) %>% - plotly::add_segments( - x = ~0, - xend = ~study_day, - y = stats::as.formula(sprintf("~%s", subject_var)), - yend = stats::as.formula(sprintf("~%s", subject_var)), - data = data |> - dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> - dplyr::summarise(study_day = max(!!as.name(time_var))), - line = list(width = 2, color = "grey"), - showlegend = FALSE, - customdata = NULL - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = subject_var_label) - ) %>% - plotly::layout(dragmode = "select") %>% - plotly::config(displaylogo = FALSE) -} diff --git a/R/tm_g_waterfall.R b/R/tm_p_waterfall.R similarity index 75% rename from R/tm_g_waterfall.R rename to R/tm_p_waterfall.R index da71cb2e9..37f41ed94 100644 --- a/R/tm_g_waterfall.R +++ b/R/tm_p_waterfall.R @@ -43,7 +43,7 @@ #' app <- init( #' data = data, #' modules = modules( -#' tm_g_waterfall( +#' tm_p_waterfall( #' plot_dataname = "waterfall_ds", #' table_datanames = "subjects", #' subject_var = "subject_var", @@ -63,7 +63,7 @@ #' } #' #' @export -tm_g_waterfall <- function(label = "Waterfall", +tm_p_waterfall <- function(label = "Waterfall", plot_dataname, subject_var, value_var, @@ -188,17 +188,66 @@ srv_g_waterfall <- function(id, title = sprintf("Waterfall plot"), tooltip_vars = tooltip_vars, expr = { - p <- waterfally( - dataname, - subject_var = subject_var, - value_var = value_var, - sort_var = sort_var, - color_var = color_var, - colors = colors, - value_arbitrary_hlines = value_arbitrary_hlines, - height = height, - tooltip_vars = tooltip_vars + subject_var_label <- attr(dataname[[subject_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + value_var_label <- attr(dataname[[value_var]], "label") + if (!length(value_var_label)) value_var_label <- value_var + color_var_label <- attr(dataname[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var + + + p <- dplyr::mutate( + if (identical(sort_var, value_var) || is.null(sort_var)) { + dplyr::arrange(dataname, desc(!!as.name(value_var))) + } else { + dplyr::arrange(dataname, !!as.name(sort_var), desc(!!as.name(value_var))) + }, + !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), + tooltip = { + if (is.null(tooltip_vars)) { + sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), + value_var_label, !!as.name(value_var), + color_var_label, !!as.name(color_var) + ) + } else { + .generate_tooltip(.data, tooltip_vars) + } + } ) %>% + dplyr::filter(!duplicated(!!as.name(subject_var))) %>% + plotly::plot_ly( + source = "waterfall", + height = height + ) %>% + plotly::add_bars( + x = stats::as.formula(sprintf("~%s", subject_var)), + y = stats::as.formula(sprintf("~%s", value_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + colors = colors, + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::layout( + shapes = lapply(value_arbitrary_hlines, function(y) { + list( + type = "line", + x0 = 0, + x1 = 1, + xref = "paper", + y0 = y, + y1 = y, + line = list(color = "black", dash = "dot") + ) + }), + xaxis = list(title = subject_var_label, tickangle = -45), + yaxis = list(title = value_var_label), + legend = list(title = list(text = "Color by:")), + barmode = "relative" + ) %>% + plotly::layout(dragmode = "select") %>% + plotly::config(displaylogo = FALSE) %>% plotly::layout(title = title) }, height = input$plot_height @@ -226,67 +275,3 @@ srv_g_waterfall <- function(id, ) }) } - - -# todo: export is temporary, this should go to a new package teal.graphs or another bird species -#' @export -waterfally <- function( - data, subject_var, value_var, sort_var, color_var, colors, - value_arbitrary_hlines, height, tooltip_vars = NULL) { - subject_var_label <- .get_column_label(data, subject_var) - value_var_label <- .get_column_label(data, value_var) - color_var_label <- .get_column_label(data, color_var) - - dplyr::mutate( - if (identical(sort_var, value_var) || is.null(sort_var)) { - dplyr::arrange(data, desc(!!as.name(value_var))) - } else { - dplyr::arrange(data, !!as.name(sort_var), desc(!!as.name(value_var))) - }, - !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), - tooltip = { - if (is.null(tooltip_vars)) { - sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), - value_var_label, !!as.name(value_var), - color_var_label, !!as.name(color_var) - ) - } else { - .generate_tooltip(.data, tooltip_vars) - } - } - ) %>% - dplyr::filter(!duplicated(!!as.name(subject_var))) %>% - plotly::plot_ly( - source = "waterfall", - height = height - ) %>% - plotly::add_bars( - x = stats::as.formula(sprintf("~%s", subject_var)), - y = stats::as.formula(sprintf("~%s", value_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - text = ~tooltip, - hoverinfo = "text" - ) %>% - plotly::layout( - shapes = lapply(value_arbitrary_hlines, function(y) { - list( - type = "line", - x0 = 0, - x1 = 1, - xref = "paper", - y0 = y, - y1 = y, - line = list(color = "black", dash = "dot") - ) - }), - xaxis = list(title = subject_var_label, tickangle = -45), - yaxis = list(title = value_var_label), - legend = list(title = list(text = "Color by:")), - barmode = "relative" - ) %>% - plotly::layout(dragmode = "select") %>% - plotly::config(displaylogo = FALSE) -} From 93bc7d97cdd848f2084639d0bd11a2b6cd715dce Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Aug 2025 12:38:15 +0530 Subject: [PATCH 095/158] fix: update docs and namespace --- NAMESPACE | 9 +-- R/utils.R | 3 +- man/tm_g_spiderplot.Rd | 125 ----------------------------------------- man/tm_g_swimlane.Rd | 113 ------------------------------------- man/tm_g_waterfall.Rd | 100 --------------------------------- 5 files changed, 4 insertions(+), 346 deletions(-) delete mode 100644 man/tm_g_spiderplot.Rd delete mode 100644 man/tm_g_swimlane.Rd delete mode 100644 man/tm_g_waterfall.Rd diff --git a/NAMESPACE b/NAMESPACE index d85616edb..15beba75e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,8 +10,6 @@ S3method(create_sparklines,logical) S3method(create_sparklines,numeric) export(add_facet_labels) export(get_scatterplotmatrix_stats) -export(spiderplotly) -export(swimlanely) export(tm_a_pca) export(tm_a_regression) export(tm_data_table) @@ -23,16 +21,15 @@ export(tm_g_distribution) export(tm_g_response) export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) -export(tm_g_spiderplot) -export(tm_g_swimlane) -export(tm_g_waterfall) export(tm_missing_data) export(tm_outliers) +export(tm_p_spiderplot) +export(tm_p_swimlane) +export(tm_p_waterfall) export(tm_rmarkdown) export(tm_t_crosstable) export(tm_t_reactables) export(tm_variable_browser) -export(waterfally) import(ggmosaic) import(ggplot2) import(shiny) diff --git a/R/utils.R b/R/utils.R index 5db4f4333..e49f50be7 100644 --- a/R/utils.R +++ b/R/utils.R @@ -186,13 +186,12 @@ variable_type_icons <- function(var_type) { )) } -#' #' @param id (`character(1)`) the id of the tab panel with tabs. #' @param name (`character(1)`) the name of the tab. #' @return JavaScript expression to be used in `shiny::conditionalPanel()` to determine #' if the specified tab is active. +#' @noRd #' @keywords internal -#' is_tab_active_js <- function(id, name) { # supporting the bs3 and higher version at the same time sprintf( diff --git a/man/tm_g_spiderplot.Rd b/man/tm_g_spiderplot.Rd deleted file mode 100644 index bd45f3360..000000000 --- a/man/tm_g_spiderplot.Rd +++ /dev/null @@ -1,125 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_spiderplot.R -\name{tm_g_spiderplot} -\alias{tm_g_spiderplot} -\title{\code{teal} module: Spider Plot} -\usage{ -tm_g_spiderplot( - label = "Spiderplot", - plot_dataname, - time_var, - value_var, - subject_var, - color_var, - filter_event_var, - size_var = NULL, - tooltip_vars = NULL, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} - -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as x-axis.} - -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as y-axis.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used to differentiate colors and symbols.} - -\item{filter_event_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used to filter the data. -The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu.} - -\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} -will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var}column.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} -} -\description{ -Module visualizes value development in time grouped by subjects. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - swimlane_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = sample(1:100, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - - spiderplot_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = 1:10, - filter_event_var = "response", - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), - value_var = sample(-50:100, 10, replace = TRUE) - ) - - waterfall_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - value_var = sample(-20:90, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_g_spiderplot( - plot_dataname = "spiderplot_ds", - table_datanames = "subjects", - time_var = "time_var", - value_var = "value_var", - subject_var = "subject_var", - filter_event_var = "filter_event_var", - color_var = "color_var", - point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ), - point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_g_swimlane.Rd b/man/tm_g_swimlane.Rd deleted file mode 100644 index 61054f64b..000000000 --- a/man/tm_g_swimlane.Rd +++ /dev/null @@ -1,113 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_swimlane.R -\name{tm_g_swimlane} -\alias{tm_g_swimlane} -\title{\code{teal} module: Swimlane plot} -\usage{ -tm_g_swimlane( - label = "Swimlane", - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var = NULL, - tooltip_vars = NULL, - point_size = 10, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(700, 400, 1200), - table_datanames = character(0), - reactable_args = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} - -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as x-axis.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as y-axis.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to name and color subject events in time.} - -\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to categorize type of event. -(legend is sorted according to this variable, and used in toolip to display type of the event) -todo: this can be fixed by ordering factor levels} - -\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which -value determines order of the subjects displayed on the y-axis.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. -If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} - -\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} -} -\description{ -Module visualizes subjects' events in time. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - swimlane_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = sample(1:100, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_g_swimlane( - plot_dataname = "swimlane_ds", - table_datanames = "subjects", - time_var = "time_var", - subject_var = "subject_var", - color_var = "color_var", - group_var = "color_var", - sort_var = "time_var", - plot_height = 400, - point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ), - point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_g_waterfall.Rd b/man/tm_g_waterfall.Rd deleted file mode 100644 index 4afb01ecd..000000000 --- a/man/tm_g_waterfall.Rd +++ /dev/null @@ -1,100 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_waterfall.R -\name{tm_g_waterfall} -\alias{tm_g_waterfall} -\title{\code{teal} module: Waterfall plot} -\usage{ -tm_g_waterfall( - label = "Waterfall", - plot_dataname, - subject_var, - value_var, - sort_var = NULL, - color_var = NULL, - tooltip_vars = NULL, - bar_colors = character(0), - value_arbitrary_hlines = c(0.2, -0.3), - plot_title = "Waterfall plot", - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as x-axis.} - -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as y-axis.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used to differentiate bar colors.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal -lines on the plot.} - -\item{plot_title}{(\code{character}) Title of the plot.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} -} -\description{ -Module visualizes subjects sorted decreasingly by y-values. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - waterfall_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - value_var = sample(-20:90, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_g_waterfall( - plot_dataname = "waterfall_ds", - table_datanames = "subjects", - subject_var = "subject_var", - value_var = "value_var", - sort_var = "value_var", - color_var = "color_var", - value_arbitrary_hlines = c(20, -30), - bar_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} From 392c394bcee47129dafb3d74b2b37d5603abbb4e Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Aug 2025 12:57:08 +0530 Subject: [PATCH 096/158] chore: rename internal functions too --- R/tm_p_spiderplot.R | 8 ++++---- R/tm_p_swimlane.R | 8 ++++---- R/tm_p_waterfall.R | 8 ++++---- 3 files changed, 12 insertions(+), 12 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index ba2fc191d..416cc74b4 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -117,8 +117,8 @@ tm_p_spiderplot <- function(label = "Spiderplot", module( label = label, - ui = ui_g_spiderplot, - server = srv_g_spiderplot, + ui = ui_p_spiderplot, + server = srv_p_spiderplot, ui_args = list(height = plot_height), server_args = list( plot_dataname = plot_dataname, @@ -139,7 +139,7 @@ tm_p_spiderplot <- function(label = "Spiderplot", } -ui_g_spiderplot <- function(id, height) { +ui_p_spiderplot <- function(id, height) { ns <- NS(id) bslib::page_sidebar( sidebar = div( @@ -171,7 +171,7 @@ ui_g_spiderplot <- function(id, height) { ) } -srv_g_spiderplot <- function(id, +srv_p_spiderplot <- function(id, data, plot_dataname, time_var, diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 1ffea25ba..762ca284c 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -106,8 +106,8 @@ tm_p_swimlane <- function(label = "Swimlane", } module( label = label, - ui = ui_g_swimlane, - server = srv_g_swimlane, + ui = ui_p_swimlane, + server = srv_p_swimlane, datanames = c(plot_dataname, table_datanames), ui_args = list(height = plot_height), server_args = list( @@ -127,7 +127,7 @@ tm_p_swimlane <- function(label = "Swimlane", ) } -ui_g_swimlane <- function(id, height) { +ui_p_swimlane <- function(id, height) { ns <- NS(id) bslib::page_sidebar( sidebar = div( @@ -153,7 +153,7 @@ ui_g_swimlane <- function(id, height) { ) ) } -srv_g_swimlane <- function(id, +srv_p_swimlane <- function(id, data, plot_dataname, time_var, diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index 37f41ed94..89606a490 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -91,8 +91,8 @@ tm_p_waterfall <- function(label = "Waterfall", module( label = label, - ui = ui_g_waterfall, - server = srv_g_waterfall, + ui = ui_p_waterfall, + server = srv_p_waterfall, datanames = union(plot_dataname, table_datanames), ui_args = list(height = plot_height), server_args = list( @@ -111,7 +111,7 @@ tm_p_waterfall <- function(label = "Waterfall", ) } -ui_g_waterfall <- function(id, height) { +ui_p_waterfall <- function(id, height) { ns <- NS(id) bslib::page_sidebar( @@ -142,7 +142,7 @@ ui_g_waterfall <- function(id, height) { ) ) } -srv_g_waterfall <- function(id, +srv_p_waterfall <- function(id, data, plot_dataname, subject_var, From c338ea0bf2312093a3a741c3601bc432a555a892 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Aug 2025 19:50:42 +0530 Subject: [PATCH 097/158] feat: add the new scatterplot module --- NAMESPACE | 1 + R/tm_p_scatterplot.R | 111 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 112 insertions(+) create mode 100644 R/tm_p_scatterplot.R diff --git a/NAMESPACE b/NAMESPACE index 15beba75e..94fff1ced 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,7 @@ export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) +export(tm_p_scatterplot) export(tm_p_spiderplot) export(tm_p_swimlane) export(tm_p_waterfall) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R new file mode 100644 index 000000000..0323372cb --- /dev/null +++ b/R/tm_p_scatterplot.R @@ -0,0 +1,111 @@ +#' @export +tm_p_scatterplot <- function(label = "Scatter Plot", + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + filter_var, + point_colors = character(0)) { + module( + label = label, + ui = ui_p_scatterplot, + server = srv_p_scatterplot, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + subject_var = subject_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + filter_var = filter_var, + point_colors = point_colors + ) + ) +} + +ui_p_scatterplot <- function(id) { + ns <- NS(id) + bslib::page_sidebar( + sidebar = div( + shinyWidgets::pickerInput(ns("event_type"), label = "Select Event Type", choices = NULL), + colour_picker_ui(ns("colors")) + ), + tags$div( + bslib::card( + full_screen = TRUE, + tags$div( + trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ) + ) + ) +} + +srv_p_scatterplot <- function(id, + data, + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + filter_var, + point_colors) { + moduleServer(id, function(input, output, session) { + observeEvent(data(), { + shinyWidgets::updatePickerInput( + session, "event_type", + choices = unique(data()[[plot_dataname]][[filter_var]]) + ) + }) + + color_inputs <- colour_picker_srv( + "colors", + x = reactive({ + data()[[plot_dataname]][[color_var]] + }), + default_colors = point_colors + ) + + plotly_q <- reactive({ + req(input$event_type, color_inputs()) + within( + data(), + filter_var = str2lang(filter_var), + subject_var = str2lang(subject_var), + x_var = str2lang(x_var), + y_var = str2lang(y_var), + color_var = str2lang(color_var), + colors = color_inputs(), + expr = { + plot_data <- scatterplot_ds |> + dplyr::filter(filter_var == input_event_type) |> + dplyr::select(subject_var, x_var, y_var, color_var) |> + dplyr::mutate(color_var = factor(color_var, levels = names(colors))) + p <- plot_ly( + data = plot_data, + x = ~x_var, + y = ~y_var, + color = ~color_var, + colors = colors, + mode = "markers", + type = "scatter" + ) |> + plotly::layout(dragmode = "select") + p() + }, + input_event_type = input$event_type + ) + }) + + + output$plot <- plotly::renderPlotly(plotly::event_register( + { + plotly_q()$p |> + setup_trigger_tooltips(session$ns) + }, + "plotly_selected" + )) + }) +} From 95310d3523d64e85e5e5c12f3ec890945877c70f Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 28 Aug 2025 20:22:52 +0530 Subject: [PATCH 098/158] chore: add pkg namespace --- R/tm_p_scatterplot.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 0323372cb..afcb451a3 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -83,7 +83,7 @@ srv_p_scatterplot <- function(id, dplyr::filter(filter_var == input_event_type) |> dplyr::select(subject_var, x_var, y_var, color_var) |> dplyr::mutate(color_var = factor(color_var, levels = names(colors))) - p <- plot_ly( + p <- plotly::plot_ly( data = plot_data, x = ~x_var, y = ~y_var, From de3b770b9411cecfbc03ca3a11848dce9fa8196e Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 29 Aug 2025 16:34:23 +0530 Subject: [PATCH 099/158] fix: stop using internal functions inside the qenv --- R/tm_p_spiderplot.R | 3 ++- R/tm_p_swimlane.R | 44 +++++++++++++++++++++++++++++--------------- R/tm_p_waterfall.R | 28 +++++++++++++++++++++------- R/utils.R | 20 -------------------- 4 files changed, 52 insertions(+), 43 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 416cc74b4..d8c10a04d 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -283,7 +283,8 @@ srv_p_spiderplot <- function(id, ) } else { tooltip_lines <- sapply(tooltip_vars, function(col) { - label <- .get_column_label(.data, col) + label <- attr(dataname[[col]], "label") + if (!length(label)) label <- col value <- .data[[col]] paste0(label, ": ", value) }) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 762ca284c..f74798ec5 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -244,23 +244,37 @@ srv_p_swimlane <- function(id, dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( tooltip = { - if (is.null(tooltip_vars)) { - paste( - unique( - c( - paste(subject_var_label, !!as.name(subject_var)), - paste(time_var_label, !!as.name(time_var)), - sprintf( - "%s: %s", - tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), - !!as.name(color_var) - ) + default_tip <- paste( + unique( + c( + paste(subject_var_label, !!as.name(subject_var)), + paste(time_var_label, !!as.name(time_var)), + sprintf( + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), + !!as.name(color_var) ) - ), - collapse = "
" - ) + ) + ), + collapse = "
" + ) + if (is.null(tooltip_vars)) { + default_tip } else { - .generate_tooltip(.data, tooltip_vars) + cur_data <- dplyr::pick(dplyr::everything()) + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + default_tip + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + lb <- attr(sub[[cn]], "label") + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) + } } } ) %>% diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index 89606a490..fee2f9008 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -204,15 +204,29 @@ srv_p_waterfall <- function(id, }, !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), tooltip = { + default_tip <- sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var), + value_var_label, !!as.name(value_var), + color_var_label, !!as.name(color_var) + ) if (is.null(tooltip_vars)) { - sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), - value_var_label, !!as.name(value_var), - color_var_label, !!as.name(color_var) - ) + default_tip } else { - .generate_tooltip(.data, tooltip_vars) + cur_data <- dplyr::pick(dplyr::everything()) + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + default_tip + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + lb <- attr(sub[[cn]], "label") + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) + } } } ) %>% diff --git a/R/utils.R b/R/utils.R index e49f50be7..a5a9d07d8 100644 --- a/R/utils.R +++ b/R/utils.R @@ -433,26 +433,6 @@ children <- function(x, dataset_name = character(0)) { if (length(cs$choices) < 2) shinyjs::hide(inputId) } -.get_column_label <- function(data, column) { - column_label <- attr(data[[column]], "label") - if (!length(column_label)) column_label <- column - column_label -} - - -.generate_tooltip <- function(data, tooltip_cols) { - tooltip_lines <- sapply(tooltip_cols, function(col) { - label <- .get_column_label(data, col) - value <- data[[col]] - paste0(label, ": ", value) - }) - if (is.vector(tooltip_lines)) { - paste(tooltip_lines, collapse = "
") - } else { - apply(tooltip_lines, 1, function(row) paste(row, collapse = "
")) - } -} - #' @keywords internal #' @noRd From f4a13ef783ec07c03d905a27cb6cff7972f2d3b1 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 11:36:38 +0530 Subject: [PATCH 100/158] feat: add MVP version of line and barplot --- NAMESPACE | 2 ++ R/tm_p_bargraph.R | 80 +++++++++++++++++++++++++++++++++++++++++ R/tm_p_lineplot.R | 91 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 173 insertions(+) create mode 100644 R/tm_p_bargraph.R create mode 100644 R/tm_p_lineplot.R diff --git a/NAMESPACE b/NAMESPACE index 94fff1ced..a4e70b7aa 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -23,6 +23,8 @@ export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) +export(tm_p_bargraph) +export(tm_p_lineplot) export(tm_p_scatterplot) export(tm_p_spiderplot) export(tm_p_swimlane) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R new file mode 100644 index 000000000..9812f7183 --- /dev/null +++ b/R/tm_p_bargraph.R @@ -0,0 +1,80 @@ +#' @export +tm_p_bargraph <- function(label = "Bar Plot", + plot_dataname, + y_var, + color_var, + count_var, + bar_colors = NULL) { + module( + label = label, + ui = ui_p_bargraph, + server = srv_p_bargraph, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + bar_colors = bar_colors + ) + ) +} + +ui_p_bargraph <- function(id) { + ns <- NS(id) + bslib::page_fluid( + bslib::card( + full_screen = TRUE, + tags$div( + # trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ) + ) +} + +srv_p_bargraph <- function(id, data, plot_dataname, y_var, color_var, count_var, bar_colors) { + moduleServer(id, function(input, output, session) { + plotly_q <- reactive({ + df <- data()[[plot_dataname]] + df[[color_var]] <- as.character(df[[color_var]]) + + plot_data <- df %>% + group_by(!!as.name(y_var), !!as.name(color_var)) %>% + summarize(count = n_distinct(!!as.name(count_var)), .groups = "drop") + + event_type_order <- plot_data %>% + group_by(!!as.name(y_var)) %>% + summarize(total = sum(count)) %>% + arrange(total) %>% + pull(!!as.name(y_var)) + + plot_data[[y_var]] <- factor(plot_data[[y_var]], levels = event_type_order) + + p <- plot_ly( + data = plot_data, + y = as.formula(paste0("~", y_var)), + x = ~count, + color = as.formula(paste0("~", color_var)), + colors = bar_colors, + type = "bar", + orientation = "h" + ) %>% + layout( + barmode = "stack", + xaxis = list(title = "Count"), + yaxis = list(title = "Adverse Event Type"), + legend = list(title = list(text = "AE Type")) + ) + + p + }) + + + output$plot <- plotly::renderPlotly({ + p <- plotly_q() + plotly::event_register(p, "plotly_selected") + p + }) + }) +} diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R new file mode 100644 index 000000000..35ed7c90a --- /dev/null +++ b/R/tm_p_lineplot.R @@ -0,0 +1,91 @@ +#' @export +tm_p_lineplot <- function(label = "Line Plot", + plot_dataname, + x_var, + y_var, + transformators = list()) { + module( + label = label, + ui = ui_p_lineplot, + server = srv_p_lineplot, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + x_var = x_var, + y_var = y_var + ), + transformators = transformators + ) +} + +ui_p_lineplot <- function(id) { + ns <- NS(id) + bslib::page_fluid( + tags$div( + # trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ) +} + +srv_p_lineplot <- function(id, data, plot_dataname, x_var, y_var) { + moduleServer(id, function(input, output, session) { + plotly_q <- reactive({ + df <- data()[[plot_dataname]] + + validate(need(nrow(df) > 0, "No data after applying filters.")) + + # TODO: implement the high/low lines with annotations + y_low_last <- if ("si_low" %in% names(df)) utils::tail(stats::na.omit(df[["si_low"]]), 1) else NA + y_high_last <- if ("si_high" %in% names(df)) utils::tail(stats::na.omit(df[["si_high"]]), 1) else NA + + p <- plotly::plot_ly(data = df, x = df[[x_var]]) |> + plotly::add_trace( + y = df[[y_var]], + mode = "lines+markers", type = "scatter", name = "Lab Result", + line = list(color = "green"), + marker = list(color = "green"), + showlegend = FALSE + ) |> + # plotly::add_trace( + # y = df[["si_low"]], + # mode = "lines", + # line = list(color = "red", dash = "dash"), + # showlegend = FALSE + # ) |> + # plotly::add_annotations( + # x = max(df[[x_var]], na.rm = TRUE), + # y = y_low_last, + # yshift = 15, + # text = "Original LLN", + # showarrow = FALSE + # ) |> + # plotly::add_trace( + # y = df[["si_high"]], + # mode = "lines", + # line = list(color = "red", dash = "solid"), + # showlegend = FALSE + # ) |> + # plotly::add_annotations( + # x = max(df[[x_var]], na.rm = TRUE), + # y = y_high_last, + # yshift = -15, + # text = "Original ULN", + # showarrow = FALSE + # ) |> + plotly::layout( + xaxis = list(title = "Study Day of Sample Collection", zeroline = FALSE), + yaxis = list(title = "Original Result") + ) + + p + }) + + + output$plot <- plotly::renderPlotly({ + p <- plotly_q() + plotly::event_register(p, "plotly_selected") + p + }) + }) +} From 9ad1397deac00d9ce0e0f74d5cc7a8bf31300332 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 11:48:22 +0530 Subject: [PATCH 101/158] fix: add pkg namespace --- R/tm_p_bargraph.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 9812f7183..ed65d7af1 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -51,7 +51,7 @@ srv_p_bargraph <- function(id, data, plot_dataname, y_var, color_var, count_var, plot_data[[y_var]] <- factor(plot_data[[y_var]], levels = event_type_order) - p <- plot_ly( + p <- plotly::plot_ly( data = plot_data, y = as.formula(paste0("~", y_var)), x = ~count, @@ -60,7 +60,7 @@ srv_p_bargraph <- function(id, data, plot_dataname, y_var, color_var, count_var, type = "bar", orientation = "h" ) %>% - layout( + plotly::layout( barmode = "stack", xaxis = list(title = "Count"), yaxis = list(title = "Adverse Event Type"), From 1a42f2a7bc0a0c6e40fa9e70c2f4f61a3a6de557 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 12:56:59 +0530 Subject: [PATCH 102/158] fix: move filter out of args into transformators --- R/tm_p_scatterplot.R | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index afcb451a3..7dcc5afb5 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -6,7 +6,8 @@ tm_p_scatterplot <- function(label = "Scatter Plot", y_var, color_var, filter_var, - point_colors = character(0)) { + point_colors = character(0), + transformators = list()) { module( label = label, ui = ui_p_scatterplot, @@ -20,7 +21,8 @@ tm_p_scatterplot <- function(label = "Scatter Plot", color_var = color_var, filter_var = filter_var, point_colors = point_colors - ) + ), + transformators = transformators ) } @@ -28,7 +30,6 @@ ui_p_scatterplot <- function(id) { ns <- NS(id) bslib::page_sidebar( sidebar = div( - shinyWidgets::pickerInput(ns("event_type"), label = "Select Event Type", choices = NULL), colour_picker_ui(ns("colors")) ), tags$div( @@ -53,13 +54,6 @@ srv_p_scatterplot <- function(id, filter_var, point_colors) { moduleServer(id, function(input, output, session) { - observeEvent(data(), { - shinyWidgets::updatePickerInput( - session, "event_type", - choices = unique(data()[[plot_dataname]][[filter_var]]) - ) - }) - color_inputs <- colour_picker_srv( "colors", x = reactive({ @@ -69,7 +63,7 @@ srv_p_scatterplot <- function(id, ) plotly_q <- reactive({ - req(input$event_type, color_inputs()) + req(color_inputs()) within( data(), filter_var = str2lang(filter_var), @@ -80,7 +74,6 @@ srv_p_scatterplot <- function(id, colors = color_inputs(), expr = { plot_data <- scatterplot_ds |> - dplyr::filter(filter_var == input_event_type) |> dplyr::select(subject_var, x_var, y_var, color_var) |> dplyr::mutate(color_var = factor(color_var, levels = names(colors))) p <- plotly::plot_ly( @@ -94,8 +87,7 @@ srv_p_scatterplot <- function(id, ) |> plotly::layout(dragmode = "select") p() - }, - input_event_type = input$event_type + } ) }) From d2b2ff0011ee879193b45099798c64d4f321b8a5 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 18:37:10 +0530 Subject: [PATCH 103/158] feat: add lines to the scatterplot --- R/tm_p_scatterplot.R | 20 ++++++++++++++++++-- R/utils.R | 1 + 2 files changed, 19 insertions(+), 2 deletions(-) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 7dcc5afb5..47ea3e222 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -30,6 +30,7 @@ ui_p_scatterplot <- function(id) { ns <- NS(id) bslib::page_sidebar( sidebar = div( + bslib::input_switch(ns("add_lines"), "Add lines", value = FALSE), colour_picker_ui(ns("colors")) ), tags$div( @@ -72,6 +73,7 @@ srv_p_scatterplot <- function(id, y_var = str2lang(y_var), color_var = str2lang(color_var), colors = color_inputs(), + add_lines = input$add_lines, expr = { plot_data <- scatterplot_ds |> dplyr::select(subject_var, x_var, y_var, color_var) |> @@ -83,10 +85,24 @@ srv_p_scatterplot <- function(id, color = ~color_var, colors = colors, mode = "markers", - type = "scatter" + type = "scatter", + source = "scatterplot" ) |> plotly::layout(dragmode = "select") - p() + + if (add_lines) { + p <- p %>% + plotly::add_trace( + x = ~x_var, + y = ~y_var, + split = ~subject_var, + mode = "lines", + line = list(color = "grey"), + showlegend = FALSE, + inherit = FALSE + ) + } + p } ) }) diff --git a/R/utils.R b/R/utils.R index a5a9d07d8..8a596926b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -485,6 +485,7 @@ setup_trigger_tooltips <- function(plot, ns) { #' @keywords internal #' @noRd set_plot_data <- function(plot, data_id) { + # Make sure to have a `customdata` column in the dataset and pass it to `plotly::plot_ly`. htmlwidgets::onRender( plot, paste0( From 0613aeac29484ac8d8094f194a0b5984fa244a5e Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 18:44:51 +0530 Subject: [PATCH 104/158] fix: fix error when `sort_var` is not specified in `tm_p_swimlane` --- R/tm_p_swimlane.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index f74798ec5..0c938eda9 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -79,7 +79,7 @@ tm_p_swimlane <- function(label = "Swimlane", subject_var, color_var, group_var, - sort_var = NULL, + sort_var = time_var, tooltip_vars = NULL, point_size = 10, point_colors = character(0), @@ -160,7 +160,7 @@ srv_p_swimlane <- function(id, subject_var, color_var, group_var, - sort_var = time_var, + sort_var, point_size = 10, point_colors, point_symbols, From 620f74f7d1883e04e688d351570aba585100488c Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 18:55:09 +0530 Subject: [PATCH 105/158] chore: remove subject selection tooltip --- R/tm_p_swimlane.R | 36 +----------------------------------- 1 file changed, 1 insertion(+), 35 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 0c938eda9..0e724770b 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -137,9 +137,7 @@ ui_p_swimlane <- function(id, height) { selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]), - selectInput(ns("subjects"), "Subjects", choices = NULL, selected = NULL, multiple = TRUE), - actionButton(ns("subject_tooltips"), "Show Subject Tooltips") + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), tags$div( bslib::card( @@ -341,25 +339,6 @@ srv_p_swimlane <- function(id, plotly::event_data("plotly_selected", source = "swimlane") }) - observeEvent(input$subject_tooltips, { - hovervalues <- data()[[plot_dataname]] |> - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::filter(!!rlang::sym(input$subject_var) %in% input$subjects) |> - dplyr::pull(customdata) - - - hovertips <- plotly_data() |> - dplyr::filter(customdata %in% hovervalues) - - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = session$ns("plot"), - tooltipPoints = jsonlite::toJSON(hovertips) - ) - ) - }) - tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, @@ -369,19 +348,6 @@ srv_p_swimlane <- function(id, children_datanames = table_datanames ) - - observeEvent(data(), { - if (class(subject_var) == "choices_selected") { - subject_col <- subject_var$selected - } else { - subject_col <- subject_var - } - updateSelectInput( - inputId = "subjects", - choices = data()[[plot_dataname]][[subject_col]] - ) - }) - srv_t_reactables( "subtables", data = tables_selected_q, From 7acd61802a4c953584bd4f600c9c1ee8651980e2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 2 Sep 2025 19:13:20 +0530 Subject: [PATCH 106/158] chore: remove print --- R/utils.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 8a596926b..f81d8087e 100644 --- a/R/utils.R +++ b/R/utils.R @@ -456,7 +456,6 @@ setup_trigger_tooltips <- function(plot, ns) { paste0( "function(el) { const targetDiv = document.querySelector('#", ns("plot"), " .modebar-group:nth-child(4)'); - console.log(el.data); if (targetDiv) { const button = document.createElement('button'); button.setAttribute('data-count', '0'); From 2cc3595fdb57b5e60bcf5c14652cce96440e05c1 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 3 Sep 2025 12:30:05 +0530 Subject: [PATCH 107/158] docs: add func docs --- man/tm_p_spiderplot.Rd | 125 +++++++++++++++++++++++++++++++++++++++++ man/tm_p_swimlane.Rd | 113 +++++++++++++++++++++++++++++++++++++ man/tm_p_waterfall.Rd | 100 +++++++++++++++++++++++++++++++++ 3 files changed, 338 insertions(+) create mode 100644 man/tm_p_spiderplot.Rd create mode 100644 man/tm_p_swimlane.Rd create mode 100644 man/tm_p_waterfall.Rd diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd new file mode 100644 index 000000000..4fa8ad53e --- /dev/null +++ b/man/tm_p_spiderplot.Rd @@ -0,0 +1,125 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_spiderplot.R +\name{tm_p_spiderplot} +\alias{tm_p_spiderplot} +\title{\code{teal} module: Spider Plot} +\usage{ +tm_p_spiderplot( + label = "Spiderplot", + plot_dataname, + time_var, + value_var, + subject_var, + color_var, + filter_event_var, + size_var = NULL, + tooltip_vars = NULL, + point_colors = character(0), + point_symbols = character(0), + plot_height = c(600, 400, 1200), + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} + +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as x-axis.} + +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as y-axis.} + +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} + +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used to differentiate colors and symbols.} + +\item{filter_event_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used to filter the data. +The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu.} + +\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} +will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + +\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var}column.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} +} +\description{ +Module visualizes value development in time grouped by subjects. +} +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + swimlane_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = sample(1:100, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + + spiderplot_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = 1:10, + filter_event_var = "response", + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), + value_var = sample(-50:100, 10, replace = TRUE) + ) + + waterfall_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + value_var = sample(-20:90, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_p_spiderplot( + plot_dataname = "spiderplot_ds", + table_datanames = "subjects", + time_var = "time_var", + value_var = "value_var", + subject_var = "subject_var", + filter_event_var = "filter_event_var", + color_var = "color_var", + point_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ), + point_symbols = c( + CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd new file mode 100644 index 000000000..8527f3b81 --- /dev/null +++ b/man/tm_p_swimlane.Rd @@ -0,0 +1,113 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_swimlane.R +\name{tm_p_swimlane} +\alias{tm_p_swimlane} +\title{\code{teal} module: Swimlane plot} +\usage{ +tm_p_swimlane( + label = "Swimlane", + plot_dataname, + time_var, + subject_var, + color_var, + group_var, + sort_var = time_var, + tooltip_vars = NULL, + point_size = 10, + point_colors = character(0), + point_symbols = character(0), + plot_height = c(700, 400, 1200), + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} + +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as x-axis.} + +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as y-axis.} + +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to name and color subject events in time.} + +\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to categorize type of event. +(legend is sorted according to this variable, and used in toolip to display type of the event) +todo: this can be fixed by ordering factor levels} + +\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which +value determines order of the subjects displayed on the y-axis.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + +\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. +If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} + +\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} +} +\description{ +Module visualizes subjects' events in time. +} +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + swimlane_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = sample(1:100, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_p_swimlane( + plot_dataname = "swimlane_ds", + table_datanames = "subjects", + time_var = "time_var", + subject_var = "subject_var", + color_var = "color_var", + group_var = "color_var", + sort_var = "time_var", + plot_height = 400, + point_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ), + point_symbols = c( + CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd new file mode 100644 index 000000000..20eb27aae --- /dev/null +++ b/man/tm_p_waterfall.Rd @@ -0,0 +1,100 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_waterfall.R +\name{tm_p_waterfall} +\alias{tm_p_waterfall} +\title{\code{teal} module: Waterfall plot} +\usage{ +tm_p_waterfall( + label = "Waterfall", + plot_dataname, + subject_var, + value_var, + sort_var = NULL, + color_var = NULL, + tooltip_vars = NULL, + bar_colors = character(0), + value_arbitrary_hlines = c(0.2, -0.3), + plot_title = "Waterfall plot", + plot_height = c(600, 400, 1200), + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} + +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as x-axis.} + +\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as y-axis.} + +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to be used to differentiate bar colors.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + +\item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal +lines on the plot.} + +\item{plot_title}{(\code{character}) Title of the plot.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} +} +\description{ +Module visualizes subjects sorted decreasingly by y-values. +} +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + waterfall_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + value_var = sample(-20:90, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_p_waterfall( + plot_dataname = "waterfall_ds", + table_datanames = "subjects", + subject_var = "subject_var", + value_var = "value_var", + sort_var = "value_var", + color_var = "color_var", + value_arbitrary_hlines = c(20, -30), + bar_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} From 624bbd7f382f0bf55318e6edcca5666661455902 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 3 Sep 2025 21:30:12 +0530 Subject: [PATCH 108/158] fix: remove unwanted data grouping --- R/tm_p_swimlane.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 0e724770b..62f6514ce 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -239,7 +239,6 @@ srv_p_swimlane <- function(id, dplyr::mutate( !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), ) %>% - dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( tooltip = { default_tip <- paste( From 4889032652a1b8ca220f1419de2bffe26b9cb58c Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 3 Sep 2025 21:43:15 +0530 Subject: [PATCH 109/158] fix: ungroup before plot --- R/tm_p_swimlane.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 62f6514ce..effa234f1 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -239,6 +239,7 @@ srv_p_swimlane <- function(id, dplyr::mutate( !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), ) %>% + dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( tooltip = { default_tip <- paste( @@ -275,6 +276,7 @@ srv_p_swimlane <- function(id, } } ) %>% + dplyr::ungroup() %>% plotly::plot_ly( source = "swimlane", colors = colors, From 0be199b45cafc441a6a52b3bcff3acbda67f7cff Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 3 Sep 2025 22:23:57 +0530 Subject: [PATCH 110/158] fix: retain the labels for grouped vars and color var --- R/tm_p_swimlane.R | 26 ++++++++++++++++++++++---- 1 file changed, 22 insertions(+), 4 deletions(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index effa234f1..8d4f304af 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -184,7 +184,6 @@ srv_p_swimlane <- function(id, plotly_q <- reactive({ req(data(), input$time_var, input$subject_var, input$color_var, input$group_var, input$sort_var, color_inputs()) - print(input$subject_var) adjusted_symbols <- .shape_palette_discrete( levels = unique(data()[[plot_dataname]][[input$color_var]]), symbol = point_symbols @@ -237,7 +236,15 @@ srv_p_swimlane <- function(id, p <- plot_data %>% dplyr::mutate( - !!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors)), + !!as.name(color_var) := { + # Store the original label + original_label <- attr(.data[[color_var]], "label") + # Create the factor + new_factor <- factor(.data[[color_var]], levels = names(colors)) + # Restore the label + attr(new_factor, "label") <- original_label + new_factor + } ) %>% dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% dplyr::mutate( @@ -259,14 +266,25 @@ srv_p_swimlane <- function(id, if (is.null(tooltip_vars)) { default_tip } else { - cur_data <- dplyr::pick(dplyr::everything()) + cur_data <- dplyr::cur_data() + grouping_vars <- list() + grouping_vars[[subject_var]] <- dplyr::cur_group()[[subject_var]] + grouping_vars[[time_var]] <- dplyr::cur_group()[[time_var]] + cur_data <- c(cur_data, grouping_vars) + cols <- intersect(tooltip_vars, names(cur_data)) if (!length(cols)) { default_tip } else { sub <- cur_data[cols] labels <- vapply(cols, function(cn) { - lb <- attr(sub[[cn]], "label") + if (cn == subject_var) { + lb <- subject_var_label + } else if (cn == time_var) { + lb <- time_var_label + } else { + lb <- attr(sub[[cn]], "label") + } if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn }, character(1)) values <- lapply(sub, as.character) From 1e5be8090fc91a0ba1a4627d6516c9ca55c1a288 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 Sep 2025 18:52:13 +0530 Subject: [PATCH 111/158] feat: add a poc of a module that uses multiple modules --- R/module_colur_picker.R | 6 ++-- R/tm_p_lineplot.R | 8 +++-- R/tm_p_scatterlineplot.R | 63 ++++++++++++++++++++++++++++++++++++++++ R/tm_p_scatterplot.R | 40 ++++++++++++++++++------- 4 files changed, 100 insertions(+), 17 deletions(-) create mode 100644 R/tm_p_scatterlineplot.R diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 137deed1e..06fbe2b94 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -2,9 +2,9 @@ colour_picker_ui <- function(id) { ns <- NS(id) - bslib::accordion( - uiOutput(ns("module"), title = "Event colors:", container = bslib::accordion_panel), - open = FALSE + bslib::popover( + actionButton(ns("toggle"), "Edit colors"), + uiOutput(ns("module")) ) } diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index 35ed7c90a..d352ac2bc 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -3,6 +3,7 @@ tm_p_lineplot <- function(label = "Line Plot", plot_dataname, x_var, y_var, + group_var, transformators = list()) { module( label = label, @@ -12,7 +13,8 @@ tm_p_lineplot <- function(label = "Line Plot", server_args = list( plot_dataname = plot_dataname, x_var = x_var, - y_var = y_var + y_var = y_var, + group_var = group_var ), transformators = transformators ) @@ -28,7 +30,7 @@ ui_p_lineplot <- function(id) { ) } -srv_p_lineplot <- function(id, data, plot_dataname, x_var, y_var) { +srv_p_lineplot <- function(id, data, plot_dataname, x_var, y_var, group_var) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ df <- data()[[plot_dataname]] @@ -39,7 +41,7 @@ srv_p_lineplot <- function(id, data, plot_dataname, x_var, y_var) { y_low_last <- if ("si_low" %in% names(df)) utils::tail(stats::na.omit(df[["si_low"]]), 1) else NA y_high_last <- if ("si_high" %in% names(df)) utils::tail(stats::na.omit(df[["si_high"]]), 1) else NA - p <- plotly::plot_ly(data = df, x = df[[x_var]]) |> + p <- plotly::plot_ly(data = df |> dplyr::group_by(!!sym(group_var)), x = df[[x_var]]) |> plotly::add_trace( y = df[[y_var]], mode = "lines+markers", type = "scatter", name = "Lab Result", diff --git a/R/tm_p_scatterlineplot.R b/R/tm_p_scatterlineplot.R new file mode 100644 index 000000000..dfea2c490 --- /dev/null +++ b/R/tm_p_scatterlineplot.R @@ -0,0 +1,63 @@ +#' @export +tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + point_colors = character(0), + transformators = list()) { + module( + label = label, + ui = ui_p_scatterlineplot, + server = srv_p_scatterlineplot, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + subject_var = subject_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + point_colors = point_colors + ), + transformators = transformators + ) +} + +ui_p_scatterlineplot <- function(id) { + ns <- NS(id) + bslib::page_fluid( + ui_p_scatterplot(ns("scatter")), + ui_p_lineplot(ns("line")) + ) +} + +srv_p_scatterlineplot <- function(id, + data, + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + point_colors) { + moduleServer(id, function(input, output, session) { + plot_q <- srv_p_scatterplot( + "scatter", + data = data, + plot_dataname = plot_dataname, + subject_var = subject_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + point_colors = point_colors + ) + srv_p_lineplot( + "line", + data = plot_q, + plot_dataname = plot_dataname, + x_var = x_var, + y_var = y_var, + group_var = subject_var + ) + }) +} diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 47ea3e222..ace5fec92 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -5,7 +5,6 @@ tm_p_scatterplot <- function(label = "Scatter Plot", x_var, y_var, color_var, - filter_var, point_colors = character(0), transformators = list()) { module( @@ -19,7 +18,6 @@ tm_p_scatterplot <- function(label = "Scatter Plot", x_var = x_var, y_var = y_var, color_var = color_var, - filter_var = filter_var, point_colors = point_colors ), transformators = transformators @@ -28,12 +26,16 @@ tm_p_scatterplot <- function(label = "Scatter Plot", ui_p_scatterplot <- function(id) { ns <- NS(id) - bslib::page_sidebar( - sidebar = div( - bslib::input_switch(ns("add_lines"), "Add lines", value = FALSE), - colour_picker_ui(ns("colors")) - ), + bslib::page_fluid( tags$div( + shinyWidgets::prettySwitch( + ns("add_lines"), + label = "Add lines", + status = "primary", + slim = TRUE, + inline = TRUE + ), + colour_picker_ui(ns("colors")), bslib::card( full_screen = TRUE, tags$div( @@ -52,7 +54,6 @@ srv_p_scatterplot <- function(id, x_var, y_var, color_var, - filter_var, point_colors) { moduleServer(id, function(input, output, session) { color_inputs <- colour_picker_srv( @@ -67,7 +68,6 @@ srv_p_scatterplot <- function(id, req(color_inputs()) within( data(), - filter_var = str2lang(filter_var), subject_var = str2lang(subject_var), x_var = str2lang(x_var), y_var = str2lang(y_var), @@ -77,11 +77,13 @@ srv_p_scatterplot <- function(id, expr = { plot_data <- scatterplot_ds |> dplyr::select(subject_var, x_var, y_var, color_var) |> - dplyr::mutate(color_var = factor(color_var, levels = names(colors))) + dplyr::mutate(color_var = factor(color_var, levels = names(colors))) |> + dplyr::mutate(customdata = dplyr::row_number()) p <- plotly::plot_ly( data = plot_data, x = ~x_var, y = ~y_var, + customdata = ~customdata, color = ~color_var, colors = colors, mode = "markers", @@ -111,9 +113,25 @@ srv_p_scatterplot <- function(id, output$plot <- plotly::renderPlotly(plotly::event_register( { plotly_q()$p |> - setup_trigger_tooltips(session$ns) + setup_trigger_tooltips(session$ns) |> + set_plot_data(session$ns("plot_data")) }, "plotly_selected" )) + + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "scatterplot")) + reactive({ + req(plotly_selected()) + plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + scatterplot_ds <- scatterplot_ds |> + filter(subject %in% selected_plot_data$subject) + }, + plotly_selected_customdata = plotly_selected()$customdata + ) + }) }) } From 8e338acdc7cd5f5fe755bdf0d838b7f50d6ee214 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 Sep 2025 19:01:05 +0530 Subject: [PATCH 112/158] feat: hide widgets using module arg --- NAMESPACE | 1 + R/tm_p_scatterplot.R | 15 ++++++++++++--- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index a4e70b7aa..688708b9b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -25,6 +25,7 @@ export(tm_missing_data) export(tm_outliers) export(tm_p_bargraph) export(tm_p_lineplot) +export(tm_p_scatterlineplot) export(tm_p_scatterplot) export(tm_p_spiderplot) export(tm_p_swimlane) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index ace5fec92..b2e5462ab 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -6,7 +6,8 @@ tm_p_scatterplot <- function(label = "Scatter Plot", y_var, color_var, point_colors = character(0), - transformators = list()) { + transformators = list(), + show_widgets = TRUE) { module( label = label, ui = ui_p_scatterplot, @@ -18,7 +19,8 @@ tm_p_scatterplot <- function(label = "Scatter Plot", x_var = x_var, y_var = y_var, color_var = color_var, - point_colors = point_colors + point_colors = point_colors, + show_widgets = show_widgets ), transformators = transformators ) @@ -27,6 +29,7 @@ tm_p_scatterplot <- function(label = "Scatter Plot", ui_p_scatterplot <- function(id) { ns <- NS(id) bslib::page_fluid( + shinyjs::useShinyjs(), tags$div( shinyWidgets::prettySwitch( ns("add_lines"), @@ -54,7 +57,8 @@ srv_p_scatterplot <- function(id, x_var, y_var, color_var, - point_colors) { + point_colors, + show_widgets) { moduleServer(id, function(input, output, session) { color_inputs <- colour_picker_srv( "colors", @@ -64,6 +68,11 @@ srv_p_scatterplot <- function(id, default_colors = point_colors ) + if (!show_widgets) { + shinyjs::hide("add_lines") + shinyjs::hide("colors") + } + plotly_q <- reactive({ req(color_inputs()) within( From e1449002ea4c74b95b1709c598433fa435808a63 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 Sep 2025 19:02:28 +0530 Subject: [PATCH 113/158] feat: hide widgets using module arg --- R/tm_p_scatterplot.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index b2e5462ab..10474137d 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -38,7 +38,7 @@ ui_p_scatterplot <- function(id) { slim = TRUE, inline = TRUE ), - colour_picker_ui(ns("colors")), + tags$span(id = ns("colors_span"), colour_picker_ui(ns("colors"))), bslib::card( full_screen = TRUE, tags$div( @@ -70,7 +70,7 @@ srv_p_scatterplot <- function(id, if (!show_widgets) { shinyjs::hide("add_lines") - shinyjs::hide("colors") + shinyjs::hide("colors_span") } plotly_q <- reactive({ From eb0f48901f9fc8344104e6c6481c1a73973dff05 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 Sep 2025 19:07:10 +0530 Subject: [PATCH 114/158] feat: hide widgets from the module --- R/tm_p_scatterlineplot.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/tm_p_scatterlineplot.R b/R/tm_p_scatterlineplot.R index dfea2c490..251f2297a 100644 --- a/R/tm_p_scatterlineplot.R +++ b/R/tm_p_scatterlineplot.R @@ -49,7 +49,8 @@ srv_p_scatterlineplot <- function(id, x_var = x_var, y_var = y_var, color_var = color_var, - point_colors = point_colors + point_colors = point_colors, + show_widgets = FALSE ) srv_p_lineplot( "line", From d660198776759cc9bc69a1aa887b2833d77276c5 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 4 Sep 2025 19:11:41 +0530 Subject: [PATCH 115/158] fix: add pkg prefix for code reproducibility --- R/tm_t_reactable.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index 25c4e300a..bba18b681 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -236,7 +236,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco as.call( c( list( - name = quote(reactable), + name = quote(reactable::reactable), data = str2lang(dataname) ), call_args From f9f5bf94ce5d11ab6a35360de0b7183a8699c87a Mon Sep 17 00:00:00 2001 From: Dony Unardi Date: Sun, 7 Sep 2025 07:15:02 +0000 Subject: [PATCH 116/158] only join when there's a record --- R/utils.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index f81d8087e..9f191abb9 100644 --- a/R/utils.R +++ b/R/utils.R @@ -409,7 +409,9 @@ children <- function(x, dataset_name = character(0)) { join_cols <- teal.data::join_keys(plotly_selected_q())[childname, plot_dataname] substitute( expr = { - childname <- dplyr::right_join(childname, swimlane_selected, by = by) + if (nrow(childname) > 0) { + childname <- dplyr::right_join(childname, swimlane_selected, by = by) + } }, list( childname = str2lang(childname), From 6bcd1f5f2d13850924de57b93b783acb7aaccf41 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 8 Sep 2025 16:43:00 +0530 Subject: [PATCH 117/158] feat: move table outside swimlane --- R/tm_p_swimlane.R | 104 +++++++++++------------- R/tm_p_swimlane_table.R | 175 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 222 insertions(+), 57 deletions(-) create mode 100644 R/tm_p_swimlane_table.R diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 8d4f304af..4301a092f 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -24,8 +24,6 @@ #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. -#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. -#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples #' data <- teal_data() |> @@ -51,7 +49,6 @@ #' modules = modules( #' tm_p_swimlane( #' plot_dataname = "swimlane_ds", -#' table_datanames = "subjects", #' time_var = "time_var", #' subject_var = "subject_var", #' color_var = "color_var", @@ -85,8 +82,7 @@ tm_p_swimlane <- function(label = "Swimlane", point_colors = character(0), point_symbols = character(0), plot_height = c(700, 400, 1200), - table_datanames = character(0), - reactable_args = list()) { + show_widgets = TRUE) { checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") if (is.character(time_var)) { @@ -108,7 +104,7 @@ tm_p_swimlane <- function(label = "Swimlane", label = label, ui = ui_p_swimlane, server = srv_p_swimlane, - datanames = c(plot_dataname, table_datanames), + datanames = c(plot_dataname), ui_args = list(height = plot_height), server_args = list( plot_dataname = plot_dataname, @@ -120,34 +116,38 @@ tm_p_swimlane <- function(label = "Swimlane", point_size = point_size, point_colors = point_colors, point_symbols = point_symbols, - table_datanames = table_datanames, - reactable_args = reactable_args, - tooltip_vars = tooltip_vars + tooltip_vars = tooltip_vars, + show_widgets = show_widgets ) ) } ui_p_swimlane <- function(id, height) { ns <- NS(id) - bslib::page_sidebar( - sidebar = div( - selectInput(ns("time_var"), label = "Time variable:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("subject_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), - colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) - ), + bslib::page_fluid( tags$div( + shinyjs::useShinyjs(), + tags$div( + id = ns("top_widgets"), + style = "display: flex;", + selectInput(ns("subject_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), + colour_picker_ui(ns("colors")), + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) + ), bslib::card( full_screen = TRUE, tags$div( trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") + plotly::plotlyOutput(ns("plot"), height = "100%"), ) ), - ui_t_reactables(ns("subtables")) + tags$div( + id = ns("bottom_widgets"), + selectInput(ns("time_var"), label = "Time variable:", choices = NULL, selected = NULL, multiple = FALSE) + ) ) ) } @@ -162,10 +162,9 @@ srv_p_swimlane <- function(id, point_size = 10, point_colors, point_symbols, - table_datanames, - reactable_args = list(), tooltip_vars = NULL, - filter_panel_api) { + filter_panel_api, + show_widgets) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) @@ -173,6 +172,11 @@ srv_p_swimlane <- function(id, .update_cs_input(inputId = "group_var", data = reactive(data()[[dataname]]), cs = group_var) .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) + if (!show_widgets) { + shinyjs::hide("top_widgets") + shinyjs::hide("bottom_widgets") + } + color_inputs <- colour_picker_srv( "colors", x = reactive({ @@ -334,44 +338,30 @@ srv_p_swimlane <- function(id, ) }) - output$plot <- plotly::renderPlotly(plotly::event_register( - { - plotly_q()$p |> - set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) - }, - "plotly_selected" - )) - - plotly_data <- reactive({ - data.frame( - x = unlist(input$plot_data$x), - y = unlist(input$plot_data$y), - customdata = unlist(input$plot_data$customdata), - curve = unlist(input$plot_data$curveNumber), - index = unlist(input$plot_data$pointNumber) - ) + output$plot <- plotly::renderPlotly({ + plotly_q()$p |> + set_plot_data(session$ns("plot_data")) |> + setup_trigger_tooltips(session$ns) |> + plotly::event_register("plotly_selected") }) plotly_selected <- reactive({ - plotly::event_data("plotly_deselect", source = "swimlane") # todo: deselect doesn't work plotly::event_data("plotly_selected", source = "swimlane") }) - tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, - plot_dataname = plot_dataname, - xvar = reactive(input$time_var), - yvar = reactive(input$subject_var), - plotly_selected = plotly_selected, - children_datanames = table_datanames - ) - - srv_t_reactables( - "subtables", - data = tables_selected_q, - datanames = table_datanames, - reactable_args = reactable_args - ) + reactive({ + req(plotly_selected()) + plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + dataname <- dataname |> + filter(subject %in% selected_plot_data$subject) + }, + dataname = str2lang(plot_dataname), + plotly_selected_customdata = plotly_selected()$customdata + ) + }) }) } diff --git a/R/tm_p_swimlane_table.R b/R/tm_p_swimlane_table.R new file mode 100644 index 000000000..9f63c700d --- /dev/null +++ b/R/tm_p_swimlane_table.R @@ -0,0 +1,175 @@ +#' `teal` module: Swimlane plot +#' +#' Module visualizes subjects' events in time. +#' +#' @inheritParams teal::module +#' @inheritParams shared_params +#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. +#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' in `plot_dataname` to be used as x-axis. +#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to be used as y-axis. +#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' in `plot_dataname` to name and color subject events in time. +#' @param group_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` +#' to categorize type of event. +#' (legend is sorted according to this variable, and used in toolip to display type of the event) +#' todo: this can be fixed by ordering factor levels +#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which +#' value determines order of the subjects displayed on the y-axis. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created. +#' @param point_size (`numeric(1)` or `named numeric`) Default point size of the points in the plot. +#' If `point_size` is a named numeric vector, it should be named by levels of `color_var` column. +#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named +#' by levels of `color_var` column. +#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. +#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. +#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' subjects <- data.frame( +#' subject_var = c("A", "B", "C"), +#' AGE = sample(30:100, 3), +#' ARM = c("Combination", "Combination", "Placebo") +#' ) +#' +#' swimlane_ds <- data.frame( +#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), +#' time_var = sample(1:100, 10, replace = TRUE), +#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) +#' ) +#' }) +#' join_keys(data) <- join_keys( +#' join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) +#' ) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_swimlane_table( +#' plot_dataname = "swimlane_ds", +#' table_datanames = "subjects", +#' time_var = "time_var", +#' subject_var = "subject_var", +#' color_var = "color_var", +#' group_var = "color_var", +#' sort_var = "time_var", +#' plot_height = 400, +#' point_colors = c( +#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' ), +#' point_symbols = c( +#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" +#' ) +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @export +tm_p_swimlane_table <- function(label = "Swimlane", + plot_dataname, + time_var, + subject_var, + color_var, + group_var, + sort_var = time_var, + tooltip_vars = NULL, + point_size = 10, + point_colors = character(0), + point_symbols = character(0), + plot_height = c(700, 400, 1200), + table_datanames = character(0), + reactable_args = list()) { + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + if (is.character(time_var)) { + time_var <- choices_selected(choices = time_var, selected = time_var) + } + if (is.character(subject_var)) { + subject_var <- choices_selected(choices = subject_var, selected = subject_var) + } + if (is.character(color_var)) { + color_var <- choices_selected(choices = color_var, selected = color_var) + } + if (is.character(group_var)) { + group_var <- choices_selected(choices = group_var, selected = group_var) + } + if (is.character(sort_var)) { + sort_var <- choices_selected(choices = sort_var, selected = sort_var) + } + module( + label = label, + ui = ui_p_swimlane_table, + server = srv_p_swimlane_table, + datanames = c(plot_dataname, table_datanames), + ui_args = list(height = plot_height), + server_args = list( + plot_dataname = plot_dataname, + time_var = time_var, + subject_var = subject_var, + color_var = color_var, + group_var = group_var, + sort_var = sort_var, + point_size = point_size, + point_colors = point_colors, + point_symbols = point_symbols, + table_datanames = table_datanames, + reactable_args = reactable_args, + tooltip_vars = tooltip_vars + ) + ) +} + +ui_p_swimlane_table <- function(id, height) { + ns <- NS(id) + bslib::page_fluid( + ui_p_swimlane(ns("swimlane"), height = height), + ui_t_reactables(ns("subtables")) + ) +} +srv_p_swimlane_table <- function(id, + data, + plot_dataname, + time_var, + subject_var, + color_var, + group_var, + sort_var, + point_size = 10, + point_colors, + point_symbols, + table_datanames, + reactable_args = list(), + tooltip_vars = NULL, + filter_panel_api) { + moduleServer(id, function(input, output, session) { + plot_q <- srv_p_swimlane( + "swimlane", + data = data, + plot_dataname = plot_dataname, + time_var = time_var, + subject_var = subject_var, + color_var = color_var, + group_var = group_var, + sort_var = sort_var, + point_size = point_size, + point_colors = point_colors, + point_symbols = point_symbols, + show_widgets = FALSE + ) + srv_t_reactables( + "subtables", + data = plot_q, + filter_panel_api = filter_panel_api, + datanames = table_datanames, + reactable_args = reactable_args + ) + }) +} From 66e980eb6caa37bf50429defa0468aa1e36b1699 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 9 Sep 2025 12:22:55 +0530 Subject: [PATCH 118/158] feat: apply filter logic for the table --- NAMESPACE | 1 + R/tm_p_swimlane.R | 3 ++- R/tm_p_swimlane_table.R | 20 +++++++++++++++++++- 3 files changed, 22 insertions(+), 2 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 688708b9b..fdafcf442 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,6 +29,7 @@ export(tm_p_scatterlineplot) export(tm_p_scatterplot) export(tm_p_spiderplot) export(tm_p_swimlane) +export(tm_p_swimlane_table) export(tm_p_waterfall) export(tm_rmarkdown) export(tm_t_crosstable) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 4301a092f..3d4b59c65 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -357,9 +357,10 @@ srv_p_swimlane <- function(id, selected_plot_data <- plot_data |> dplyr::filter(customdata %in% plotly_selected_customdata) dataname <- dataname |> - filter(subject %in% selected_plot_data$subject) + dplyr::filter(!!sym(subject_var) %in% selected_plot_data[[subject_var]]) }, dataname = str2lang(plot_dataname), + subject_var = input$subject_var, plotly_selected_customdata = plotly_selected()$customdata ) }) diff --git a/R/tm_p_swimlane_table.R b/R/tm_p_swimlane_table.R index 9f63c700d..3c89000b3 100644 --- a/R/tm_p_swimlane_table.R +++ b/R/tm_p_swimlane_table.R @@ -164,9 +164,27 @@ srv_p_swimlane_table <- function(id, point_symbols = point_symbols, show_widgets = FALSE ) + + filtered_data_q <- reactive({ + req(plot_q()) + plot_q() |> + within( + { + table_names <- c("recist_listing") + for (table_name in table_names) { + current_table <- get(table_name) + filtered_table <- current_table |> + dplyr::filter(!!sym(subject_var) %in% plot_dataname[[subject_var]]) + assign(table_name, filtered_table) + } + }, + plot_dataname = str2lang(plot_dataname), + subject_var = subject_var$selected + ) + }) srv_t_reactables( "subtables", - data = plot_q, + data = filtered_data_q, filter_panel_api = filter_panel_api, datanames = table_datanames, reactable_args = reactable_args From cb5e7256519018bca5f11d31b88cc1a97cebce5b Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 11 Sep 2025 14:07:27 +0200 Subject: [PATCH 119/158] spiderplot with `picks` --- R/tm_p_spiderplot.R | 316 ++++++++++++++++++----------------------- man/tm_p_spiderplot.Rd | 47 +++--- 2 files changed, 167 insertions(+), 196 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index d8c10a04d..63d308e26 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -4,29 +4,24 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' @param time_var (`character(1)` or `variables`) name of the `numeric` column #' in `plot_dataname` to be used as x-axis. -#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column +#' @param value_var (`character(1)` or `variables`) name of the `numeric` column #' in `plot_dataname` to be used as y-axis. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column +#' @param subject_var (`character(1)` or `variables`) name of the `factor` or `character` column #' in `plot_dataname` to be used as grouping variable for displayed lines/points. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` +#' @param color_var (`character(1)` or `variables`) name of the `factor` or `character` column in `plot_dataname` #' to be used to differentiate colors and symbols. -#' @param filter_event_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to be used to filter the data. -#' The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu. -#' @param size_var (`character(1)` or `NULL`) If provided, this numeric column from the `plot_dataname` +#' @param size_var (`character(1)` or `variables` or `NULL`) If provided, this numeric column from the `plot_dataname` #' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. #' If `NULL`, default tooltip is created. #' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named #' by levels of `color_var` column. #' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var`column. -#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. -#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples +#' library(teal.transform) #' data <- teal_data() |> #' within({ #' subjects <- data.frame( @@ -65,11 +60,17 @@ #' tm_p_spiderplot( #' plot_dataname = "spiderplot_ds", #' table_datanames = "subjects", -#' time_var = "time_var", -#' value_var = "value_var", -#' subject_var = "subject_var", -#' filter_event_var = "filter_event_var", -#' color_var = "color_var", +#' time_var = picks(datasets("spiderplot_ds"), variables("time_var")), +#' value_var = picks(datasets("spiderplot_ds"), variables("value_var")), +#' subject_var = picks(datasets("spiderplot_ds"), variables("subject_var")), +#' color_var = picks(datasets("spiderplot_ds"), variables("color_var")), +#' transformators = list( +#' teal_transform_filter( +#' picks( +#' datasets("spiderplot_ds"), variables("filter_event_var"), values() +#' ) +#' ) +#' ), #' point_colors = c( #' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" #' ), @@ -79,6 +80,7 @@ #' ) #' ) #' ) + #' #' if (interactive()) { #' shinyApp(app$ui, app$server) @@ -86,79 +88,75 @@ #' #' @export tm_p_spiderplot <- function(label = "Spiderplot", - plot_dataname, time_var, value_var, subject_var, color_var, - filter_event_var, size_var = NULL, tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list()) { - if (is.character(time_var)) { - time_var <- choices_selected(choices = time_var, selected = time_var) - } - if (is.character(value_var)) { - value_var <- choices_selected(choices = value_var, selected = value_var) - } - if (is.character(subject_var)) { - subject_var <- choices_selected(choices = subject_var, selected = subject_var) - } - if (is.character(color_var)) { - color_var <- choices_selected(choices = color_var, selected = color_var) - } - if (is.character(filter_event_var)) { - filter_event_var <- choices_selected(choices = filter_event_var, selected = filter_event_var) - } + transformators = list(), + decorators = list()) { + # todo: filter_event_var shouldn't in arguments as it is not a dimension of the plot + # title based on arbitrary filter is not an accepted solution. + # additional filters should be passed to trasformers + checkmate::assert_string(label) + checkmate::assert_class(time_var, "picks") + checkmate::assert_class(subject_var, "picks") + checkmate::assert_class(color_var, "picks") + checkmate::assert_class(size_var, "picks", null.ok = TRUE) + args <- as.list(environment()) module( label = label, ui = ui_p_spiderplot, server = srv_p_spiderplot, - ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - time_var = time_var, - value_var = value_var, - subject_var = subject_var, - filter_event_var = filter_event_var, - color_var = color_var, - size_var = size_var, - point_colors = point_colors, - point_symbols = point_symbols, - table_datanames = table_datanames, - reactable_args = reactable_args, - tooltip_vars = tooltip_vars - ), - datanames = union(plot_dataname, table_datanames) + ui_args = args[names(args) %in% names(formals(ui_p_spiderplot))], + server_args = args[names(args) %in% names(formals(srv_p_spiderplot))], + transformators = transformators, + datanames = { + datanames <- datanames( + list( + time_var = time_var, value_var = value_var, subject_var = subject_var, + color_var = color_var, size_var = size_var + ) + ) + if (length(datanames)) datanames else "all" + } ) } - -ui_p_spiderplot <- function(id, height) { +ui_p_spiderplot <- function(id, time_var, value_var, subject_var, color_var, size_var, plot_height, decorators) { ns <- NS(id) bslib::page_sidebar( sidebar = div( - selectInput(ns("time_var"), label = "Time variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE), - selectInput( - ns("value_var"), - label = "Value variable (y-axis):", - choices = NULL, selected = NULL, multiple = FALSE + class = "standard-layout encoding-panel", + teal::teal_nav_item( + label = tags$strong("Time variable (x-axis):"), + teal.transform::module_input_ui(id = ns("time_var"), spec = time_var) + ), + teal::teal_nav_item( + label = tags$strong("Value variable (y-axis):"), + teal.transform::module_input_ui(id = ns("value_var"), spec = value_var) + ), + teal::teal_nav_item( + label = tags$strong("Subject variable:"), + teal.transform::module_input_ui(id = ns("subject_var"), spec = subject_var) ), - selectInput(ns("subject_var"), label = "Subject variable:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("filter_event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("filter_event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), - colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]), - selectInput(ns("subjects"), "Subjects", choices = NULL, selected = NULL, multiple = TRUE), - actionButton(ns("subject_tooltips"), "Show Subject Tooltips") + teal::teal_nav_item( + label = tags$strong("Color by:"), + teal.transform::module_input_ui(id = ns("color_var"), spec = color_var) + ), + if (!is.null(size_var)) { + colour_picker_ui(ns("colors")) + }, + ui_decorate_teal_data(ns("decorator"), decorators = decorators), + sliderInput(ns("plot_height"), "Plot Height (px)", plot_height[2], plot_height[3], plot_height[1]) ), tags$div( + class = "standard-layout output-panel", bslib::card( full_screen = TRUE, tags$div( @@ -173,95 +171,91 @@ ui_p_spiderplot <- function(id, height) { srv_p_spiderplot <- function(id, data, - plot_dataname, time_var, value_var, subject_var, - filter_event_var, color_var, + size_var = NULL, + tooltip_vars = NULL, point_colors, point_symbols, - size_var = NULL, plot_height = 600, - table_datanames = character(0), - reactable_args = list(), - tooltip_vars = NULL, + decorators = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { - .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) - .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) - .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) - .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) - .update_cs_input(inputId = "filter_event_var", data = reactive(data()[[dataname]]), cs = filter_event_var) - - filter_event_var_levels <- reactive({ - req(data(), input$filter_event_var) - # comment: - # i don't know if it makes sense. I think it will be rare that dataset would have multiple - # category variables. There would rather be another dataset (consider responses, interventions etc.) - unique(data()[[plot_dataname]][[input$filter_event_var]]) - }) - observeEvent(filter_event_var_levels(), { - label <- attr(data()[[plot_dataname]][[input$filter_event_var]], "label") - updateSelectInput( - inputId = "filter_event_var_level", - label = sprintf("Select %s:", if (length(label)) label else "en event:"), - choices = filter_event_var_levels(), - selected = filter_event_var_levels()[1] + selectors <- teal.transform::module_input_srv( + data = data, + spec = list( + time_var = time_var, value_var = value_var, subject_var = subject_var, + color_var = color_var, size_var = size_var ) - if (length(filter_event_var_levels()) < 2) shinyjs::hide("filter_event_var_level") - }) + ) color_inputs <- colour_picker_srv( "colors", x = reactive({ - req(input$color_var) - data()[[plot_dataname]][[input$color_var]] + selected_color <- req(map_merged(selectors)$color_var) + data()[[selected_color$datasets]][[selected_color$variables]] }), default_colors = point_colors ) - plotly_q <- reactive({ - req( - input$filter_event_var_level, input$time_var, input$value_var, - input$subject_var, input$filter_event_var, input$color_var, color_inputs() + merged_q <- reactive({ + req(data(), map_merged(selectors)) + obj <- data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spiderplot data preparation") + qenv_merge_selectors(x = obj, selectors = selectors, output_name = "anl") + }) + + plot_data_q <- reactive({ + obj <- req(merged_q()) + within(obj, + { + anl <- anl %>% + dplyr::mutate(customdata = dplyr::row_number()) %>% + dplyr::arrange(subject_var_lang, time_var_lang) %>% + dplyr::group_by(subject_var_lang) + }, + subject_var_lang = str2lang(map_merged(selectors)$subject_var$variables), + time_var_lang = str2lang(map_merged(selectors)$time_var$variables) ) + }) + output_q <- reactive({ + obj <- req(plot_data_q()) + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spiderplot Visualization") adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[plot_dataname]][[input$color_var]]), + levels = unique(obj$anl[[map_merged(selectors)$color_var$variables]]), symbol = point_symbols ) within( - data(), - dataname = str2lang(plot_dataname), - filter_event_var_lang = str2lang(input$filter_event_var), - time_var = input$time_var, - value_var = input$value_var, - subject_var = input$subject_var, - filter_event_var = input$filter_event_var, - selected_event = input$filter_event_var_level, - color_var = input$color_var, + obj, + dataname = str2lang("anl"), + time_var_lang = str2lang(map_merged(selectors)$time_var$variables), + value_var_lang = str2lang(map_merged(selectors)$value_var$variables), + subject_var_lang = str2lang(map_merged(selectors)$subject_var$variables), + color_var_lang = str2lang(map_merged(selectors)$color_var$variables), + time_var = map_merged(selectors)$time_var$variables, + value_var = map_merged(selectors)$value_var$variables, + subject_var = map_merged(selectors)$subject_var$variables, + color_var = map_merged(selectors)$color_var$variables, colors = color_inputs(), symbols = adjusted_symbols, - size_var = size_var, + size_var = if (!is.null(size_var)) map_merged(selectors)$size_var$variables, height = input$plot_height, point_size = 10, - title = sprintf("%s over time", input$filter_event_var_level), tooltip_vars = tooltip_vars, expr = { - plot_data <- dataname %>% - dplyr::filter(filter_event_var_lang == selected_event) %>% - dplyr::arrange(!!as.name(subject_var), !!as.name(time_var)) %>% - dplyr::group_by(!!as.name(subject_var)) - subject_var_label <- attr(plot_data[[subject_var]], "label") + subject_var_label <- attr(anl[[subject_var]], "label") if (!length(subject_var_label)) subject_var_label <- subject_var - time_var_label <- attr(plot_data[[time_var]], "label") + + time_var_label <- attr(anl[[time_var]], "label") if (!length(time_var_label)) time_var_label <- time_var - value_var_label <- attr(plot_data[[value_var]], "label") + + value_var_label <- attr(anl[[value_var]], "label") if (!length(value_var_label)) value_var_label <- value_var - plot_data <- plot_data |> - dplyr::mutate(customdata = dplyr::row_number()) + if (is.null(size_var)) { size <- point_size @@ -269,17 +263,17 @@ srv_p_spiderplot <- function(id, size <- stats::as.formula(sprintf("~%s", size_var)) } - p <- plot_data %>% + plot <- anl %>% dplyr::mutate( - x = dplyr::lag(!!as.name(time_var), default = 0), - y = dplyr:::lag(!!as.name(value_var), default = 0), + x = dplyr::lag(time_var_lang, default = 0), + y = dplyr:::lag(value_var_lang, default = 0), tooltip = { if (is.null(tooltip_vars)) { sprintf( "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var), - time_var_label, !!as.name(time_var), - value_var_label, !!as.name(value_var) * 100 + subject_var_label, subject_var_lang, + time_var_label, time_var_lang, + value_var_label, value_var_lang * 100 ) } else { tooltip_lines <- sapply(tooltip_vars, function(col) { @@ -323,36 +317,30 @@ srv_p_spiderplot <- function(id, plotly::layout( xaxis = list(title = time_var_label), yaxis = list(title = value_var_label), - title = title, + title = "Spiderplot", dragmode = "select" ) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::layout(title = title) + plotly::config(displaylogo = FALSE) } ) }) - output$plot <- output$plot <- plotly::renderPlotly(plotly::event_register( + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = decorators, + expr = quote(plot) + ) + + output$plot <- plotly::renderPlotly(plotly::event_register( { - plotly_q()$p |> + rev(teal.code::get_outputs(decorated_output_plot_q()))[[1]] |> set_plot_data(session$ns("plot_data")) |> setup_trigger_tooltips(session$ns) }, "plotly_selected" )) - observeEvent(data(), { - if (class(subject_var) == "choices_selected") { - subject_col <- subject_var$selected - } else { - subject_col <- subject_var - } - updateSelectInput( - inputId = "subjects", - choices = data()[[plot_dataname]][[subject_col]] - ) - }) - plotly_data <- reactive({ data.frame( x = unlist(input$plot_data$x), @@ -365,38 +353,18 @@ srv_p_spiderplot <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - observeEvent(input$subject_tooltips, { - hovervalues <- data()[[plot_dataname]] |> - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::filter(!!rlang::sym(input$subject_var) %in% input$subjects) |> - dplyr::pull(customdata) - - hovertips <- plotly_data() |> - dplyr::filter(customdata %in% hovervalues) - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = session$ns("plot"), - tooltipPoints = jsonlite::toJSON(hovertips) + reactive({ + req(decorated_output_plot_q()) + if (length(plotly_selected()) && nrow(plotly_selected())) { + within( + decorated_output_plot_q(), + anl <- dplyr::filter(anl, customdata %in% selected), + selected = unique(plotly_selected()$customdata) ) - ) + } else { + decorated_output_plot_q() + } }) - - tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, - plot_dataname = plot_dataname, - xvar = reactive(input$time_var), - yvar = reactive(input$value_var), - plotly_selected = plotly_selected, - children_datanames = table_datanames - ) - - srv_t_reactables( - "subtables", - data = tables_selected_q, - datanames = table_datanames, - reactable_args = reactable_args - ) }) } diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 4fa8ad53e..cd07e4531 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -6,44 +6,36 @@ \usage{ tm_p_spiderplot( label = "Spiderplot", - plot_dataname, time_var, value_var, subject_var, color_var, - filter_event_var, size_var = NULL, tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list() + transformators = list(), + decorators = list() ) } \arguments{ \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} - -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +\item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +\item{value_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as y-axis.} -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +\item{subject_var}{(\code{character(1)} or \code{variables}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +\item{color_var}{(\code{character(1)} or \code{variables}) name of the \code{factor} or \code{character} column in \code{plot_dataname} to be used to differentiate colors and symbols.} -\item{filter_event_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used to filter the data. -The plot will be updated with just the filtereed data when the user selects an event from the dropdown menu.} - -\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} +\item{size_var}{(\code{character(1)} or \code{variables} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} \item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. @@ -57,14 +49,19 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} +\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +(named \code{list} of lists of \code{teal_transform_module}) optional, +decorator for tables or plots included in the module output reported. +The decorators are applied to the respective output objects.} } \description{ Module visualizes value development in time grouped by subjects. } \examples{ +library(teal.transform) data <- teal_data() |> within({ subjects <- data.frame( @@ -103,11 +100,17 @@ app <- init( tm_p_spiderplot( plot_dataname = "spiderplot_ds", table_datanames = "subjects", - time_var = "time_var", - value_var = "value_var", - subject_var = "subject_var", - filter_event_var = "filter_event_var", - color_var = "color_var", + time_var = picks(datasets("spiderplot_ds"), variables("time_var")), + value_var = picks(datasets("spiderplot_ds"), variables("value_var")), + subject_var = picks(datasets("spiderplot_ds"), variables("subject_var")), + color_var = picks(datasets("spiderplot_ds"), variables("color_var")), + transformators = list( + teal_transform_filter( + picks( + datasets("spiderplot_ds"), variables("filter_event_var"), values() + ) + ) + ), point_colors = c( CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" ), From 8c251ed132ef41a6ae387106abd665ea222f94d0 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 17:37:25 +0530 Subject: [PATCH 120/158] feat: add spaghetti plot module + improve scatter and line plot modules --- NAMESPACE | 2 + R/tm_p_lineplot.R | 300 ++++++++++++++++++++++++----- R/tm_p_scatterlineplot.R | 63 +++++- R/tm_p_scatterplot.R | 244 +++++++++++++++++------ R/tm_p_spaghetti.R | 280 +++++++++++++++++++++++++++ R/tm_p_spaghettiline.R | 123 ++++++++++++ R/tm_p_spiderplot.R | 7 +- R/tm_p_swimlane.R | 7 +- R/tm_p_waterfall.R | 5 +- man/get_scatterplotmatrix_stats.Rd | 2 +- man/tm_data_table.Rd | 2 +- man/tm_p_lineplot.Rd | 90 +++++++++ man/tm_p_scatterlineplot.Rd | 76 ++++++++ man/tm_p_scatterplot.Rd | 100 ++++++++++ man/tm_p_spaghetti.Rd | 86 +++++++++ man/tm_p_spaghettiline.Rd | 79 ++++++++ man/tm_p_swimlane.Rd | 8 +- man/tm_p_swimlane_table.Rd | 113 +++++++++++ 18 files changed, 1458 insertions(+), 129 deletions(-) create mode 100644 R/tm_p_spaghetti.R create mode 100644 R/tm_p_spaghettiline.R create mode 100644 man/tm_p_lineplot.Rd create mode 100644 man/tm_p_scatterlineplot.Rd create mode 100644 man/tm_p_scatterplot.Rd create mode 100644 man/tm_p_spaghetti.Rd create mode 100644 man/tm_p_spaghettiline.Rd create mode 100644 man/tm_p_swimlane_table.Rd diff --git a/NAMESPACE b/NAMESPACE index fdafcf442..b68204a65 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -27,6 +27,8 @@ export(tm_p_bargraph) export(tm_p_lineplot) export(tm_p_scatterlineplot) export(tm_p_scatterplot) +export(tm_p_spaghetti) +export(tm_p_spaghettiline) export(tm_p_spiderplot) export(tm_p_swimlane) export(tm_p_swimlane_table) diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index d352ac2bc..c0d524580 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -1,10 +1,74 @@ +#' Line Plot Module +#' +#' This module creates an interactive line plot visualization that connects data points +#' within groups to show trends over time. The plot displays both line segments connecting +#' points and individual markers, with support for customizable tooltips and color coding. +#' Optional reference lines can be added to highlight specific values. The plot can be +#' activated by brushing events from other plots when used in combination modules. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param x_var (`character(1)`) Name of the variable to be used for x-axis (typically time). +#' @param y_var (`character(1)`) Name of the variable to be used for y-axis (typically a measurement). +#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines. +#' @param group_var (`character(1)`) Name of the grouping variable that defines which points to connect with lines. +#' @param colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing group, x, y, and color variables. +#' @param transformators (`list`) Named list of transformator functions. +#' @param reference_lines (`list` or `NULL`) Reference lines specification for adding horizontal reference lines. +#' @param activate_on_brushing (`logical(1)`) Whether to activate the plot only when brushing occurs in another plot. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' subject_id = rep(paste0("S", 1:8), each = 5), +#' time_week = rep(c(0, 2, 4, 6, 8), 8), +#' measurement = rnorm(40, 20, 4) + rep(c(0, 1, 2, 3, 4), 8), +#' treatment = rep(c("Active", "Placebo"), each = 20), +#' baseline = rep(rnorm(8, 18, 2), each = 5) +#' ) +#' +#' # Add labels +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$time_week, "label") <- "Time (weeks)" +#' attr(df$measurement, "label") <- "Measurement Value" +#' attr(df$treatment, "label") <- "Treatment Group" +#' attr(df$baseline, "label") <- "Baseline Value" +#' }) +#' +#' # Basic line plot example +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_lineplot( +#' label = "Line Plot", +#' plot_dataname = "df", +#' x_var = "time_week", +#' y_var = "measurement", +#' color_var = "treatment", +#' group_var = "subject_id" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_p_lineplot <- function(label = "Line Plot", plot_dataname, x_var, y_var, + color_var, group_var, - transformators = list()) { + colors = NULL, + tooltip_vars = NULL, + transformators = list(), + reference_lines = NULL, + activate_on_brushing = FALSE) { module( label = label, ui = ui_p_lineplot, @@ -14,7 +78,12 @@ tm_p_lineplot <- function(label = "Line Plot", plot_dataname = plot_dataname, x_var = x_var, y_var = y_var, - group_var = group_var + color_var = color_var, + colors = colors, + group_var = group_var, + tooltip_vars = tooltip_vars, + reference_lines = reference_lines, + activate_on_brushing = activate_on_brushing ), transformators = transformators ) @@ -24,70 +93,199 @@ ui_p_lineplot <- function(id) { ns <- NS(id) bslib::page_fluid( tags$div( - # trigger_tooltips_deps(), + trigger_tooltips_deps(), plotly::plotlyOutput(ns("plot"), height = "100%") ) ) } -srv_p_lineplot <- function(id, data, plot_dataname, x_var, y_var, group_var) { +srv_p_lineplot <- function(id, + data, + plot_dataname, + x_var, + y_var, + color_var, + group_var, + colors, + tooltip_vars = NULL, + reference_lines, + activate_on_brushing) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ - df <- data()[[plot_dataname]] + if (activate_on_brushing) { + req(attr(data(), "has_brushing")) + } + data() %>% + within( + { + validate(need(nrow(df) > 0, "No data after applying filters.")) + + # Get label attributes for variables, fallback to column names + group_var_label <- attr(df[[group_var]], "label") + if (!length(group_var_label)) group_var_label <- group_var + + x_var_label <- attr(df[[x_var]], "label") + if (!length(x_var_label)) x_var_label <- x_var + + y_var_label <- attr(df[[y_var]], "label") + if (!length(y_var_label)) y_var_label <- y_var + + color_var_label <- attr(df[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var - validate(need(nrow(df) > 0, "No data after applying filters.")) + # Add tooltip to the data + df <- df |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars)) { + # Default tooltip: show group, x, y, color variables with labels + paste( + paste(group_var_label, ":", !!as.name(group_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Custom tooltip: show only specified columns + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + # Fallback to default if no valid columns found + paste( + paste(group_var_label, ":", !!as.name(group_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Create tooltip from specified columns + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == group_var) { + lb <- group_var_label + } else if (cn == x_var) { + lb <- x_var_label + } else if (cn == y_var) { + lb <- y_var_label + } else if (cn == color_var) { + lb <- color_var_label + } else { + lb <- attr(sub[[cn]], "label") + } + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) + } + } + } + ) - # TODO: implement the high/low lines with annotations - y_low_last <- if ("si_low" %in% names(df)) utils::tail(stats::na.omit(df[["si_low"]]), 1) else NA - y_high_last <- if ("si_high" %in% names(df)) utils::tail(stats::na.omit(df[["si_high"]]), 1) else NA + add_reference_lines <- function(data, + reference_lines, + default_line_color = "red", + default_font_color = "red", + default_font_size = 12) { + shapes <- list() + annotations <- list() + for (i in seq_along(reference_lines)) { + if (is.character(reference_lines[[i]]) && length(reference_lines[[i]]) == 1) { + col <- reference_lines[[i]] + label <- col + line_mode <- "dash" + } else if (is.list(reference_lines[[i]])) { + col <- names(reference_lines)[i] + if (col == "") next + label <- if (!is.null(reference_lines[[col]]$label)) reference_lines[[col]]$label else col + line_mode <- if (!is.null(reference_lines[[col]]$line_mode)) reference_lines[[col]]$line_mode else "dash" + } else { + next + } + if (length(unique(data[[col]])) != 1) { + label <- paste0(label, "
(mean)") + } + y_val <- mean(data[[col]]) + shapes[[length(shapes) + 1]] <- list( + type = "line", + x0 = 0, x1 = 1, + xref = "paper", + y0 = y_val, y1 = y_val, + yref = "y", + line = list(color = default_line_color, dash = line_mode, width = 2) + ) + annotations[[length(annotations) + 1]] <- list( + x = 1, xref = "paper", + y = y_val, yref = "y", + text = label, + showarrow = FALSE, + xanchor = "left", + font = list(color = default_font_color, size = default_font_size) + ) + } + list(shapes = shapes, annotations = annotations) + } - p <- plotly::plot_ly(data = df |> dplyr::group_by(!!sym(group_var)), x = df[[x_var]]) |> - plotly::add_trace( - y = df[[y_var]], - mode = "lines+markers", type = "scatter", name = "Lab Result", - line = list(color = "green"), - marker = list(color = "green"), - showlegend = FALSE - ) |> - # plotly::add_trace( - # y = df[["si_low"]], - # mode = "lines", - # line = list(color = "red", dash = "dash"), - # showlegend = FALSE - # ) |> - # plotly::add_annotations( - # x = max(df[[x_var]], na.rm = TRUE), - # y = y_low_last, - # yshift = 15, - # text = "Original LLN", - # showarrow = FALSE - # ) |> - # plotly::add_trace( - # y = df[["si_high"]], - # mode = "lines", - # line = list(color = "red", dash = "solid"), - # showlegend = FALSE - # ) |> - # plotly::add_annotations( - # x = max(df[[x_var]], na.rm = TRUE), - # y = y_high_last, - # yshift = -15, - # text = "Original ULN", - # showarrow = FALSE - # ) |> - plotly::layout( - xaxis = list(title = "Study Day of Sample Collection", zeroline = FALSE), - yaxis = list(title = "Original Result") - ) + segments_df <- df %>% + dplyr::arrange(!!as.name(group_var), !!as.name(x_var)) %>% + dplyr::group_by(!!as.name(group_var)) %>% + dplyr::mutate( + xend = lead(!!as.name(x_var)), + yend = lead(!!as.name(y_var)), + color_var_seg = lead(!!as.name(color_var)) + ) %>% + dplyr::filter(!is.na(xend)) + + p <- plotly::plot_ly( + data = segments_df, + source = "spiderplot", + height = 600L + ) %>% + plotly::add_segments( + x = stats::as.formula(sprintf("~%s", x_var)), + y = stats::as.formula(sprintf("~%s", y_var)), + xend = ~xend, + yend = ~yend, + color = ~color_var_seg, + colors = colors + ) %>% + plotly::add_markers( + data = df, + x = stats::as.formula(sprintf("~%s", x_var)), + y = stats::as.formula(sprintf("~%s", y_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + colors = colors, + text = ~tooltip, + hoverinfo = "text" + ) - p + if (!is.null(reference_lines)) { + ref_lines <- add_reference_lines(df, reference_lines) + p <- p %>% + layout( + shapes = ref_lines$shapes, + annotations = ref_lines$annotations + ) + } + }, + df = str2lang(plot_dataname), + x_var = x_var, + y_var = y_var, + color_var = color_var, + group_var = group_var, + colors = colors, + tooltip_vars = tooltip_vars, + reference_lines = reference_lines + ) }) output$plot <- plotly::renderPlotly({ - p <- plotly_q() - plotly::event_register(p, "plotly_selected") - p + plotly_q()$p %>% + plotly::event_register("plotly_selected") }) }) } diff --git a/R/tm_p_scatterlineplot.R b/R/tm_p_scatterlineplot.R index 251f2297a..d822ddb14 100644 --- a/R/tm_p_scatterlineplot.R +++ b/R/tm_p_scatterlineplot.R @@ -1,3 +1,51 @@ +#' Scatter + Line Plot Module +#' +#' This module creates a combined visualization with both scatter plot and line plot views. +#' It displays a scatter plot where users can select points, and the selection is reflected +#' in a corresponding line plot below. +#' +#' The line plot uses `subject_var` as the grouping variable to connect points with lines. +#' When no selection is made in the scatter plot, the line plot shows all data. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param subject_var (`character(1)`) Name of the subject variable used for grouping in the line plot. +#' @param x_var (`character(1)`) Name of the variable to be used for x-axis in both plots. +#' @param y_var (`character(1)`) Name of the variable to be used for y-axis in both plots. +#' @param color_var (`character(1)`) Name of the variable to be used for coloring points in both plots. +#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. +#' @param transformators (`list`) Named list of transformator functions. +#' @param reference_lines (`list` or `NULL`) Reference lines specification for the line plot. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' subject_id = rep(c("S1", "S2", "S3"), each = 4), +#' time_point = rep(c(0, 30, 60, 90), 3), +#' response = rnorm(12, 15, 3), +#' treatment = rep(c("A", "B", "A"), each = 4) +#' ) +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_scatterlineplot( +#' label = "Scatter + Line Plot", +#' plot_dataname = "df", +#' subject_var = "subject_id", +#' x_var = "time_point", +#' y_var = "response", +#' color_var = "treatment" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", plot_dataname, @@ -6,7 +54,8 @@ tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", y_var, color_var, point_colors = character(0), - transformators = list()) { + transformators = list(), + reference_lines = NULL) { module( label = label, ui = ui_p_scatterlineplot, @@ -18,7 +67,8 @@ tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", x_var = x_var, y_var = y_var, color_var = color_var, - point_colors = point_colors + point_colors = point_colors, + reference_lines = reference_lines ), transformators = transformators ) @@ -39,7 +89,8 @@ srv_p_scatterlineplot <- function(id, x_var, y_var, color_var, - point_colors) { + point_colors, + reference_lines) { moduleServer(id, function(input, output, session) { plot_q <- srv_p_scatterplot( "scatter", @@ -58,7 +109,11 @@ srv_p_scatterlineplot <- function(id, plot_dataname = plot_dataname, x_var = x_var, y_var = y_var, - group_var = subject_var + color_var = color_var, + group_var = subject_var, + colors = point_colors, + reference_lines = reference_lines, + activate_on_brushing = TRUE ) }) } diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 10474137d..36417ead6 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -1,3 +1,74 @@ +#' Scatterplot Module +#' +#' This module creates an interactive scatter plot visualization with customizable tooltips. +#' Users can select points by brushing to filter the underlying data. The plot supports +#' color coding by categorical variables and displays tooltips on hover that can show +#' default variables (subject, x, y, color) or custom columns specified via `tooltip_vars`. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param subject_var (`character(1)`) Name of the subject variable. +#' @param x_var (`character(1)`) Name of the variable to be used for x-axis. +#' @param y_var (`character(1)`) Name of the variable to be used for y-axis. +#' @param color_var (`character(1)`) Name of the variable to be used for coloring points. +#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing x, y, and color variables. +#' @param transformators (`list`) Named list of transformator functions. +#' @param show_widgets (`logical(1)`) Whether to show module widgets. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' subject_id = paste0("S", 1:50), +#' age = sample(20:80, 50, replace = TRUE), +#' response = rnorm(50, 15, 3), +#' treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), +#' gender = sample(c("M", "F"), 50, replace = TRUE) +#' ) +#' +#' # Add labels for better tooltips +#' attr(df$age, "label") <- "Age (years)" +#' attr(df$response, "label") <- "Response Score" +#' attr(df$treatment, "label") <- "Treatment Group" +#' }) +#' +#' # Default tooltip example +#' app1 <- init( +#' data = data, +#' modules = modules( +#' tm_p_scatterplot( +#' label = "Scatter Plot", +#' plot_dataname = "df", +#' subject_var = "subject_id", +#' x_var = "age", +#' y_var = "response", +#' color_var = "treatment" +#' ) +#' ) +#' ) +#' +#' # Custom tooltip example +#' app2 <- init( +#' data = data, +#' modules = modules( +#' tm_p_scatterplot( +#' label = "Scatter Plot with Custom Tooltip", +#' plot_dataname = "df", +#' subject_var = "subject_id", +#' x_var = "age", +#' y_var = "response", +#' color_var = "treatment", +#' tooltip_vars = c("subject_id", "age", "gender", "treatment") +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app1$ui, app1$server) +#' } +#' #' @export tm_p_scatterplot <- function(label = "Scatter Plot", plot_dataname, @@ -6,6 +77,7 @@ tm_p_scatterplot <- function(label = "Scatter Plot", y_var, color_var, point_colors = character(0), + tooltip_vars = NULL, transformators = list(), show_widgets = TRUE) { module( @@ -20,6 +92,7 @@ tm_p_scatterplot <- function(label = "Scatter Plot", y_var = y_var, color_var = color_var, point_colors = point_colors, + tooltip_vars = tooltip_vars, show_widgets = show_widgets ), transformators = transformators @@ -31,13 +104,6 @@ ui_p_scatterplot <- function(id) { bslib::page_fluid( shinyjs::useShinyjs(), tags$div( - shinyWidgets::prettySwitch( - ns("add_lines"), - label = "Add lines", - status = "primary", - slim = TRUE, - inline = TRUE - ), tags$span(id = ns("colors_span"), colour_picker_ui(ns("colors"))), bslib::card( full_screen = TRUE, @@ -58,6 +124,7 @@ srv_p_scatterplot <- function(id, y_var, color_var, point_colors, + tooltip_vars = NULL, show_widgets) { moduleServer(id, function(input, output, session) { color_inputs <- colour_picker_srv( @@ -69,7 +136,6 @@ srv_p_scatterplot <- function(id, ) if (!show_widgets) { - shinyjs::hide("add_lines") shinyjs::hide("colors_span") } @@ -77,70 +143,132 @@ srv_p_scatterplot <- function(id, req(color_inputs()) within( data(), - subject_var = str2lang(subject_var), - x_var = str2lang(x_var), - y_var = str2lang(y_var), - color_var = str2lang(color_var), + x_var = x_var, + y_var = y_var, + color_var = color_var, + subject_var = subject_var, colors = color_inputs(), - add_lines = input$add_lines, + source = session$ns("scatterplot"), + tooltip_vars = tooltip_vars, expr = { - plot_data <- scatterplot_ds |> - dplyr::select(subject_var, x_var, y_var, color_var) |> - dplyr::mutate(color_var = factor(color_var, levels = names(colors))) |> - dplyr::mutate(customdata = dplyr::row_number()) + # Get label attributes for variables, fallback to column names + subject_var_label <- attr(df[[subject_var]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var + + x_var_label <- attr(df[[x_var]], "label") + if (!length(x_var_label)) x_var_label <- x_var + + y_var_label <- attr(df[[y_var]], "label") + if (!length(y_var_label)) y_var_label <- y_var + + color_var_label <- attr(df[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var + + plot_data <- df |> + dplyr::mutate(!!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors))) |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars)) { + # Default tooltip: show subject, x, y, color variables with labels + paste( + paste(subject_var_label, ":", !!as.name(subject_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Custom tooltip: show only specified columns + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + # Fallback to default if no valid columns found + paste( + paste(subject_var_label, ":", !!as.name(subject_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Create tooltip from specified columns + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var) { + lb <- subject_var_label + } else if (cn == x_var) { + lb <- x_var_label + } else if (cn == y_var) { + lb <- y_var_label + } else if (cn == color_var) { + lb <- color_var_label + } else { + lb <- attr(sub[[cn]], "label") + } + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) + } + } + } + ) + p <- plotly::plot_ly( data = plot_data, - x = ~x_var, - y = ~y_var, - customdata = ~customdata, - color = ~color_var, + source = source, colors = colors, - mode = "markers", - type = "scatter", - source = "scatterplot" + customdata = ~customdata ) |> - plotly::layout(dragmode = "select") + plotly::add_markers( + x = stats::as.formula(sprintf("~%s", x_var)), + y = stats::as.formula(sprintf("~%s", y_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + text = ~tooltip, + hoverinfo = "text" + ) |> + plotly::layout(dragmode = "select") |> + plotly::event_register("plotly_selected") - if (add_lines) { - p <- p %>% - plotly::add_trace( - x = ~x_var, - y = ~y_var, - split = ~subject_var, - mode = "lines", - line = list(color = "grey"), - showlegend = FALSE, - inherit = FALSE - ) - } p - } + }, + df = str2lang(plot_dataname) ) }) - output$plot <- plotly::renderPlotly(plotly::event_register( - { - plotly_q()$p |> - setup_trigger_tooltips(session$ns) |> - set_plot_data(session$ns("plot_data")) - }, - "plotly_selected" - )) + output$plot <- plotly::renderPlotly( + plotly_q()$p |> + setup_trigger_tooltips(session$ns) |> + set_plot_data(session$ns("plot_data")) |> + plotly::event_register("plotly_selected") + ) + - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "scatterplot")) + plotly_selected <- reactive( + plotly::event_data("plotly_selected", source = session$ns("scatterplot")) + ) reactive({ - req(plotly_selected()) - plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - scatterplot_ds <- scatterplot_ds |> - filter(subject %in% selected_plot_data$subject) - }, - plotly_selected_customdata = plotly_selected()$customdata - ) + if (is.null(plotly_selected()) || is.null(subject_var)) { + plotly_q() + } else { + q <- plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + df <- df |> + dplyr::filter(!!as.name(subject_var_string) %in% selected_plot_data[[subject_var_string]]) + }, + df = str2lang(plot_dataname), + subject_var_string = subject_var, + plotly_selected_customdata = plotly_selected()$customdata + ) + attr(q, "has_brushing") <- TRUE + q + } }) }) } diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R new file mode 100644 index 000000000..e2d17f093 --- /dev/null +++ b/R/tm_p_spaghetti.R @@ -0,0 +1,280 @@ +#' Spaghetti Plot Module +#' +#' This module creates an interactive spaghetti plot visualization that shows individual +#' trajectories for each group over time. Each trajectory is represented by connected +#' points and lines, creating a "spaghetti-like" appearance. The plot supports customizable +#' tooltips and color coding by categorical variables. Users can select points by brushing +#' to filter the underlying data. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param group_var (`character(1)`) Name of the grouping variable that defines individual trajectories. +#' @param x_var (`character(1)`) Name of the variable to be used for x-axis (typically time). +#' @param y_var (`character(1)`) Name of the variable to be used for y-axis (typically a measurement). +#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines. +#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing group, x, y, and color variables. +#' @param transformators (`list`) Named list of transformator functions. +#' @param show_widgets (`logical(1)`) Whether to show module widgets. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' subject_id = rep(paste0("S", 1:10), each = 4), +#' time_point = rep(c(0, 30, 60, 90), 10), +#' response = rnorm(40, 15, 3) + rep(c(0, 2, 4, 6), 10), +#' treatment = rep(c("Active", "Placebo"), each = 20), +#' age_group = rep(c("Young", "Old"), 20) +#' ) +#' +#' # Add labels +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$time_point, "label") <- "Time Point (days)" +#' attr(df$response, "label") <- "Response Score" +#' attr(df$treatment, "label") <- "Treatment Group" +#' }) +#' +#' # Default tooltip example +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_spaghetti( +#' label = "Spaghetti Plot", +#' plot_dataname = "df", +#' group_var = "subject_id", +#' x_var = "time_point", +#' y_var = "response", +#' color_var = "treatment" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @export +tm_p_spaghetti <- function(label = "Scatter Plot", + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors = character(0), + tooltip_vars = NULL, + transformators = list(), + show_widgets = TRUE) { + module( + label = label, + ui = ui_p_spaghetti, + server = srv_p_spaghetti, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + group_var = group_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + point_colors = point_colors, + tooltip_vars = tooltip_vars, + show_widgets = show_widgets + ), + transformators = transformators + ) +} + +ui_p_spaghetti <- function(id) { + ns <- NS(id) + bslib::page_fluid( + shinyjs::useShinyjs(), + tags$div( + tags$span(id = ns("colors_span"), colour_picker_ui(ns("colors"))), + bslib::card( + full_screen = TRUE, + tags$div( + trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) + ) + ) + ) +} + +srv_p_spaghetti <- function(id, + data, + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL, + show_widgets) { + moduleServer(id, function(input, output, session) { + color_inputs <- colour_picker_srv( + "colors", + x = reactive({ + data()[[plot_dataname]][[color_var]] + }), + default_colors = point_colors + ) + + if (!show_widgets) { + shinyjs::hide("colors_span") + } + + plotly_q <- reactive({ + req(color_inputs()) + within( + data(), + group_var = group_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + colors = color_inputs(), + source = session$ns("spaghetti"), + tooltip_vars = tooltip_vars, + expr = { + # Get label attributes for variables, fallback to column names + group_var_label <- attr(df[[group_var]], "label") + if (!length(group_var_label)) group_var_label <- group_var + + x_var_label <- attr(df[[x_var]], "label") + if (!length(x_var_label)) x_var_label <- x_var + + y_var_label <- attr(df[[y_var]], "label") + if (!length(y_var_label)) y_var_label <- y_var + + color_var_label <- attr(df[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var + + plot_data <- df |> + dplyr::select(!!as.name(group_var), !!as.name(x_var), !!as.name(y_var), !!as.name(color_var)) |> + dplyr::mutate(!!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors))) %>% + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars)) { + # Default tooltip: show group, x, y, color variables with labels + paste( + paste(group_var_label, ":", !!as.name(group_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Custom tooltip: show only specified columns + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + # Fallback to default if no valid columns found + paste( + paste(group_var_label, ":", !!as.name(group_var)), + paste(x_var_label, ":", !!as.name(x_var)), + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + sep = "
" + ) + } else { + # Create tooltip from specified columns + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == group_var) { + lb <- group_var_label + } else if (cn == x_var) { + lb <- x_var_label + } else if (cn == y_var) { + lb <- y_var_label + } else if (cn == color_var) { + lb <- color_var_label + } else { + lb <- attr(sub[[cn]], "label") + } + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) + } + } + } + ) + + segments_df <- plot_data %>% + dplyr::arrange(!!as.name(group_var), !!as.name(x_var)) %>% + dplyr::group_by(!!as.name(group_var)) %>% + dplyr::mutate( + x = !!as.name(x_var), + y = !!as.name(y_var), + xend = lead(!!as.name(x_var)), + yend = lead(!!as.name(y_var)), + color_var_seg = lead(!!as.name(color_var)) + ) %>% + dplyr::filter(!is.na(xend)) + + p <- plotly::plot_ly( + data = segments_df, + customdata = ~customdata, + source = source + ) %>% + plotly::add_segments( + x = ~x, y = ~y, + xend = ~xend, yend = ~yend, + color = ~color_var_seg, + colors = colors, + showlegend = TRUE + ) %>% + plotly::add_markers( + data = plot_data, + x = stats::as.formula(sprintf("~%s", x_var)), + y = stats::as.formula(sprintf("~%s", y_var)), + color = stats::as.formula(sprintf("~%s", color_var)), + colors = colors, + text = ~tooltip, + hoverinfo = "text" + ) |> + plotly::layout(dragmode = "select") + + p + }, + df = str2lang(plot_dataname) + ) + }) + + + output$plot <- plotly::renderPlotly( + plotly_q()$p |> + setup_trigger_tooltips(session$ns) |> + set_plot_data(session$ns("plot_data")) |> + plotly::event_register("plotly_selected") + ) + + plotly_selected <- reactive( + plotly::event_data("plotly_selected", source = session$ns("spaghetti")) + ) + reactive({ + if (is.null(plotly_selected()) || is.null(group_var)) { + plotly_q() + } else { + print("selection is recorded") + q <- plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + df <- df |> + dplyr::filter(!!as.name(group_var_string) %in% selected_plot_data[[group_var_string]]) + }, + df = str2lang(plot_dataname), + group_var_string = group_var, + plotly_selected_customdata = plotly_selected()$customdata + ) + attr(q, "has_brushing") <- TRUE + q + } + }) + }) +} diff --git a/R/tm_p_spaghettiline.R b/R/tm_p_spaghettiline.R new file mode 100644 index 000000000..ac7efa887 --- /dev/null +++ b/R/tm_p_spaghettiline.R @@ -0,0 +1,123 @@ +#' Spaghetti + Line Plot Module +#' +#' This module creates a combined visualization with both spaghetti plot and line plot views. +#' It displays a spaghetti plot where users can select points, and the selection is reflected +#' in a corresponding line plot below. The spaghetti plot shows individual trajectories for +#' each group over time. +#' +#' The spaghetti plot connects points within each `group_var` level to show individual trajectories. +#' The line plot uses the same `group_var` for grouping and updates to show only the selected data +#' when brushing occurs in the spaghetti plot. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param group_var (`character(1)`) Name of the grouping variable used for creating individual +#' trajectories in the spaghetti plot and grouping in the line plot. +#' @param x_var (`character(1)`) Name of the variable to be used for x-axis in both plots. +#' @param y_var (`character(1)`) Name of the variable to be used for y-axis in both plots. +#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines in both plots. +#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. +#' @param transformators (`list`) Named list of transformator functions. +#' @param reference_lines (`list` or `NULL`) Reference lines specification for the line plot. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' subject_id = rep(c("S1", "S2", "S3", "S4"), each = 4), +#' time_point = rep(c(0, 30, 60, 90), 4), +#' response = rnorm(16, 15, 3), +#' treatment = rep(c("A", "B", "A", "B"), each = 4) +#' ) +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_spaghettiline( +#' label = "Spaghetti + Line Plot", +#' plot_dataname = "df", +#' group_var = "subject_id", +#' x_var = "time_point", +#' y_var = "response", +#' color_var = "treatment" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @export +tm_p_spaghettiline <- function(label = "Scatter + Line Plot", + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors = character(0), + transformators = list(), + reference_lines = NULL) { + module( + label = label, + ui = ui_p_spaghettiline, + server = srv_p_spaghettiline, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + group_var = group_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + point_colors = point_colors, + reference_lines = reference_lines + ), + transformators = transformators + ) +} + +ui_p_spaghettiline <- function(id) { + ns <- NS(id) + bslib::page_fluid( + ui_p_spaghetti(ns("scatter")), + ui_p_lineplot(ns("line")) + ) +} + +srv_p_spaghettiline <- function(id, + data, + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors, + reference_lines) { + moduleServer(id, function(input, output, session) { + plot_q <- srv_p_spaghetti( + "scatter", + data = data, + plot_dataname = plot_dataname, + group_var = group_var, + x_var = x_var, + y_var = y_var, + color_var = color_var, + point_colors = point_colors, + show_widgets = FALSE + ) + + srv_p_lineplot( + "line", + data = plot_q, + plot_dataname = plot_dataname, + x_var = x_var, + y_var = y_var, + color_var = color_var, + group_var = group_var, + colors = point_colors, + reference_lines = reference_lines, + activate_on_brushing = TRUE + ) + }) +} diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index d8c10a04d..718f2fbd5 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -249,6 +249,7 @@ srv_p_spiderplot <- function(id, point_size = 10, title = sprintf("%s over time", input$filter_event_var_level), tooltip_vars = tooltip_vars, + source = session$ns("spiderplot"), expr = { plot_data <- dataname %>% dplyr::filter(filter_event_var_lang == selected_event) %>% @@ -298,7 +299,7 @@ srv_p_spiderplot <- function(id, ) %>% dplyr::ungroup() %>% plotly::plot_ly( - source = "spiderplot", + source = source, height = height, color = stats::as.formula(sprintf("~%s", color_var)), colors = colors, @@ -363,7 +364,9 @@ srv_p_spiderplot <- function(id, ) }) - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) + plotly_selected <- reactive( + plotly::event_data("plotly_selected", source = session$ns("spiderplot")) + ) observeEvent(input$subject_tooltips, { hovervalues <- data()[[plot_dataname]] |> diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 3d4b59c65..889df8fbb 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -204,7 +204,8 @@ srv_p_swimlane <- function(id, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - tooltip_vars = tooltip_vars, + tooltip_vars = tooltip_vars, , + source = session$ns("swimlane"), expr = { subject_var_label <- attr(dataname[[subject_var]], "label") if (!length(subject_var_label)) subject_var_label <- subject_var @@ -300,7 +301,7 @@ srv_p_swimlane <- function(id, ) %>% dplyr::ungroup() %>% plotly::plot_ly( - source = "swimlane", + source = source, colors = colors, symbols = symbols, height = height, @@ -346,7 +347,7 @@ srv_p_swimlane <- function(id, }) plotly_selected <- reactive({ - plotly::event_data("plotly_selected", source = "swimlane") + plotly::event_data("plotly_selected", source = session$ns("swimlane")) }) reactive({ diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index fee2f9008..2ecfdd788 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -187,6 +187,7 @@ srv_p_waterfall <- function(id, height = input$plot_height, title = sprintf("Waterfall plot"), tooltip_vars = tooltip_vars, + source = session$ns("waterfall"), expr = { subject_var_label <- attr(dataname[[subject_var]], "label") if (!length(subject_var_label)) subject_var_label <- subject_var @@ -232,7 +233,7 @@ srv_p_waterfall <- function(id, ) %>% dplyr::filter(!duplicated(!!as.name(subject_var))) %>% plotly::plot_ly( - source = "waterfall", + source = source, height = height ) %>% plotly::add_bars( @@ -270,7 +271,7 @@ srv_p_waterfall <- function(id, output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "waterfall")) + plotly_selected <- reactive(plotly::event_data("plotly_selected", source = session$ns("waterfall"))) tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index 176b24cb1..f310c641b 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -32,7 +32,7 @@ Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correl Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. -Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. +Meant to be called from \code{\link[lattice:panel.text]{lattice::panel.text()}}. } \details{ Presently we need to use a formula input for \code{stats::cor.test} because diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index e5084fbf8..d5acf6dbd 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -47,7 +47,7 @@ argument. \code{list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)}} \item{server_rendering}{(\code{logical}) should the data table be rendered server side -(see \code{server} argument of \code{\link[DT:dataTableOutput]{DT::renderDataTable()}})} +(see \code{server} argument of \code{\link[DT:renderDataTable]{DT::renderDataTable()}})} \item{pre_output}{(\code{shiny.tag}) optional, text or UI element to be displayed before the module's output, providing context or a title. diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd new file mode 100644 index 000000000..f5fea6557 --- /dev/null +++ b/man/tm_p_lineplot.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_lineplot.R +\name{tm_p_lineplot} +\alias{tm_p_lineplot} +\title{Line Plot Module} +\usage{ +tm_p_lineplot( + label = "Line Plot", + plot_dataname, + x_var, + y_var, + color_var, + group_var, + colors = NULL, + tooltip_vars = NULL, + transformators = list(), + reference_lines = NULL, + activate_on_brushing = FALSE +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} + +\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis (typically a measurement).} + +\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines.} + +\item{group_var}{(\code{character(1)}) Name of the grouping variable that defines which points to connect with lines.} + +\item{colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created showing group, x, y, and color variables.} + +\item{transformators}{(\code{list}) Named list of transformator functions.} + +\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for adding horizontal reference lines.} + +\item{activate_on_brushing}{(\code{logical(1)}) Whether to activate the plot only when brushing occurs in another plot.} +} +\description{ +This module creates an interactive line plot visualization that connects data points +within groups to show trends over time. The plot displays both line segments connecting +points and individual markers, with support for customizable tooltips and color coding. +Optional reference lines can be added to highlight specific values. The plot can be +activated by brushing events from other plots when used in combination modules. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + subject_id = rep(paste0("S", 1:8), each = 5), + time_week = rep(c(0, 2, 4, 6, 8), 8), + measurement = rnorm(40, 20, 4) + rep(c(0, 1, 2, 3, 4), 8), + treatment = rep(c("Active", "Placebo"), each = 20), + baseline = rep(rnorm(8, 18, 2), each = 5) + ) + + # Add labels + attr(df$subject_id, "label") <- "Subject ID" + attr(df$time_week, "label") <- "Time (weeks)" + attr(df$measurement, "label") <- "Measurement Value" + attr(df$treatment, "label") <- "Treatment Group" + attr(df$baseline, "label") <- "Baseline Value" + }) + +# Basic line plot example +app <- init( + data = data, + modules = modules( + tm_p_lineplot( + label = "Line Plot", + plot_dataname = "df", + x_var = "time_week", + y_var = "measurement", + color_var = "treatment", + group_var = "subject_id" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_scatterlineplot.Rd b/man/tm_p_scatterlineplot.Rd new file mode 100644 index 000000000..79d9bcf80 --- /dev/null +++ b/man/tm_p_scatterlineplot.Rd @@ -0,0 +1,76 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_scatterlineplot.R +\name{tm_p_scatterlineplot} +\alias{tm_p_scatterlineplot} +\title{Scatter + Line Plot Module} +\usage{ +tm_p_scatterlineplot( + label = "Scatter + Line Plot", + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + point_colors = character(0), + transformators = list(), + reference_lines = NULL +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{subject_var}{(\code{character(1)}) Name of the subject variable used for grouping in the line plot.} + +\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis in both plots.} + +\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis in both plots.} + +\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points in both plots.} + +\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} + +\item{transformators}{(\code{list}) Named list of transformator functions.} + +\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for the line plot.} +} +\description{ +This module creates a combined visualization with both scatter plot and line plot views. +It displays a scatter plot where users can select points, and the selection is reflected +in a corresponding line plot below. +} +\details{ +The line plot uses \code{subject_var} as the grouping variable to connect points with lines. +When no selection is made in the scatter plot, the line plot shows all data. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + subject_id = rep(c("S1", "S2", "S3"), each = 4), + time_point = rep(c(0, 30, 60, 90), 3), + response = rnorm(12, 15, 3), + treatment = rep(c("A", "B", "A"), each = 4) + ) + }) + +app <- init( + data = data, + modules = modules( + tm_p_scatterlineplot( + label = "Scatter + Line Plot", + plot_dataname = "df", + subject_var = "subject_id", + x_var = "time_point", + y_var = "response", + color_var = "treatment" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd new file mode 100644 index 000000000..5617032b9 --- /dev/null +++ b/man/tm_p_scatterplot.Rd @@ -0,0 +1,100 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_scatterplot.R +\name{tm_p_scatterplot} +\alias{tm_p_scatterplot} +\title{Scatterplot Module} +\usage{ +tm_p_scatterplot( + label = "Scatter Plot", + plot_dataname, + subject_var, + x_var, + y_var, + color_var, + point_colors = character(0), + tooltip_vars = NULL, + transformators = list(), + show_widgets = TRUE +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{subject_var}{(\code{character(1)}) Name of the subject variable.} + +\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis.} + +\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis.} + +\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points.} + +\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created showing x, y, and color variables.} + +\item{transformators}{(\code{list}) Named list of transformator functions.} + +\item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} +} +\description{ +This module creates an interactive scatter plot visualization with customizable tooltips. +Users can select points by brushing to filter the underlying data. The plot supports +color coding by categorical variables and displays tooltips on hover that can show +default variables (subject, x, y, color) or custom columns specified via \code{tooltip_vars}. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + subject_id = paste0("S", 1:50), + age = sample(20:80, 50, replace = TRUE), + response = rnorm(50, 15, 3), + treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), + gender = sample(c("M", "F"), 50, replace = TRUE) + ) + + # Add labels for better tooltips + attr(df$age, "label") <- "Age (years)" + attr(df$response, "label") <- "Response Score" + attr(df$treatment, "label") <- "Treatment Group" + }) + +# Default tooltip example +app1 <- init( + data = data, + modules = modules( + tm_p_scatterplot( + label = "Scatter Plot", + plot_dataname = "df", + subject_var = "subject_id", + x_var = "age", + y_var = "response", + color_var = "treatment" + ) + ) +) + +# Custom tooltip example +app2 <- init( + data = data, + modules = modules( + tm_p_scatterplot( + label = "Scatter Plot with Custom Tooltip", + plot_dataname = "df", + subject_var = "subject_id", + x_var = "age", + y_var = "response", + color_var = "treatment", + tooltip_vars = c("subject_id", "age", "gender", "treatment") + ) + ) +) + +if (interactive()) { + shinyApp(app1$ui, app1$server) +} + +} diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd new file mode 100644 index 000000000..31e7794cb --- /dev/null +++ b/man/tm_p_spaghetti.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_spaghetti.R +\name{tm_p_spaghetti} +\alias{tm_p_spaghetti} +\title{Spaghetti Plot Module} +\usage{ +tm_p_spaghetti( + label = "Scatter Plot", + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors = character(0), + tooltip_vars = NULL, + transformators = list(), + show_widgets = TRUE +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{group_var}{(\code{character(1)}) Name of the grouping variable that defines individual trajectories.} + +\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} + +\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis (typically a measurement).} + +\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines.} + +\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created showing group, x, y, and color variables.} + +\item{transformators}{(\code{list}) Named list of transformator functions.} + +\item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} +} +\description{ +This module creates an interactive spaghetti plot visualization that shows individual +trajectories for each group over time. Each trajectory is represented by connected +points and lines, creating a "spaghetti-like" appearance. The plot supports customizable +tooltips and color coding by categorical variables. Users can select points by brushing +to filter the underlying data. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + subject_id = rep(paste0("S", 1:10), each = 4), + time_point = rep(c(0, 30, 60, 90), 10), + response = rnorm(40, 15, 3) + rep(c(0, 2, 4, 6), 10), + treatment = rep(c("Active", "Placebo"), each = 20), + age_group = rep(c("Young", "Old"), 20) + ) + + # Add labels + attr(df$subject_id, "label") <- "Subject ID" + attr(df$time_point, "label") <- "Time Point (days)" + attr(df$response, "label") <- "Response Score" + attr(df$treatment, "label") <- "Treatment Group" + }) + +# Default tooltip example +app <- init( + data = data, + modules = modules( + tm_p_spaghetti( + label = "Spaghetti Plot", + plot_dataname = "df", + group_var = "subject_id", + x_var = "time_point", + y_var = "response", + color_var = "treatment" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_spaghettiline.Rd b/man/tm_p_spaghettiline.Rd new file mode 100644 index 000000000..e2f04b3fd --- /dev/null +++ b/man/tm_p_spaghettiline.Rd @@ -0,0 +1,79 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_spaghettiline.R +\name{tm_p_spaghettiline} +\alias{tm_p_spaghettiline} +\title{Spaghetti + Line Plot Module} +\usage{ +tm_p_spaghettiline( + label = "Scatter + Line Plot", + plot_dataname, + group_var, + x_var, + y_var, + color_var, + point_colors = character(0), + transformators = list(), + reference_lines = NULL +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{group_var}{(\code{character(1)}) Name of the grouping variable used for creating individual +trajectories in the spaghetti plot and grouping in the line plot.} + +\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis in both plots.} + +\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis in both plots.} + +\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines in both plots.} + +\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} + +\item{transformators}{(\code{list}) Named list of transformator functions.} + +\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for the line plot.} +} +\description{ +This module creates a combined visualization with both spaghetti plot and line plot views. +It displays a spaghetti plot where users can select points, and the selection is reflected +in a corresponding line plot below. The spaghetti plot shows individual trajectories for +each group over time. +} +\details{ +The spaghetti plot connects points within each \code{group_var} level to show individual trajectories. +The line plot uses the same \code{group_var} for grouping and updates to show only the selected data +when brushing occurs in the spaghetti plot. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + subject_id = rep(c("S1", "S2", "S3", "S4"), each = 4), + time_point = rep(c(0, 30, 60, 90), 4), + response = rnorm(16, 15, 3), + treatment = rep(c("A", "B", "A", "B"), each = 4) + ) + }) + +app <- init( + data = data, + modules = modules( + tm_p_spaghettiline( + label = "Spaghetti + Line Plot", + plot_dataname = "df", + group_var = "subject_id", + x_var = "time_point", + y_var = "response", + color_var = "treatment" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 8527f3b81..2f9b38872 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -17,8 +17,7 @@ tm_p_swimlane( point_colors = character(0), point_symbols = character(0), plot_height = c(700, 400, 1200), - table_datanames = character(0), - reactable_args = list() + show_widgets = TRUE ) } \arguments{ @@ -57,10 +56,6 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} } \description{ Module visualizes subjects' events in time. @@ -89,7 +84,6 @@ app <- init( modules = modules( tm_p_swimlane( plot_dataname = "swimlane_ds", - table_datanames = "subjects", time_var = "time_var", subject_var = "subject_var", color_var = "color_var", diff --git a/man/tm_p_swimlane_table.Rd b/man/tm_p_swimlane_table.Rd new file mode 100644 index 000000000..2d45d21f1 --- /dev/null +++ b/man/tm_p_swimlane_table.Rd @@ -0,0 +1,113 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_swimlane_table.R +\name{tm_p_swimlane_table} +\alias{tm_p_swimlane_table} +\title{\code{teal} module: Swimlane plot} +\usage{ +tm_p_swimlane_table( + label = "Swimlane", + plot_dataname, + time_var, + subject_var, + color_var, + group_var, + sort_var = time_var, + tooltip_vars = NULL, + point_size = 10, + point_colors = character(0), + point_symbols = character(0), + plot_height = c(700, 400, 1200), + table_datanames = character(0), + reactable_args = list() +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} + +\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column +in \code{plot_dataname} to be used as x-axis.} + +\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to be used as y-axis.} + +\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column +in \code{plot_dataname} to name and color subject events in time.} + +\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} +to categorize type of event. +(legend is sorted according to this variable, and used in toolip to display type of the event) +todo: this can be fixed by ordering factor levels} + +\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which +value determines order of the subjects displayed on the y-axis.} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + +\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. +If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} + +\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named +by levels of \code{color_var} column.} + +\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} + +\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} +} +\description{ +Module visualizes subjects' events in time. +} +\examples{ +data <- teal_data() |> + within({ + subjects <- data.frame( + subject_var = c("A", "B", "C"), + AGE = sample(30:100, 3), + ARM = c("Combination", "Combination", "Placebo") + ) + + swimlane_ds <- data.frame( + subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), + time_var = sample(1:100, 10, replace = TRUE), + color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) + ) + }) +join_keys(data) <- join_keys( + join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) +) + +app <- init( + data = data, + modules = modules( + tm_p_swimlane_table( + plot_dataname = "swimlane_ds", + table_datanames = "subjects", + time_var = "time_var", + subject_var = "subject_var", + color_var = "color_var", + group_var = "color_var", + sort_var = "time_var", + plot_height = 400, + point_colors = c( + CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + ), + point_symbols = c( + CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} From 848e89b9dd3cd636912bbdeee3cb26a1ffea7ffe Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 18:13:35 +0530 Subject: [PATCH 121/158] fix: use package prefix `layout` is exported in graphics, igraph, and plotly --- R/tm_p_lineplot.R | 2 +- man/get_scatterplotmatrix_stats.Rd | 2 +- man/tm_data_table.Rd | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index c0d524580..337a37977 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -265,7 +265,7 @@ srv_p_lineplot <- function(id, if (!is.null(reference_lines)) { ref_lines <- add_reference_lines(df, reference_lines) p <- p %>% - layout( + plotly::layout( shapes = ref_lines$shapes, annotations = ref_lines$annotations ) diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index f310c641b..176b24cb1 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -32,7 +32,7 @@ Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correl Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. -Meant to be called from \code{\link[lattice:panel.text]{lattice::panel.text()}}. +Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. } \details{ Presently we need to use a formula input for \code{stats::cor.test} because diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index d5acf6dbd..e5084fbf8 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -47,7 +47,7 @@ argument. \code{list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)}} \item{server_rendering}{(\code{logical}) should the data table be rendered server side -(see \code{server} argument of \code{\link[DT:renderDataTable]{DT::renderDataTable()}})} +(see \code{server} argument of \code{\link[DT:dataTableOutput]{DT::renderDataTable()}})} \item{pre_output}{(\code{shiny.tag}) optional, text or UI element to be displayed before the module's output, providing context or a title. From 636a0cd9ed18a6b8af72bf07d7c785ed36625239 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 18:13:35 +0530 Subject: [PATCH 122/158] fix: use package prefix `layout` is exported in graphics, igraph, and plotly --- R/tm_p_lineplot.R | 2 +- man/get_scatterplotmatrix_stats.Rd | 2 +- man/tm_data_table.Rd | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index c0d524580..337a37977 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -265,7 +265,7 @@ srv_p_lineplot <- function(id, if (!is.null(reference_lines)) { ref_lines <- add_reference_lines(df, reference_lines) p <- p %>% - layout( + plotly::layout( shapes = ref_lines$shapes, annotations = ref_lines$annotations ) diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index f310c641b..176b24cb1 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -32,7 +32,7 @@ Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correl Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. -Meant to be called from \code{\link[lattice:panel.text]{lattice::panel.text()}}. +Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. } \details{ Presently we need to use a formula input for \code{stats::cor.test} because diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index d5acf6dbd..e5084fbf8 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -47,7 +47,7 @@ argument. \code{list(searching = FALSE, pageLength = 30, lengthMenu = c(5, 15, 30, 100), scrollX = TRUE)}} \item{server_rendering}{(\code{logical}) should the data table be rendered server side -(see \code{server} argument of \code{\link[DT:renderDataTable]{DT::renderDataTable()}})} +(see \code{server} argument of \code{\link[DT:dataTableOutput]{DT::renderDataTable()}})} \item{pre_output}{(\code{shiny.tag}) optional, text or UI element to be displayed before the module's output, providing context or a title. From f14992e76ca52848b47bcf4c381299325859e166 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 18:22:42 +0530 Subject: [PATCH 123/158] typo --- R/tm_p_swimlane.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 889df8fbb..6168985b7 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -204,7 +204,7 @@ srv_p_swimlane <- function(id, colors = color_inputs(), symbols = adjusted_symbols, height = input$plot_height, - tooltip_vars = tooltip_vars, , + tooltip_vars = tooltip_vars, source = session$ns("swimlane"), expr = { subject_var_label <- attr(dataname[[subject_var]], "label") From 210cb1b70a36e1e9ab102676e63bef08da82d40b Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 18:24:53 +0530 Subject: [PATCH 124/158] chore: remove local log --- R/tm_p_spaghetti.R | 1 - 1 file changed, 1 deletion(-) diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index e2d17f093..fbbe048a8 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -259,7 +259,6 @@ srv_p_spaghetti <- function(id, if (is.null(plotly_selected()) || is.null(group_var)) { plotly_q() } else { - print("selection is recorded") q <- plotly_q() |> within( { From fe7be25a2805d1dc84425425439b713e36072add Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 19:51:50 +0530 Subject: [PATCH 125/158] chore: remove legacy subject tooltip triggers --- R/tm_p_spiderplot.R | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 718f2fbd5..0d825f32b 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -154,9 +154,7 @@ ui_p_spiderplot <- function(id, height) { selectInput(ns("filter_event_var"), label = "Event variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("filter_event_var_level"), label = "Select an event:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]), - selectInput(ns("subjects"), "Subjects", choices = NULL, selected = NULL, multiple = TRUE), - actionButton(ns("subject_tooltips"), "Show Subject Tooltips") + sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), tags$div( bslib::card( @@ -368,24 +366,6 @@ srv_p_spiderplot <- function(id, plotly::event_data("plotly_selected", source = session$ns("spiderplot")) ) - observeEvent(input$subject_tooltips, { - hovervalues <- data()[[plot_dataname]] |> - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::filter(!!rlang::sym(input$subject_var) %in% input$subjects) |> - dplyr::pull(customdata) - - hovertips <- plotly_data() |> - dplyr::filter(customdata %in% hovervalues) - - session$sendCustomMessage( - "triggerTooltips", - list( - plotID = session$ns("plot"), - tooltipPoints = jsonlite::toJSON(hovertips) - ) - ) - }) - tables_selected_q <- .plotly_selected_filter_children( data = plotly_q, plot_dataname = plot_dataname, From d647ee11f7267249c7bc2b2cb4ee72c89dc21215 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 15 Sep 2025 15:26:01 +0530 Subject: [PATCH 126/158] feat: improve bargraph and add double_bargraph module --- R/tm_p_bargraph.R | 108 ++++++++++++++++++++++++++++----------- R/tm_p_double_bargraph.R | 67 ++++++++++++++++++++++++ 2 files changed, 144 insertions(+), 31 deletions(-) create mode 100644 R/tm_p_double_bargraph.R diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index ed65d7af1..8f55fbb0a 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -33,48 +33,94 @@ ui_p_bargraph <- function(id) { ) } -srv_p_bargraph <- function(id, data, plot_dataname, y_var, color_var, count_var, bar_colors) { +srv_p_bargraph <- function(id, + data, + plot_dataname, + y_var, + color_var, + count_var, + bar_colors) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ - df <- data()[[plot_dataname]] - df[[color_var]] <- as.character(df[[color_var]]) + data() |> + within( + { + df[[color_var]] <- as.character(df[[color_var]]) - plot_data <- df %>% - group_by(!!as.name(y_var), !!as.name(color_var)) %>% - summarize(count = n_distinct(!!as.name(count_var)), .groups = "drop") + plot_data <- df %>% + dplyr::group_by(!!as.name(y_var), !!as.name(color_var)) %>% + dplyr::summarize(count = n_distinct(!!as.name(count_var)), .groups = "drop") %>% + dplyr::mutate(customdata = dplyr::row_number()) - event_type_order <- plot_data %>% - group_by(!!as.name(y_var)) %>% - summarize(total = sum(count)) %>% - arrange(total) %>% - pull(!!as.name(y_var)) + event_type_order <- plot_data %>% + dplyr::group_by(!!as.name(y_var)) %>% + dplyr::summarize(total = sum(count), .groups = "drop") %>% + dplyr::arrange(total) %>% + dplyr::pull(!!as.name(y_var)) - plot_data[[y_var]] <- factor(plot_data[[y_var]], levels = event_type_order) + plot_data[[y_var]] <- factor(plot_data[[y_var]], levels = event_type_order) - p <- plotly::plot_ly( - data = plot_data, - y = as.formula(paste0("~", y_var)), - x = ~count, - color = as.formula(paste0("~", color_var)), - colors = bar_colors, - type = "bar", - orientation = "h" - ) %>% - plotly::layout( - barmode = "stack", - xaxis = list(title = "Count"), - yaxis = list(title = "Adverse Event Type"), - legend = list(title = list(text = "AE Type")) + p <- plotly::plot_ly( + data = plot_data, + y = as.formula(paste0("~", y_var)), + x = ~count, + color = as.formula(paste0("~", color_var)), + colors = bar_colors, + type = "bar", + orientation = "h", + customdata = ~customdata, + source = source + ) %>% + plotly::layout( + barmode = "stack", + xaxis = list(title = "Count"), + yaxis = list(title = "Adverse Event Type"), + legend = list(title = list(text = "AE Type")) + ) %>% + plotly::layout(dragmode = "select") + }, + df = str2lang(plot_dataname), + color_var = color_var, + y_var = y_var, + count_var = count_var, + bar_colors = bar_colors, + source = session$ns("bargraph") ) - - p }) output$plot <- plotly::renderPlotly({ - p <- plotly_q() - plotly::event_register(p, "plotly_selected") - p + plotly_q()$p %>% + set_plot_data(session$ns("plot_data")) |> + plotly::event_register("plotly_selected") + }) + plotly_selected <- reactive( + plotly::event_data("plotly_selected", source = session$ns("bargraph")) + ) + + reactive({ + if (is.null(plotly_selected())) { + plotly_q() + } else { + q <- plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + df <- df |> + dplyr::filter( + !!as.name(y_var_string) %in% selected_plot_data[[y_var_string]], + !!as.name(color_var_string) %in% selected_plot_data[[color_var_string]] + ) + }, + df = str2lang(plot_dataname), + y_var_string = y_var, + color_var_string = color_var, + plotly_selected_customdata = plotly_selected()$customdata + ) + attr(q, "has_brushing") <- TRUE + q + } }) }) } diff --git a/R/tm_p_double_bargraph.R b/R/tm_p_double_bargraph.R new file mode 100644 index 000000000..6dc8667ab --- /dev/null +++ b/R/tm_p_double_bargraph.R @@ -0,0 +1,67 @@ +#' @export +tm_p_doublebargraph <- function(label = "Bar Plot", + plot_dataname, + y_var, + color_var, + count_var, + secondary_y_var, + bar_colors = NULL) { + module( + label = label, + ui = ui_p_doublebargraph, + server = srv_p_doublebargraph, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + secondary_y_var = secondary_y_var, + bar_colors = bar_colors + ) + ) +} + +ui_p_doublebargraph <- function(id) { + ns <- NS(id) + bslib::page_fluid( + ui_p_bargraph(ns("main_bargraph")), + ui_p_bargraph(ns("secondary_bargraph")) + ) +} + +srv_p_doublebargraph <- function(id, + data, + plot_dataname, + y_var, + color_var, + count_var, + secondary_y_var, + bar_colors) { + moduleServer(id, function(input, output, session) { + plot_q <- srv_p_bargraph( + "main_bargraph", + data = data, + plot_dataname = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + bar_colors = bar_colors + ) + + brushed_q <- reactive({ + req(attr(plot_q(), "has_brushing")) + plot_q() + }) + + srv_p_bargraph( + "secondary_bargraph", + data = brushed_q, + plot_dataname = plot_dataname, + y_var = secondary_y_var, + color_var = color_var, + count_var = count_var, + bar_colors = bar_colors + ) + }) +} From 4b0a1a70053d5efd8116a6896b8282f4b6f69656 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 15 Sep 2025 15:39:02 +0530 Subject: [PATCH 127/158] docs: rename double bargraph to drilldown bargraph + add docs --- NAMESPACE | 1 + R/tm_p_bargraph.R | 56 ++++++++++++++ R/tm_p_double_bargraph.R | 67 ----------------- R/tm_p_drilldown_bargraph.R | 131 +++++++++++++++++++++++++++++++++ man/tm_p_bargraph.Rd | 77 +++++++++++++++++++ man/tm_p_drilldown_bargraph.Rd | 87 ++++++++++++++++++++++ 6 files changed, 352 insertions(+), 67 deletions(-) delete mode 100644 R/tm_p_double_bargraph.R create mode 100644 R/tm_p_drilldown_bargraph.R create mode 100644 man/tm_p_bargraph.Rd create mode 100644 man/tm_p_drilldown_bargraph.Rd diff --git a/NAMESPACE b/NAMESPACE index b68204a65..39506ce83 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,7 @@ export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) export(tm_p_bargraph) +export(tm_p_drilldown_bargraph) export(tm_p_lineplot) export(tm_p_scatterlineplot) export(tm_p_scatterplot) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 8f55fbb0a..022e36848 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -1,3 +1,59 @@ +#' Bar Graph Module +#' +#' This module creates an interactive horizontal stacked bar chart visualization that +#' displays counts of distinct values grouped by categories. The bars are automatically +#' ordered by total count (ascending) and support color coding by a categorical variable. +#' Users can select bar segments by brushing to filter the underlying data. The plot +#' aggregates data by counting distinct values within each group combination. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param y_var (`character(1)`) Name of the categorical variable to be displayed on y-axis (bar categories). +#' @param color_var (`character(1)`) Name of the categorical variable used for color coding and stacking segments. +#' @param count_var (`character(1)`) Name of the variable whose distinct values will be counted for bar heights. +#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash"), +#' 100, +#' replace = TRUE, prob = c(0.3, 0.25, 0.2, 0.15, 0.1) +#' ), +#' severity = sample(c("Mild", "Moderate", "Severe"), 100, +#' replace = TRUE, +#' prob = c(0.6, 0.3, 0.1) +#' ), +#' subject_id = sample(paste0("S", 1:30), 100, replace = TRUE), +#' treatment = sample(c("Active", "Placebo"), 100, replace = TRUE) +#' ) +#' +#' # Add labels +#' attr(df$adverse_event, "label") <- "Adverse Event Type" +#' attr(df$severity, "label") <- "Severity Grade" +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$treatment, "label") <- "Treatment Group" +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_bargraph( +#' label = "AE by Treatment", +#' plot_dataname = "df", +#' y_var = "adverse_event", +#' color_var = "treatment", +#' count_var = "subject_id", +#' bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4") +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_p_bargraph <- function(label = "Bar Plot", plot_dataname, diff --git a/R/tm_p_double_bargraph.R b/R/tm_p_double_bargraph.R deleted file mode 100644 index 6dc8667ab..000000000 --- a/R/tm_p_double_bargraph.R +++ /dev/null @@ -1,67 +0,0 @@ -#' @export -tm_p_doublebargraph <- function(label = "Bar Plot", - plot_dataname, - y_var, - color_var, - count_var, - secondary_y_var, - bar_colors = NULL) { - module( - label = label, - ui = ui_p_doublebargraph, - server = srv_p_doublebargraph, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - y_var = y_var, - color_var = color_var, - count_var = count_var, - secondary_y_var = secondary_y_var, - bar_colors = bar_colors - ) - ) -} - -ui_p_doublebargraph <- function(id) { - ns <- NS(id) - bslib::page_fluid( - ui_p_bargraph(ns("main_bargraph")), - ui_p_bargraph(ns("secondary_bargraph")) - ) -} - -srv_p_doublebargraph <- function(id, - data, - plot_dataname, - y_var, - color_var, - count_var, - secondary_y_var, - bar_colors) { - moduleServer(id, function(input, output, session) { - plot_q <- srv_p_bargraph( - "main_bargraph", - data = data, - plot_dataname = plot_dataname, - y_var = y_var, - color_var = color_var, - count_var = count_var, - bar_colors = bar_colors - ) - - brushed_q <- reactive({ - req(attr(plot_q(), "has_brushing")) - plot_q() - }) - - srv_p_bargraph( - "secondary_bargraph", - data = brushed_q, - plot_dataname = plot_dataname, - y_var = secondary_y_var, - color_var = color_var, - count_var = count_var, - bar_colors = bar_colors - ) - }) -} diff --git a/R/tm_p_drilldown_bargraph.R b/R/tm_p_drilldown_bargraph.R new file mode 100644 index 000000000..2ebe5e313 --- /dev/null +++ b/R/tm_p_drilldown_bargraph.R @@ -0,0 +1,131 @@ +#' Drilldown Bar Graph Module +#' +#' This module creates two synchronized interactive bar chart visualizations displayed +#' vertically. The top bar chart allows users to select segments by brushing, and the +#' bottom bar chart automatically updates to show a different categorical breakdown of +#' the selected data. Both charts use the same color coding and count variables but +#' display different categorical variables on their y-axes. This is particularly useful +#' for drill-down analysis and exploring relationships between different categorical dimensions. +#' +#' @param label (`character(1)`) Label shown in the navigation item for the module. +#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param y_var (`character(1)`) Name of the categorical variable for the main (top) bar chart y-axis. +#' @param color_var (`character(1)`) Name of the categorical variable used for color coding in both charts. +#' @param count_var (`character(1)`) Name of the variable whose distinct values will be counted for bar heights in both charts. +#' @param secondary_y_var (`character(1)`) Name of the categorical variable for the secondary (bottom) bar chart y-axis. +#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' df <- data.frame( +#' adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness"), +#' 150, +#' replace = TRUE, prob = c(0.4, 0.3, 0.2, 0.1) +#' ), +#' severity = sample(c("Mild", "Moderate", "Severe"), 150, +#' replace = TRUE, +#' prob = c(0.6, 0.3, 0.1) +#' ), +#' system_organ_class = sample(c("Nervous System", "Gastrointestinal", "General"), +#' 150, +#' replace = TRUE, prob = c(0.5, 0.3, 0.2) +#' ), +#' subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), +#' treatment = sample(c("Active", "Placebo"), 150, replace = TRUE) +#' ) +#' +#' # Add labels +#' attr(df$adverse_event, "label") <- "Adverse Event Term" +#' attr(df$severity, "label") <- "Severity Grade" +#' attr(df$system_organ_class, "label") <- "System Organ Class" +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$treatment, "label") <- "Treatment Group" +#' }) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_drilldown_bargraph( +#' label = "SOC to Term Breakdown", +#' plot_dataname = "df", +#' y_var = "system_organ_class", +#' color_var = "treatment", +#' count_var = "subject_id", +#' secondary_y_var = "adverse_event", +#' bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @export +tm_p_drilldown_bargraph <- function(label = "Bar Plot", + plot_dataname, + y_var, + color_var, + count_var, + secondary_y_var, + bar_colors = NULL) { + module( + label = label, + ui = ui_p_drilldown_bargraph, + server = srv_p_drilldown_bargraph, + ui_args = list(), + server_args = list( + plot_dataname = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + secondary_y_var = secondary_y_var, + bar_colors = bar_colors + ) + ) +} + +ui_p_drilldown_bargraph <- function(id) { + ns <- NS(id) + bslib::page_fluid( + ui_p_bargraph(ns("main_bargraph")), + ui_p_bargraph(ns("secondary_bargraph")) + ) +} + +srv_p_drilldown_bargraph <- function(id, + data, + plot_dataname, + y_var, + color_var, + count_var, + secondary_y_var, + bar_colors) { + moduleServer(id, function(input, output, session) { + plot_q <- srv_p_bargraph( + "main_bargraph", + data = data, + plot_dataname = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + bar_colors = bar_colors + ) + + brushed_q <- reactive({ + req(attr(plot_q(), "has_brushing")) + plot_q() + }) + + srv_p_bargraph( + "secondary_bargraph", + data = brushed_q, + plot_dataname = plot_dataname, + y_var = secondary_y_var, + color_var = color_var, + count_var = count_var, + bar_colors = bar_colors + ) + }) +} diff --git a/man/tm_p_bargraph.Rd b/man/tm_p_bargraph.Rd new file mode 100644 index 000000000..7277db337 --- /dev/null +++ b/man/tm_p_bargraph.Rd @@ -0,0 +1,77 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_bargraph.R +\name{tm_p_bargraph} +\alias{tm_p_bargraph} +\title{Bar Graph Module} +\usage{ +tm_p_bargraph( + label = "Bar Plot", + plot_dataname, + y_var, + color_var, + count_var, + bar_colors = NULL +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{y_var}{(\code{character(1)}) Name of the categorical variable to be displayed on y-axis (bar categories).} + +\item{color_var}{(\code{character(1)}) Name of the categorical variable used for color coding and stacking segments.} + +\item{count_var}{(\code{character(1)}) Name of the variable whose distinct values will be counted for bar heights.} + +\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} +} +\description{ +This module creates an interactive horizontal stacked bar chart visualization that +displays counts of distinct values grouped by categories. The bars are automatically +ordered by total count (ascending) and support color coding by a categorical variable. +Users can select bar segments by brushing to filter the underlying data. The plot +aggregates data by counting distinct values within each group combination. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash"), + 100, + replace = TRUE, prob = c(0.3, 0.25, 0.2, 0.15, 0.1) + ), + severity = sample(c("Mild", "Moderate", "Severe"), 100, + replace = TRUE, + prob = c(0.6, 0.3, 0.1) + ), + subject_id = sample(paste0("S", 1:30), 100, replace = TRUE), + treatment = sample(c("Active", "Placebo"), 100, replace = TRUE) + ) + + # Add labels + attr(df$adverse_event, "label") <- "Adverse Event Type" + attr(df$severity, "label") <- "Severity Grade" + attr(df$subject_id, "label") <- "Subject ID" + attr(df$treatment, "label") <- "Treatment Group" + }) + +app <- init( + data = data, + modules = modules( + tm_p_bargraph( + label = "AE by Treatment", + plot_dataname = "df", + y_var = "adverse_event", + color_var = "treatment", + count_var = "subject_id", + bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4") + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} diff --git a/man/tm_p_drilldown_bargraph.Rd b/man/tm_p_drilldown_bargraph.Rd new file mode 100644 index 000000000..93312d928 --- /dev/null +++ b/man/tm_p_drilldown_bargraph.Rd @@ -0,0 +1,87 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_drilldown_bargraph.R +\name{tm_p_drilldown_bargraph} +\alias{tm_p_drilldown_bargraph} +\title{Drilldown Bar Graph Module} +\usage{ +tm_p_drilldown_bargraph( + label = "Bar Plot", + plot_dataname, + y_var, + color_var, + count_var, + secondary_y_var, + bar_colors = NULL +) +} +\arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} + +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + +\item{y_var}{(\code{character(1)}) Name of the categorical variable for the main (top) bar chart y-axis.} + +\item{color_var}{(\code{character(1)}) Name of the categorical variable used for color coding in both charts.} + +\item{count_var}{(\code{character(1)}) Name of the variable whose distinct values will be counted for bar heights in both charts.} + +\item{secondary_y_var}{(\code{character(1)}) Name of the categorical variable for the secondary (bottom) bar chart y-axis.} + +\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} +} +\description{ +This module creates two synchronized interactive bar chart visualizations displayed +vertically. The top bar chart allows users to select segments by brushing, and the +bottom bar chart automatically updates to show a different categorical breakdown of +the selected data. Both charts use the same color coding and count variables but +display different categorical variables on their y-axes. This is particularly useful +for drill-down analysis and exploring relationships between different categorical dimensions. +} +\examples{ +data <- teal_data() |> + within({ + df <- data.frame( + adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness"), + 150, + replace = TRUE, prob = c(0.4, 0.3, 0.2, 0.1) + ), + severity = sample(c("Mild", "Moderate", "Severe"), 150, + replace = TRUE, + prob = c(0.6, 0.3, 0.1) + ), + system_organ_class = sample(c("Nervous System", "Gastrointestinal", "General"), + 150, + replace = TRUE, prob = c(0.5, 0.3, 0.2) + ), + subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), + treatment = sample(c("Active", "Placebo"), 150, replace = TRUE) + ) + + # Add labels + attr(df$adverse_event, "label") <- "Adverse Event Term" + attr(df$severity, "label") <- "Severity Grade" + attr(df$system_organ_class, "label") <- "System Organ Class" + attr(df$subject_id, "label") <- "Subject ID" + attr(df$treatment, "label") <- "Treatment Group" + }) + +app <- init( + data = data, + modules = modules( + tm_p_drilldown_bargraph( + label = "SOC to Term Breakdown", + plot_dataname = "df", + y_var = "system_organ_class", + color_var = "treatment", + count_var = "subject_id", + secondary_y_var = "adverse_event", + bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} From a78a08365a9139b0cac634ad42b516ee2fcf61e3 Mon Sep 17 00:00:00 2001 From: vedhav Date: Mon, 15 Sep 2025 19:24:30 +0530 Subject: [PATCH 128/158] fix: update examples with `tooltip_vars` usage and fix errors related to it --- R/tm_p_bargraph.R | 2 +- R/tm_p_lineplot.R | 23 ++++++++++--------- R/tm_p_scatterlineplot.R | 14 +++++++---- R/tm_p_scatterplot.R | 28 +++++----------------- R/tm_p_spaghetti.R | 29 ++++++++++++----------- R/tm_p_spaghettiline.R | 20 ++++++++++------ R/tm_p_spiderplot.R | 46 +++++++++++++++++++++++++++++-------- R/tm_p_swimlane.R | 3 ++- R/tm_p_swimlane_table.R | 4 +++- R/tm_p_waterfall.R | 1 + man/tm_p_lineplot.Rd | 5 ++-- man/tm_p_scatterlineplot.Rd | 4 +++- man/tm_p_scatterplot.Rd | 24 ++++--------------- man/tm_p_spaghetti.Rd | 5 ++-- man/tm_p_spaghettiline.Rd | 4 +++- man/tm_p_spiderplot.Rd | 3 ++- man/tm_p_swimlane.Rd | 3 ++- man/tm_p_swimlane_table.Rd | 3 ++- man/tm_p_waterfall.Rd | 1 + 19 files changed, 122 insertions(+), 100 deletions(-) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 022e36848..98208a751 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -105,7 +105,7 @@ srv_p_bargraph <- function(id, plot_data <- df %>% dplyr::group_by(!!as.name(y_var), !!as.name(color_var)) %>% - dplyr::summarize(count = n_distinct(!!as.name(count_var)), .groups = "drop") %>% + dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var)), .groups = "drop") %>% dplyr::mutate(customdata = dplyr::row_number()) event_type_order <- plot_data %>% diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index 337a37977..f6fcb8c68 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -29,7 +29,7 @@ #' treatment = rep(c("Active", "Placebo"), each = 20), #' baseline = rep(rnorm(8, 18, 2), each = 5) #' ) -#' +#' #' # Add labels #' attr(df$subject_id, "label") <- "Subject ID" #' attr(df$time_week, "label") <- "Time (weeks)" @@ -37,7 +37,7 @@ #' attr(df$treatment, "label") <- "Treatment Group" #' attr(df$baseline, "label") <- "Baseline Value" #' }) -#' +#' #' # Basic line plot example #' app <- init( #' data = data, @@ -48,11 +48,12 @@ #' x_var = "time_week", #' y_var = "measurement", #' color_var = "treatment", -#' group_var = "subject_id" +#' group_var = "subject_id", +#' tooltip_vars = c("subject_id", "time_week") #' ) #' ) #' ) -#' +#' #' if (interactive()) { #' shinyApp(app$ui, app$server) #' } @@ -119,17 +120,17 @@ srv_p_lineplot <- function(id, within( { validate(need(nrow(df) > 0, "No data after applying filters.")) - + # Get label attributes for variables, fallback to column names group_var_label <- attr(df[[group_var]], "label") if (!length(group_var_label)) group_var_label <- group_var - + x_var_label <- attr(df[[x_var]], "label") if (!length(x_var_label)) x_var_label <- x_var - + y_var_label <- attr(df[[y_var]], "label") if (!length(y_var_label)) y_var_label <- y_var - + color_var_label <- attr(df[[color_var]], "label") if (!length(color_var_label)) color_var_label <- color_var @@ -233,9 +234,9 @@ srv_p_lineplot <- function(id, dplyr::arrange(!!as.name(group_var), !!as.name(x_var)) %>% dplyr::group_by(!!as.name(group_var)) %>% dplyr::mutate( - xend = lead(!!as.name(x_var)), - yend = lead(!!as.name(y_var)), - color_var_seg = lead(!!as.name(color_var)) + xend = dplyr::lead(!!as.name(x_var)), + yend = dplyr::lead(!!as.name(y_var)), + color_var_seg = dplyr::lead(!!as.name(color_var)) ) %>% dplyr::filter(!is.na(xend)) diff --git a/R/tm_p_scatterlineplot.R b/R/tm_p_scatterlineplot.R index d822ddb14..5339e8dd4 100644 --- a/R/tm_p_scatterlineplot.R +++ b/R/tm_p_scatterlineplot.R @@ -3,7 +3,7 @@ #' This module creates a combined visualization with both scatter plot and line plot views. #' It displays a scatter plot where users can select points, and the selection is reflected #' in a corresponding line plot below. -#' +#' #' The line plot uses `subject_var` as the grouping variable to connect points with lines. #' When no selection is made in the scatter plot, the line plot shows all data. #' @@ -27,7 +27,7 @@ #' treatment = rep(c("A", "B", "A"), each = 4) #' ) #' }) -#' +#' #' app <- init( #' data = data, #' modules = modules( @@ -37,11 +37,12 @@ #' subject_var = "subject_id", #' x_var = "time_point", #' y_var = "response", -#' color_var = "treatment" +#' color_var = "treatment", +#' tooltip_vars = c("subject_id", "treatment") #' ) #' ) #' ) -#' +#' #' if (interactive()) { #' shinyApp(app$ui, app$server) #' } @@ -53,6 +54,7 @@ tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", x_var, y_var, color_var, + tooltip_vars = NULL, point_colors = character(0), transformators = list(), reference_lines = NULL) { @@ -66,6 +68,7 @@ tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", subject_var = subject_var, x_var = x_var, y_var = y_var, + tooltip_vars = tooltip_vars, color_var = color_var, point_colors = point_colors, reference_lines = reference_lines @@ -88,6 +91,7 @@ srv_p_scatterlineplot <- function(id, subject_var, x_var, y_var, + tooltip_vars, color_var, point_colors, reference_lines) { @@ -100,6 +104,7 @@ srv_p_scatterlineplot <- function(id, x_var = x_var, y_var = y_var, color_var = color_var, + tooltip_vars = tooltip_vars, point_colors = point_colors, show_widgets = FALSE ) @@ -112,6 +117,7 @@ srv_p_scatterlineplot <- function(id, color_var = color_var, group_var = subject_var, colors = point_colors, + tooltip_vars = tooltip_vars, reference_lines = reference_lines, activate_on_brushing = TRUE ) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 36417ead6..3fa69b52b 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -27,30 +27,14 @@ #' treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), #' gender = sample(c("M", "F"), 50, replace = TRUE) #' ) -#' +#' #' # Add labels for better tooltips #' attr(df$age, "label") <- "Age (years)" #' attr(df$response, "label") <- "Response Score" #' attr(df$treatment, "label") <- "Treatment Group" #' }) -#' -#' # Default tooltip example -#' app1 <- init( -#' data = data, -#' modules = modules( -#' tm_p_scatterplot( -#' label = "Scatter Plot", -#' plot_dataname = "df", -#' subject_var = "subject_id", -#' x_var = "age", -#' y_var = "response", -#' color_var = "treatment" -#' ) -#' ) -#' ) -#' -#' # Custom tooltip example -#' app2 <- init( +#' +#' app <- init( #' data = data, #' modules = modules( #' tm_p_scatterplot( @@ -60,13 +44,13 @@ #' x_var = "age", #' y_var = "response", #' color_var = "treatment", -#' tooltip_vars = c("subject_id", "age", "gender", "treatment") +#' tooltip_vars = c("age", "gender") #' ) #' ) #' ) -#' +#' #' if (interactive()) { -#' shinyApp(app1$ui, app1$server) +#' shinyApp(app$ui, app$server) #' } #' #' @export diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index fbbe048a8..63360a0ce 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -1,9 +1,9 @@ #' Spaghetti Plot Module #' -#' This module creates an interactive spaghetti plot visualization that shows individual -#' trajectories for each group over time. Each trajectory is represented by connected -#' points and lines, creating a "spaghetti-like" appearance. The plot supports customizable -#' tooltips and color coding by categorical variables. Users can select points by brushing +#' This module creates an interactive spaghetti plot visualization that shows individual +#' trajectories for each group over time. Each trajectory is represented by connected +#' points and lines, creating a "spaghetti-like" appearance. The plot supports customizable +#' tooltips and color coding by categorical variables. Users can select points by brushing #' to filter the underlying data. #' #' @param label (`character(1)`) Label shown in the navigation item for the module. @@ -28,14 +28,14 @@ #' treatment = rep(c("Active", "Placebo"), each = 20), #' age_group = rep(c("Young", "Old"), 20) #' ) -#' +#' #' # Add labels #' attr(df$subject_id, "label") <- "Subject ID" #' attr(df$time_point, "label") <- "Time Point (days)" #' attr(df$response, "label") <- "Response Score" #' attr(df$treatment, "label") <- "Treatment Group" #' }) -#' +#' #' # Default tooltip example #' app <- init( #' data = data, @@ -46,11 +46,12 @@ #' group_var = "subject_id", #' x_var = "time_point", #' y_var = "response", -#' color_var = "treatment" +#' color_var = "treatment", +#' tooltip_vars = c("subject_id", "treatment") #' ) #' ) #' ) -#' +#' #' if (interactive()) { #' shinyApp(app$ui, app$server) #' } @@ -140,13 +141,13 @@ srv_p_spaghetti <- function(id, # Get label attributes for variables, fallback to column names group_var_label <- attr(df[[group_var]], "label") if (!length(group_var_label)) group_var_label <- group_var - + x_var_label <- attr(df[[x_var]], "label") if (!length(x_var_label)) x_var_label <- x_var - + y_var_label <- attr(df[[y_var]], "label") if (!length(y_var_label)) y_var_label <- y_var - + color_var_label <- attr(df[[color_var]], "label") if (!length(color_var_label)) color_var_label <- color_var @@ -209,9 +210,9 @@ srv_p_spaghetti <- function(id, dplyr::mutate( x = !!as.name(x_var), y = !!as.name(y_var), - xend = lead(!!as.name(x_var)), - yend = lead(!!as.name(y_var)), - color_var_seg = lead(!!as.name(color_var)) + xend = dplyr::lead(!!as.name(x_var)), + yend = dplyr::lead(!!as.name(y_var)), + color_var_seg = dplyr::lead(!!as.name(color_var)) ) %>% dplyr::filter(!is.na(xend)) diff --git a/R/tm_p_spaghettiline.R b/R/tm_p_spaghettiline.R index ac7efa887..e9af79788 100644 --- a/R/tm_p_spaghettiline.R +++ b/R/tm_p_spaghettiline.R @@ -4,14 +4,14 @@ #' It displays a spaghetti plot where users can select points, and the selection is reflected #' in a corresponding line plot below. The spaghetti plot shows individual trajectories for #' each group over time. -#' +#' #' The spaghetti plot connects points within each `group_var` level to show individual trajectories. #' The line plot uses the same `group_var` for grouping and updates to show only the selected data #' when brushing occurs in the spaghetti plot. -#' +#' #' @param label (`character(1)`) Label shown in the navigation item for the module. #' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param group_var (`character(1)`) Name of the grouping variable used for creating individual +#' @param group_var (`character(1)`) Name of the grouping variable used for creating individual #' trajectories in the spaghetti plot and grouping in the line plot. #' @param x_var (`character(1)`) Name of the variable to be used for x-axis in both plots. #' @param y_var (`character(1)`) Name of the variable to be used for y-axis in both plots. @@ -30,7 +30,7 @@ #' treatment = rep(c("A", "B", "A", "B"), each = 4) #' ) #' }) -#' +#' #' app <- init( #' data = data, #' modules = modules( @@ -40,11 +40,12 @@ #' group_var = "subject_id", #' x_var = "time_point", #' y_var = "response", -#' color_var = "treatment" +#' color_var = "treatment", +#' tooltip_vars = c("subject_id", "treatment") #' ) #' ) #' ) -#' +#' #' if (interactive()) { #' shinyApp(app$ui, app$server) #' } @@ -56,6 +57,7 @@ tm_p_spaghettiline <- function(label = "Scatter + Line Plot", x_var, y_var, color_var, + tooltip_vars = NULL, point_colors = character(0), transformators = list(), reference_lines = NULL) { @@ -71,7 +73,8 @@ tm_p_spaghettiline <- function(label = "Scatter + Line Plot", y_var = y_var, color_var = color_var, point_colors = point_colors, - reference_lines = reference_lines + reference_lines = reference_lines, + tooltip_vars = tooltip_vars ), transformators = transformators ) @@ -92,6 +95,7 @@ srv_p_spaghettiline <- function(id, x_var, y_var, color_var, + tooltip_vars, point_colors, reference_lines) { moduleServer(id, function(input, output, session) { @@ -103,6 +107,7 @@ srv_p_spaghettiline <- function(id, x_var = x_var, y_var = y_var, color_var = color_var, + tooltip_vars = tooltip_vars, point_colors = point_colors, show_widgets = FALSE ) @@ -116,6 +121,7 @@ srv_p_spaghettiline <- function(id, color_var = color_var, group_var = group_var, colors = point_colors, + tooltip_vars = tooltip_vars, reference_lines = reference_lines, activate_on_brushing = TRUE ) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 0d825f32b..56a3cb460 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -75,7 +75,8 @@ #' ), #' point_symbols = c( #' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" -#' ) +#' ), +#' tooltip_vars = c("subject_var") #' ) #' ) #' ) @@ -259,6 +260,8 @@ srv_p_spiderplot <- function(id, if (!length(time_var_label)) time_var_label <- time_var value_var_label <- attr(plot_data[[value_var]], "label") if (!length(value_var_label)) value_var_label <- value_var + color_var_label <- attr(plot_data[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var plot_data <- plot_data |> dplyr::mutate(customdata = dplyr::row_number()) @@ -269,11 +272,13 @@ srv_p_spiderplot <- function(id, } p <- plot_data %>% + dplyr::ungroup() %>% dplyr::mutate( x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), tooltip = { if (is.null(tooltip_vars)) { + # Default tooltip: show subject, x, y, color variables with labels sprintf( "%s: %s
%s: %s
%s: %s%%
", subject_var_label, !!as.name(subject_var), @@ -281,16 +286,37 @@ srv_p_spiderplot <- function(id, value_var_label, !!as.name(value_var) * 100 ) } else { - tooltip_lines <- sapply(tooltip_vars, function(col) { - label <- attr(dataname[[col]], "label") - if (!length(label)) label <- col - value <- .data[[col]] - paste0(label, ": ", value) - }) - if (is.vector(tooltip_lines)) { - paste(tooltip_lines, collapse = "
") + # Custom tooltip: show only specified columns + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars, names(cur_data)) + if (!length(cols)) { + # Fallback to default if no valid columns found + sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var), + time_var_label, !!as.name(time_var), + value_var_label, !!as.name(value_var) * 100 + ) } else { - apply(tooltip_lines, 1, function(row) paste(row, collapse = "
")) + # Create tooltip from specified columns + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var) { + lb <- subject_var_label + } else if (cn == time_var) { + lb <- time_var_label + } else if (cn == value_var) { + lb <- value_var_label + } else if (cn == color_var) { + lb <- color_var_label + } else { + lb <- attr(sub[[cn]], "label") + } + if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn + }, character(1)) + values <- lapply(sub, as.character) + parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) + do.call(paste, c(parts, sep = "
")) } } } diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 6168985b7..1d1c1fed0 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -54,7 +54,8 @@ #' color_var = "color_var", #' group_var = "color_var", #' sort_var = "time_var", -#' plot_height = 400, +#' plot_height = c(700, 400, 1200), +#' tooltip_vars = c("subject_var", "color_var"), #' point_colors = c( #' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" #' ), diff --git a/R/tm_p_swimlane_table.R b/R/tm_p_swimlane_table.R index 3c89000b3..5df82b429 100644 --- a/R/tm_p_swimlane_table.R +++ b/R/tm_p_swimlane_table.R @@ -57,7 +57,8 @@ #' color_var = "color_var", #' group_var = "color_var", #' sort_var = "time_var", -#' plot_height = 400, +#' plot_height = c(700, 400, 1200), +#' tooltip_vars = c("subject_var", "color_var"), #' point_colors = c( #' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" #' ), @@ -162,6 +163,7 @@ srv_p_swimlane_table <- function(id, point_size = point_size, point_colors = point_colors, point_symbols = point_symbols, + tooltip_vars = tooltip_vars, show_widgets = FALSE ) diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index 2ecfdd788..f9b36c486 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -50,6 +50,7 @@ #' value_var = "value_var", #' sort_var = "value_var", #' color_var = "color_var", +#' tooltip_vars = c("value_var", "subjects"), #' value_arbitrary_hlines = c(20, -30), #' bar_colors = c( #' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd index f5fea6557..70f2f63aa 100644 --- a/man/tm_p_lineplot.Rd +++ b/man/tm_p_lineplot.Rd @@ -59,7 +59,7 @@ data <- teal_data() |> treatment = rep(c("Active", "Placebo"), each = 20), baseline = rep(rnorm(8, 18, 2), each = 5) ) - + # Add labels attr(df$subject_id, "label") <- "Subject ID" attr(df$time_week, "label") <- "Time (weeks)" @@ -78,7 +78,8 @@ app <- init( x_var = "time_week", y_var = "measurement", color_var = "treatment", - group_var = "subject_id" + group_var = "subject_id", + tooltip_vars = c("subject_id", "time_week") ) ) ) diff --git a/man/tm_p_scatterlineplot.Rd b/man/tm_p_scatterlineplot.Rd index 79d9bcf80..2a0c4f264 100644 --- a/man/tm_p_scatterlineplot.Rd +++ b/man/tm_p_scatterlineplot.Rd @@ -11,6 +11,7 @@ tm_p_scatterlineplot( x_var, y_var, color_var, + tooltip_vars = NULL, point_colors = character(0), transformators = list(), reference_lines = NULL @@ -64,7 +65,8 @@ app <- init( subject_var = "subject_id", x_var = "time_point", y_var = "response", - color_var = "treatment" + color_var = "treatment", + tooltip_vars = c("subject_id", "treatment") ) ) ) diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd index 5617032b9..79e402e92 100644 --- a/man/tm_p_scatterplot.Rd +++ b/man/tm_p_scatterplot.Rd @@ -55,30 +55,14 @@ data <- teal_data() |> treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), gender = sample(c("M", "F"), 50, replace = TRUE) ) - + # Add labels for better tooltips attr(df$age, "label") <- "Age (years)" attr(df$response, "label") <- "Response Score" attr(df$treatment, "label") <- "Treatment Group" }) -# Default tooltip example -app1 <- init( - data = data, - modules = modules( - tm_p_scatterplot( - label = "Scatter Plot", - plot_dataname = "df", - subject_var = "subject_id", - x_var = "age", - y_var = "response", - color_var = "treatment" - ) - ) -) - -# Custom tooltip example -app2 <- init( +app <- init( data = data, modules = modules( tm_p_scatterplot( @@ -88,13 +72,13 @@ app2 <- init( x_var = "age", y_var = "response", color_var = "treatment", - tooltip_vars = c("subject_id", "age", "gender", "treatment") + tooltip_vars = c("age", "gender") ) ) ) if (interactive()) { - shinyApp(app1$ui, app1$server) + shinyApp(app$ui, app$server) } } diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd index 31e7794cb..52a877fda 100644 --- a/man/tm_p_spaghetti.Rd +++ b/man/tm_p_spaghetti.Rd @@ -56,7 +56,7 @@ data <- teal_data() |> treatment = rep(c("Active", "Placebo"), each = 20), age_group = rep(c("Young", "Old"), 20) ) - + # Add labels attr(df$subject_id, "label") <- "Subject ID" attr(df$time_point, "label") <- "Time Point (days)" @@ -74,7 +74,8 @@ app <- init( group_var = "subject_id", x_var = "time_point", y_var = "response", - color_var = "treatment" + color_var = "treatment", + tooltip_vars = c("subject_id", "treatment") ) ) ) diff --git a/man/tm_p_spaghettiline.Rd b/man/tm_p_spaghettiline.Rd index e2f04b3fd..5bb4d2ced 100644 --- a/man/tm_p_spaghettiline.Rd +++ b/man/tm_p_spaghettiline.Rd @@ -11,6 +11,7 @@ tm_p_spaghettiline( x_var, y_var, color_var, + tooltip_vars = NULL, point_colors = character(0), transformators = list(), reference_lines = NULL @@ -67,7 +68,8 @@ app <- init( group_var = "subject_id", x_var = "time_point", y_var = "response", - color_var = "treatment" + color_var = "treatment", + tooltip_vars = c("subject_id", "treatment") ) ) ) diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 4fa8ad53e..a68e3b8a0 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -113,7 +113,8 @@ app <- init( ), point_symbols = c( CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) + ), + tooltip_vars = c("subject_var") ) ) ) diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 2f9b38872..85f7598fc 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -89,7 +89,8 @@ app <- init( color_var = "color_var", group_var = "color_var", sort_var = "time_var", - plot_height = 400, + plot_height = c(700, 400, 1200), + tooltip_vars = c("subject_var", "color_var"), point_colors = c( CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" ), diff --git a/man/tm_p_swimlane_table.Rd b/man/tm_p_swimlane_table.Rd index 2d45d21f1..c8177cbee 100644 --- a/man/tm_p_swimlane_table.Rd +++ b/man/tm_p_swimlane_table.Rd @@ -95,7 +95,8 @@ app <- init( color_var = "color_var", group_var = "color_var", sort_var = "time_var", - plot_height = 400, + plot_height = c(700, 400, 1200), + tooltip_vars = c("subject_var", "color_var"), point_colors = c( CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" ), diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index 20eb27aae..efb868a95 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -85,6 +85,7 @@ app <- init( value_var = "value_var", sort_var = "value_var", color_var = "color_var", + tooltip_vars = c("value_var", "subjects"), value_arbitrary_hlines = c(20, -30), bar_colors = c( CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" From b5d04e28e48f117680984f9fad3846993f939e53 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 16 Sep 2025 12:02:05 +0530 Subject: [PATCH 129/158] feat: add the ability to customize tooltips in bargraph --- R/tm_p_bargraph.R | 79 ++++++++++++++++++++++++++++++++-- R/tm_p_drilldown_bargraph.R | 6 +++ man/shared_params.Rd | 2 +- man/tm_p_bargraph.Rd | 7 ++- man/tm_p_drilldown_bargraph.Rd | 2 + 5 files changed, 90 insertions(+), 6 deletions(-) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 98208a751..65f8734d6 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -11,6 +11,8 @@ #' @param y_var (`character(1)`) Name of the categorical variable to be displayed on y-axis (bar categories). #' @param color_var (`character(1)`) Name of the categorical variable used for color coding and stacking segments. #' @param count_var (`character(1)`) Name of the variable whose distinct values will be counted for bar heights. +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created. #' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. #' #' @examples @@ -45,7 +47,8 @@ #' y_var = "adverse_event", #' color_var = "treatment", #' count_var = "subject_id", -#' bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4") +#' bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), +#' tooltip_vars = c("adverse_event", "treatment") #' ) #' ) #' ) @@ -60,6 +63,7 @@ tm_p_bargraph <- function(label = "Bar Plot", y_var, color_var, count_var, + tooltip_vars = NULL, bar_colors = NULL) { module( label = label, @@ -71,6 +75,7 @@ tm_p_bargraph <- function(label = "Bar Plot", y_var = y_var, color_var = color_var, count_var = count_var, + tooltip_vars = tooltip_vars, bar_colors = bar_colors ) ) @@ -82,7 +87,7 @@ ui_p_bargraph <- function(id) { bslib::card( full_screen = TRUE, tags$div( - # trigger_tooltips_deps(), + trigger_tooltips_deps(), plotly::plotlyOutput(ns("plot"), height = "100%") ) ) @@ -95,6 +100,7 @@ srv_p_bargraph <- function(id, y_var, color_var, count_var, + tooltip_vars = NULL, bar_colors) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ @@ -105,8 +111,69 @@ srv_p_bargraph <- function(id, plot_data <- df %>% dplyr::group_by(!!as.name(y_var), !!as.name(color_var)) %>% - dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var)), .groups = "drop") %>% - dplyr::mutate(customdata = dplyr::row_number()) + dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var))) %>% + dplyr::ungroup() %>% + dplyr::mutate(customdata = dplyr::row_number()) %>% + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars)) { + # Default tooltip: show y_var, color_var, and count + y_var_label <- attr(df[[y_var]], "label") + if (!length(y_var_label)) y_var_label <- y_var + color_var_label <- attr(df[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var + + paste( + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + paste("Count:", count), + sep = "
" + ) + } else { + # Custom tooltip: use specified columns + cur_data <- dplyr::cur_data() + + # Map tooltip_vars to actual column names if they are parameter names + actual_cols <- character(0) + for (col in tooltip_vars) { + if (col == "y_var") { + actual_cols <- c(actual_cols, y_var) + } else if (col == "color_var") { + actual_cols <- c(actual_cols, color_var) + } else if (col == "count_var") { + actual_cols <- c(actual_cols, "count") # Use the aggregated count column + } else { + # Assume it's already a column name + actual_cols <- c(actual_cols, col) + } + } + + # Get columns that actually exist in the data + cols <- intersect(actual_cols, names(cur_data)) + + if (!length(cols)) { + # Fallback to default + y_var_label <- attr(df[[y_var]], "label") + if (!length(y_var_label)) y_var_label <- y_var + color_var_label <- attr(df[[color_var]], "label") + if (!length(color_var_label)) color_var_label <- color_var + + paste( + paste(y_var_label, ":", !!as.name(y_var)), + paste(color_var_label, ":", !!as.name(color_var)), + paste("Count:", count), + sep = "
" + ) + } else { + # Create simple tooltip with column names and values + sub <- cur_data[cols] + values <- lapply(sub, as.character) + parts <- Map(function(v, n) paste0(n, ": ", v), values, names(values)) + do.call(paste, c(parts, sep = "
")) + } + } + } + ) event_type_order <- plot_data %>% dplyr::group_by(!!as.name(y_var)) %>% @@ -124,6 +191,8 @@ srv_p_bargraph <- function(id, colors = bar_colors, type = "bar", orientation = "h", + hovertext = ~tooltip, + hoverinfo = "text", customdata = ~customdata, source = source ) %>% @@ -139,6 +208,7 @@ srv_p_bargraph <- function(id, color_var = color_var, y_var = y_var, count_var = count_var, + tooltip_vars = tooltip_vars, bar_colors = bar_colors, source = session$ns("bargraph") ) @@ -148,6 +218,7 @@ srv_p_bargraph <- function(id, output$plot <- plotly::renderPlotly({ plotly_q()$p %>% set_plot_data(session$ns("plot_data")) |> + setup_trigger_tooltips(session$ns) |> plotly::event_register("plotly_selected") }) plotly_selected <- reactive( diff --git a/R/tm_p_drilldown_bargraph.R b/R/tm_p_drilldown_bargraph.R index 2ebe5e313..be7d9e688 100644 --- a/R/tm_p_drilldown_bargraph.R +++ b/R/tm_p_drilldown_bargraph.R @@ -53,6 +53,7 @@ #' color_var = "treatment", #' count_var = "subject_id", #' secondary_y_var = "adverse_event", +#' tooltip_vars = c("system_organ_class", "adverse_event", "treatment"), #' bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") #' ) #' ) @@ -69,6 +70,7 @@ tm_p_drilldown_bargraph <- function(label = "Bar Plot", color_var, count_var, secondary_y_var, + tooltip_vars = NULL, bar_colors = NULL) { module( label = label, @@ -81,6 +83,7 @@ tm_p_drilldown_bargraph <- function(label = "Bar Plot", color_var = color_var, count_var = count_var, secondary_y_var = secondary_y_var, + tooltip_vars = tooltip_vars, bar_colors = bar_colors ) ) @@ -101,6 +104,7 @@ srv_p_drilldown_bargraph <- function(id, color_var, count_var, secondary_y_var, + tooltip_vars, bar_colors) { moduleServer(id, function(input, output, session) { plot_q <- srv_p_bargraph( @@ -110,6 +114,7 @@ srv_p_drilldown_bargraph <- function(id, y_var = y_var, color_var = color_var, count_var = count_var, + tooltip_vars = tooltip_vars, bar_colors = bar_colors ) @@ -125,6 +130,7 @@ srv_p_drilldown_bargraph <- function(id, y_var = secondary_y_var, color_var = color_var, count_var = count_var, + tooltip_vars = tooltip_vars, bar_colors = bar_colors ) }) diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 979a02926..6c0cbfe2a 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -56,7 +56,7 @@ The decorators are applied to the respective output objects.} \item{table_datanames}{(\code{character}) names of the datasets which should be listed below the plot when some data points are selected. Objects named after \code{table_datanames} will be pulled from \code{data} so it is important that data actually contains these datasets. Please be aware that -table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[=join_keys]{join_keys()}}. +table datasets must be linked with \code{plot_dataname} by the relevant \code{\link[teal.data:join_keys]{teal.data::join_keys()}}. See section "Decorating Module" below for more details.} } \value{ diff --git a/man/tm_p_bargraph.Rd b/man/tm_p_bargraph.Rd index 7277db337..921e24e8e 100644 --- a/man/tm_p_bargraph.Rd +++ b/man/tm_p_bargraph.Rd @@ -10,6 +10,7 @@ tm_p_bargraph( y_var, color_var, count_var, + tooltip_vars = NULL, bar_colors = NULL ) } @@ -24,6 +25,9 @@ tm_p_bargraph( \item{count_var}{(\code{character(1)}) Name of the variable whose distinct values will be counted for bar heights.} +\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. +If \code{NULL}, default tooltip is created.} + \item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} } \description{ @@ -65,7 +69,8 @@ app <- init( y_var = "adverse_event", color_var = "treatment", count_var = "subject_id", - bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4") + bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), + tooltip_vars = c("adverse_event", "treatment") ) ) ) diff --git a/man/tm_p_drilldown_bargraph.Rd b/man/tm_p_drilldown_bargraph.Rd index 93312d928..a31af7fe3 100644 --- a/man/tm_p_drilldown_bargraph.Rd +++ b/man/tm_p_drilldown_bargraph.Rd @@ -11,6 +11,7 @@ tm_p_drilldown_bargraph( color_var, count_var, secondary_y_var, + tooltip_vars = NULL, bar_colors = NULL ) } @@ -75,6 +76,7 @@ app <- init( color_var = "treatment", count_var = "subject_id", secondary_y_var = "adverse_event", + tooltip_vars = c("system_organ_class", "adverse_event", "treatment"), bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") ) ) From e07755f5e307423f21db1f8442d92f679a89f0cf Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 16 Sep 2025 11:11:02 +0200 Subject: [PATCH 130/158] update --- R/tm_g_association.R | 223 ++++++++--------- R/tm_g_bivariate.R | 536 +++++++++++++++++++--------------------- R/tm_p_spiderplot.R | 53 ++-- man/tm_g_association.Rd | 7 +- man/tm_g_bivariate.Rd | 6 +- 5 files changed, 407 insertions(+), 418 deletions(-) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 5016472ba..51f258b63 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -146,8 +146,23 @@ #' @export #' tm_g_association <- function(label = "Association", - ref, - vars, + ref = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ) + ), + vars = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2, + multiple = TRUE + ) + ), show_association = TRUE, plot_height = c(600, 400, 5000), plot_width = NULL, @@ -161,21 +176,13 @@ tm_g_association <- function(label = "Association", message("Initializing tm_g_association") # Normalize the parameters - if (inherits(ref, "data_extract_spec")) ref <- list(ref) - if (inherits(vars, "data_extract_spec")) vars <- list(vars) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - - checkmate::assert_list(ref, types = "data_extract_spec") - if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) { - stop("'ref' should not allow multiple selection") - } - - checkmate::assert_list(vars, types = "data_extract_spec") + checkmate::assert_class(ref, "picks") + checkmate::assert_class(vars, "picks") checkmate::assert_flag(show_association) - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) @@ -197,35 +204,49 @@ tm_g_association <- function(label = "Association", assert_decorators(decorators, "plot") # End of assertions - # Make UI args - args <- as.list(environment()) - - data_extract_list <- list( - ref = ref, - vars = vars - ) - ans <- module( label = label, server = srv_tm_g_association, ui = ui_tm_g_association, - ui_args = args, - server_args = c( - data_extract_list, - list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) + ui_args = list( + ref = ref, + vars = vars, + show_association = show_association, + distribution_theme = distribution_theme, + association_theme = association_theme, + pre_output = pre_output, + post_output = post_output, + decorators = decorators + ), + server_args = list( + ref = ref, + vars = vars, + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators ), transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(ref = ref, vars = vars)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the association module -ui_tm_g_association <- function(id, ...) { +ui_tm_g_association <- function(id, + ref, + vars, + show_association, + distribution_theme, + association_theme, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -235,35 +256,18 @@ ui_tm_g_association <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("ref", "vars")]), - teal.transform::data_extract_ui( - id = ns("ref"), - label = "Reference variable", - data_extract_spec = args$ref, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("vars"), - label = "Associated variables", - data_extract_spec = args$vars, - is_single_dataset = is_single_dataset_value - ), - checkboxInput( - ns("association"), - "Association with reference variable", - value = args$show_association + teal::teal_nav_item( + label = tags$strong("Reference variable"), + teal.transform::module_input_ui(id = ns("ref"), spec = ref) ), - checkboxInput( - ns("show_dist"), - "Scaled frequencies", - value = FALSE + teal::teal_nav_item( + label = tags$strong("Associated variables"), + teal.transform::module_input_ui(id = ns("vars"), spec = vars), ), - checkboxInput( - ns("log_transformation"), - "Log transformed", - value = FALSE - ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + checkboxInput(ns("association"), "Association with reference variable", value = show_association), + checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), + checkboxInput(ns("log_transformation"), "Log transformed", value = FALSE), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -276,14 +280,14 @@ ui_tm_g_association <- function(id, ...) { inputId = ns("distribution_theme"), label = "Distribution theme (by ggplot):", choices = ggplot_themes, - selected = args$distribution_theme, + selected = distribution_theme, multiple = FALSE ), selectInput( inputId = ns("association_theme"), label = "Association theme (by ggplot):", choices = ggplot_themes, - selected = args$association_theme, + selected = association_theme, multiple = FALSE ) ) @@ -292,8 +296,8 @@ ui_tm_g_association <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } @@ -312,34 +316,27 @@ srv_tm_g_association <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(ref = ref, vars = vars), - datasets = data, - select_validation_rule = list( - ref = shinyvalidate::compose_rules( - shinyvalidate::sv_required("A reference variable needs to be selected."), - ~ if ((.) %in% selector_list()$vars()$select) { - "Associated variables and reference variable cannot overlap" - } - ), - vars = shinyvalidate::compose_rules( - shinyvalidate::sv_required("An associated variable needs to be selected."), - ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) { - "Associated variables and reference variable cannot overlap" - } - ) + selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "ref-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_required("A reference variable needs to be selected."), + ~ if (any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected)) { + "Associated variables and reference variable cannot overlap" + } ) ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list + iv$add_rule( + "vars-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_required("An associated variable needs to be selected."), + ~ if (any(selectors$vars()$variables$selected %in% selectors$ref()$variables$selected)) { + "Associated variables and reference variable cannot overlap" + } + ) ) + iv$enable() qenv <- reactive({ obj <- data() @@ -351,25 +348,21 @@ srv_tm_g_association <- function(id, ) teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("ggmosaic")') # nolint: quotes }) + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') # nolint quotes anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) + req(qenv()) + teal::validate_inputs(iv) + teal.transform::qenv_merge_selectors(x = qenv(), selectors = selectors) }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - output_q <- reactive({ - teal::validate_inputs(iv_r()) - - ANL <- merged$anl_q_r()[["ANL"]] - teal::validate_has_data(ANL, 3) + req(anl_merged_q()) + merged <- anl_merged_q()[["merged"]] + ref_name <- map_merged(selectors)$ref$variables + vars_names <- map_merged(selectors)$vars$variables + teal::validate_has_data(merged, 3) + teal::validate_has_data(merged[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) - vars_names <- merged$anl_input_r()$columns_source$vars - - ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) association <- input$association show_dist <- input$show_dist log_transformation <- input$log_transformation @@ -378,7 +371,7 @@ srv_tm_g_association <- function(id, distribution_theme <- input$distribution_theme association_theme <- input$association_theme - is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) + is_scatterplot <- is.numeric(merged[[ref_name]]) && any(vapply(merged[vars_names], is.numeric, logical(1))) if (is_scatterplot) { shinyjs::show("alpha") shinyjs::show("size") @@ -391,19 +384,17 @@ srv_tm_g_association <- function(id, size <- 2 } - teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) - # reference - ref_class <- class(ANL[[ref_name]])[1] - if (is.numeric(ANL[[ref_name]]) && log_transformation) { + ref_class <- class(merged[[ref_name]])[1] + if (is.numeric(merged[[ref_name]]) && log_transformation) { # works for both integers and doubles ref_cl_name <- call("log", as.name(ref_name)) - ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") + ref_cl_lbl <- varname_w_label(ref_name, merged, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not ref_cl_name <- as.name(ref_name) - ref_cl_lbl <- varname_w_label(ref_name, ANL) + ref_cl_lbl <- varname_w_label(ref_name, merged) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -412,7 +403,7 @@ srv_tm_g_association <- function(id, ) ref_call <- bivariate_plot_call( - data_name = "ANL", + data_name = "merged", x = ref_cl_name, x_class = ref_class, x_label = ref_cl_lbl, @@ -429,16 +420,15 @@ srv_tm_g_association <- function(id, ref_class_cov <- ifelse(association, ref_class, "NULL") var_calls <- lapply(vars_names, function(var_i) { - var_class <- class(ANL[[var_i]])[1] - if (is.numeric(ANL[[var_i]]) && log_transformation) { + if (is.numeric(merged[[var_i]]) && log_transformation) { # works for both integers and doubles var_cl_name <- call("log", as.name(var_i)) - var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") + var_cl_lbl <- varname_w_label(var_i, merged, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not var_cl_name <- as.name(var_i) - var_cl_lbl <- varname_w_label(var_i, ANL) + var_cl_lbl <- varname_w_label(var_i, merged) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -447,11 +437,11 @@ srv_tm_g_association <- function(id, ) bivariate_plot_call( - data_name = "ANL", + data_name = "merged", x = ref_cl_name, y = var_cl_name, x_class = ref_class_cov, - y_class = var_class, + y_class = class(merged[[var_i]])[1], x_label = ref_cl_lbl, y_label = var_cl_lbl, theme = association_theme, @@ -466,10 +456,10 @@ srv_tm_g_association <- function(id, # helper function to format variable name format_varnames <- function(x) { - if (is.numeric(ANL[[x]]) && log_transformation) { - varname_w_label(x, ANL, prefix = "Log of ") + if (is.numeric(merged[[x]]) && log_transformation) { + varname_w_label(x, merged, prefix = "Log of ") } else { - varname_w_label(x, ANL) + varname_w_label(x, merged) } } new_title <- @@ -497,7 +487,7 @@ srv_tm_g_association <- function(id, ) ) } - obj <- merged$anl_q_r() + obj <- anl_merged_q() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") teal.code::eval_code( obj, @@ -534,7 +524,6 @@ srv_tm_g_association <- function(id, ) plot_r <- reactive({ - req(iv_r()$is_valid()) req(decorated_output_grob_q())[["plot"]] }) diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index a2099ae36..06e449721 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -192,8 +192,22 @@ #' @export #' tm_g_bivariate <- function(label = "Bivariate Plots", - x, - y, + x = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ) + ), + y = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2 + ) + ), row_facet = NULL, col_facet = NULL, facet = !is.null(row_facet) || !is.null(col_facet), @@ -216,41 +230,36 @@ tm_g_bivariate <- function(label = "Bivariate Plots", decorators = list()) { message("Initializing tm_g_bivariate") - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) - if (inherits(color, "data_extract_spec")) color <- list(color) - if (inherits(fill, "data_extract_spec")) fill <- list(fill) - if (inherits(size, "data_extract_spec")) size <- list(size) + + extracted_filters <- extract_filters(list(x, y, row_facet, col_facet, color, fill, size)) + transformators <- c( + transformators, + lapply(extracted_filters, teal.transform:::teal_transform_filter) + ) + x <- des_to_picks(x) + y <- des_to_picks(y) + row_facet <- des_to_picks(row_facet) + col_facet <- des_to_picks(col_facet) + color <- des_to_picks(color) + fill <- des_to_picks(fill) + size <- des_to_picks(size) # Start of assertions + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + if (attr(x$variables, "multiple")) { + warning("`x`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + if (attr(y$variables, "multiple")) { + warning("`y`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(color, "picks", null.ok = TRUE) + checkmate::assert_class(size, "picks", null.ok = TRUE) checkmate::assert_string(label) - - checkmate::assert_list(x, types = "data_extract_spec") - assert_single_selection(x) - - checkmate::assert_list(y, types = "data_extract_spec") - assert_single_selection(y) - - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(row_facet) - - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(col_facet) - - checkmate::assert_flag(facet) - - checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(color) - - checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(fill) - - checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(size) - checkmate::assert_flag(use_density) # Determines color, fill & size if they are not explicitly set @@ -258,15 +267,15 @@ tm_g_bivariate <- function(label = "Bivariate Plots", if (color_settings) { if (is.null(color)) { color <- x - color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) + color$selected <- NULL } if (is.null(fill)) { fill <- x - fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) + fill$selected <- NULL } if (is.null(size)) { size <- x - size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) + size$selected <- NULL } } else { if (!is.null(c(color, fill, size))) { @@ -300,177 +309,152 @@ tm_g_bivariate <- function(label = "Bivariate Plots", # Make UI args args <- as.list(environment()) - data_extract_list <- list( - x = x, - y = y, - row_facet = row_facet, - col_facet = col_facet, - color_settings = color_settings, - color = color, - fill = fill, - size = size - ) - ans <- module( label = label, server = srv_g_bivariate, ui = ui_g_bivariate, - ui_args = args, - server_args = c( - data_extract_list, - list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) - ), + ui_args = args[names(args) %in% names(formals(ui_g_bivariate))], + server_args = args[names(args) %in% names(formals(srv_g_bivariate))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames( + list(x = x, y = y, row_facet = row_facet, col_facet = col_facet, color = color, fill = fill, size = size) + ) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the bivariate module -ui_g_bivariate <- function(id, ...) { - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset( - args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size - ) - +ui_g_bivariate <- function(id, + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + decorators = list()) { ns <- NS(id) - teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot"))) + teal::standard_layout2( + output = bslib::card( + teal.widgets::plot_with_settings_ui(id = ns("myplot")), + full_screen = TRUE ), - encoding = tags$div( - tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value + encoding = shiny::tagList( + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x) ), - teal.transform::data_extract_ui( - id = ns("y"), - label = "Y variable", - data_extract_spec = args$y, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Y variable"), + teal.transform::module_input_ui(id = ns("y"), spec = y) ), conditionalPanel( condition = "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || - $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", - shinyWidgets::radioGroupButtons( - inputId = ns("use_density"), + $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", + teal::teal_nav_item( label = NULL, - choices = c("frequency", "density"), - selected = ifelse(args$use_density, "density", "frequency"), - justified = TRUE + shinyWidgets::radioGroupButtons( + inputId = ns("use_density"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(use_density, "density", "frequency"), + justified = TRUE + ) ) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), - if (!is.null(args$row_facet) || !is.null(args$col_facet)) { - tags$div( - class = "data-extract-box", - tags$br(), - bslib::input_switch( - id = ns("facetting"), - label = "Facetting", - value = args$facet - ), - conditionalPanel( - condition = paste0("input['", ns("facetting"), "']"), - tags$div( - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting variable", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value - ) - }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting variable", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value - ) - }, - checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales), - checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales) - ) + if (!is.null(row_facet)) { + teal::teal_nav_item( + tags$div( + tags$strong("Row facetting variable"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet), + checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) ) ) }, - if (args$color_settings) { + if (!is.null(col_facet)) { + teal::teal_nav_item( + tags$div( + tags$strong("Column facetting variable"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet), + checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) + ) + ) + }, + if (color_settings) { # Put a grey border around the coloring settings - tags$div( - class = "data-extract-box", - tags$label("Color settings"), - bslib::input_switch( - id = ns("coloring"), - label = "Color settings", - value = TRUE - ), - conditionalPanel( - condition = paste0("input['", ns("coloring"), "']"), - tags$div( - teal.transform::data_extract_ui( - id = ns("color"), - label = "Outline color by variable", - data_extract_spec = args$color, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("fill"), - label = "Fill color by variable", - data_extract_spec = args$fill, - is_single_dataset = is_single_dataset_value - ), + teal::teal_nav_item( + label = tags$strong("Color settings"), + tags$div( + bslib::input_switch(id = ns("coloring"), label = "Color settings", value = TRUE), + conditionalPanel( + condition = paste0("input['", ns("coloring"), "']"), tags$div( - id = ns("size_settings"), - teal.transform::data_extract_ui( - id = ns("size"), - label = "Size of points by variable (only if x and y are numeric)", - data_extract_spec = args$size, - is_single_dataset = is_single_dataset_value + teal.transform::module_input_ui(id = ns("color"), spec = color), # label = "Outline color by variable" + teal.transform::module_input_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" + tags$div( + id = ns("size_settings"), + teal.transform::module_input_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" ) ) ) ) ) }, - bslib::accordion( - open = TRUE, - bslib::accordion_panel( - title = "Plot settings", - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), - checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes), - selectInput( - inputId = ns("ggtheme"), - label = "Theme (by ggplot):", - choices = ggplot_themes, - selected = args$ggtheme, - multiple = FALSE - ), - sliderInput( - ns("alpha"), "Opacity Scatterplot:", - min = 0, max = 1, - step = .05, value = .5, ticks = FALSE - ), - sliderInput( - ns("fixed_size"), "Scatterplot point size:", - min = 1, max = 8, - step = 1, value = 2, ticks = FALSE - ), - checkboxInput(ns("add_lines"), "Add lines"), + teal::teal_nav_item( + label = NULL, + teal:::.teal_navbar_menu( + id = ns("plot_settings"), + label = "Plot settings", + icon = "gear", + tags$div( + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + checkboxInput(ns("swap_axes"), "Swap axes", value = swap_axes), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ), + sliderInput( + ns("alpha"), "Opacity Scatterplot:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("fixed_size"), "Scatterplot point size:", + min = 1, max = 8, + step = 1, value = 2, ticks = FALSE + ), + checkboxInput(ns("add_lines"), "Add lines") + ) ) + ), + teal::teal_nav_item( + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) ) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } @@ -495,115 +479,101 @@ srv_g_bivariate <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - - data_extract <- list( - x = x, y = y, row_facet = row_facet, col_facet = col_facet, - color = color, fill = fill, size = size - ) - - rule_var <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()$select - if (length(value) == 0L && length(othervalue) == 0L) { - "Please select at least one of x-variable or y-variable" - } - } - } - rule_diff <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - x = rule_var("y"), - y = rule_var("x"), - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("row_facet") - ) - ) + selectors <- teal.transform::module_input_srv( + spec = list( + x = x, + y = y, + row_facet = row_facet, + col_facet = col_facet, + color = color, + fill = fill, + size = size + ), + data = data ) + iv <- shinyvalidate::InputValidator$new() iv_r <- reactive({ - iv_facet <- shinyvalidate::InputValidator$new() - iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, - validator_names = c("row_facet", "col_facet") - ) - iv_child$condition(~ isTRUE(input$facetting)) - - iv <- shinyvalidate::InputValidator$new() - iv$add_validator(iv_child) - teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y")) + # iv$add_rule( + # "x-variables-selected", + # shinyvalidate::compose_rules( + # ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { + # "Please select at least one of x-variable or y-variable" + # } + # ) + # ) + # iv$add_rule( + # "y-variables-selected", + # shinyvalidate::compose_rules( + # ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { + # "Please select at least one of x-variable or y-variable" + # } + # ) + # ) + # if (!is.null(col_facet)) { + # iv$add_rule( + # "row_facet-variables-selected", + # shinyvalidate::compose_rules( + # shinyvalidate::sv_optional(), + # ~ if ( + # !is.null(selectors$row_facet()$variables$selected) && + # identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) + # ) { + # "Row and column facetting variables must be different." + # } + # ) + # ) + # } + + # if (!is.null(row_facet)) { + # iv$add_rule( + # "col_facet-variables-selected", + # shinyvalidate::compose_rules( + # shinyvalidate::sv_optional(), + # ~ if ( + # !is.null(selectors$row_facet()$variables$selected) && + # identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) + # ) { + # "Row and column facetting variables must be different." + # } + # ) + # ) + # } + + iv$enable() }) - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data + qenv <- reactive( + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint: quotes. ) anl_merged_q <- reactive({ + isolate(teal::validate_inputs(iv_r())) + req(data()) obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Bivariate Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Bivariate Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) obj %>% - teal.code::eval_code( - c( - 'library("ggplot2");library("dplyr")', # nolint: quotes - as.expression(anl_merged_input()$expr) - ) - ) + teal.code::eval_code('library("ggplot2");library("dplyr")') %>% + teal.transform::qenv_merge_selectors(selectors = selectors) }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - output_q <- reactive({ - teal::validate_inputs(iv_r()) - - ANL <- merged$anl_q_r()[["ANL"]] - teal::validate_has_data(ANL, 3) + output_q <- reactive(label = "make bivariateplot", { + req(anl_merged_q()) + logger::log_debug("Plotting bivariate") + merged <- anl_merged_q()[["merged"]] + teal::validate_has_data(merged, 3) - x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) - x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) - y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) - y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) - - row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) - col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) - color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$color) - } else { - character(0) - } - fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$fill) - } else { - character(0) - } - size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$size) - } else { - character(0) - } + x_name <- map_merged(selectors)$x$variables + y_name <- map_merged(selectors)$y$variables + row_facet_name <- map_merged(selectors)$row_facet$variables + col_facet_name <- map_merged(selectors)$col_facet$variables + color_name <- map_merged(selectors)$color$variables + fill_name <- map_merged(selectors)$fill$variables + size_name <- map_merged(selectors)$size$variables use_density <- input$use_density == "density" free_x_scales <- input$free_x_scales @@ -612,7 +582,7 @@ srv_g_bivariate <- function(id, rotate_xaxis_labels <- input$rotate_xaxis_labels swap_axes <- input$swap_axes - is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && + is_scatterplot <- all(vapply(merged[c(x_name, y_name)], is.numeric, logical(1))) && length(x_name) > 0 && length(y_name) > 0 if (is_scatterplot) { @@ -638,16 +608,16 @@ srv_g_bivariate <- function(id, size <- NULL } - teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(merged[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) cl <- bivariate_plot_call( - data_name = "ANL", + data_name = "merged", x = x_name, y = y_name, - x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), - y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), - x_label = varname_w_label(x_name, ANL), - y_label = varname_w_label(y_name, ANL), + x_class = ifelse(length(x_name), class(merged[[x_name]]), "NULL"), + y_class = ifelse(length(y_name), class(merged[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, merged), + y_label = varname_w_label(y_name, merged), freq = !use_density, theme = ggtheme, rotate_xaxis_labels = rotate_xaxis_labels, @@ -694,7 +664,7 @@ srv_g_bivariate <- function(id, } } - obj <- merged$anl_q_r() + obj <- anl_merged_q() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) }) @@ -704,13 +674,13 @@ srv_g_bivariate <- function(id, data = output_q, decorators = select_decorators(decorators, "plot"), expr = reactive({ - ANL <- merged$anl_q_r()[["ANL"]] - row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) - col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) + merged <- anl_merged_q()[["merged"]] + row_facet_name <- map_merged(selectors)$row_facet$variables + col_facet_name <- map_merged(selectors)$col_facet$variables # Add labels to facets - nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) - nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) + nulled_row_facet_name <- varname_w_label(row_facet_name, merged) + nulled_col_facet_name <- varname_w_label(col_facet_name, merged) facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting @@ -758,8 +728,8 @@ srv_g_bivariate <- function(id, # Get Substituted ggplot call bivariate_plot_call <- function(data_name, - x = character(0), - y = character(0), + x = NULL, + y = NULL, x_class = "NULL", y_class = "NULL", x_label = NULL, @@ -776,12 +746,12 @@ bivariate_plot_call <- function(data_name, validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported."))) - if (identical(x, character(0))) { + if (is.null(x)) { x <- x_label <- "-" } else { x <- if (is.call(x)) x else as.name(x) } - if (identical(y, character(0))) { + if (is.null(y)) { y <- y_label <- "-" } else { y <- if (is.call(y)) y else as.name(y) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 17e31409d..a4cd3810b 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -108,6 +108,7 @@ tm_p_spiderplot <- function(label = "Spiderplot", checkmate::assert_class(subject_var, "picks") checkmate::assert_class(color_var, "picks") checkmate::assert_class(size_var, "picks", null.ok = TRUE) + checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) args <- as.list(environment()) module( @@ -129,7 +130,15 @@ tm_p_spiderplot <- function(label = "Spiderplot", ) } -ui_p_spiderplot <- function(id, time_var, value_var, subject_var, color_var, size_var, plot_height, decorators) { +ui_p_spiderplot <- function(id, + time_var, + value_var, + subject_var, + color_var, + size_var, + tooltip_vars, + plot_height, + decorators) { ns <- NS(id) bslib::page_sidebar( sidebar = div( @@ -148,10 +157,20 @@ ui_p_spiderplot <- function(id, time_var, value_var, subject_var, color_var, siz ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_var"), spec = color_var) + teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + colour_picker_ui(ns("colors")) ), + if (!is.null(tooltip_vars)) { # todo: don't show at all + teal::teal_nav_item( + label = tags$strong("Tooltip variables:"), + teal.transform::module_input_ui(id = ns("tooltip_vars"), spec = tooltip_vars) + ) + }, if (!is.null(size_var)) { - colour_picker_ui(ns("colors")) + teal::teal_nav_item( + label = tags$strong("Size by:"), + teal.transform::module_input_ui(id = ns("size_var"), spec = size_var) + ) }, ui_decorate_teal_data(ns("decorator"), decorators = decorators), sliderInput(ns("plot_height"), "Plot Height (px)", plot_height[2], plot_height[3], plot_height[1]) @@ -184,11 +203,12 @@ srv_p_spiderplot <- function(id, decorators = list(), filter_panel_api) { moduleServer(id, function(input, output, session) { + logger::log_trace("srv_p_spiderplot initializing") selectors <- teal.transform::module_input_srv( data = data, spec = list( time_var = time_var, value_var = value_var, subject_var = subject_var, - color_var = color_var, size_var = size_var + color_var = color_var, size_var = size_var, tooltip_vars = tooltip_vars ) ) @@ -224,6 +244,7 @@ srv_p_spiderplot <- function(id, output_q <- reactive({ obj <- req(plot_data_q()) + logger::log_debug("Plotting spiderplot") teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spiderplot Visualization") adjusted_symbols <- .shape_palette_discrete( levels = unique(obj$anl[[map_merged(selectors)$color_var$variables]]), @@ -244,9 +265,9 @@ srv_p_spiderplot <- function(id, colors = color_inputs(), symbols = adjusted_symbols, size_var = if (!is.null(size_var)) map_merged(selectors)$size_var$variables, + tooltip_vars = if (!is.null(tooltip_vars)) map_merged(selectors)$tooltip_vars$variables, height = input$plot_height, point_size = 10, - tooltip_vars = tooltip_vars, source = session$ns("spiderplot"), expr = { subject_var_label <- attr(anl[[subject_var]], "label") @@ -336,7 +357,7 @@ srv_p_spiderplot <- function(id, y = stats::as.formula(sprintf("~%s", value_var)), symbol = stats::as.formula(sprintf("~%s", color_var)), size = size, - text = ~tooltip, + # text = ~tooltip, hoverinfo = "text", customdata = ~customdata ) %>% @@ -358,14 +379,18 @@ srv_p_spiderplot <- function(id, expr = quote(plot) ) - output$plot <- plotly::renderPlotly(plotly::event_register( - { - rev(teal.code::get_outputs(decorated_output_plot_q()))[[1]] |> - set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) - }, - "plotly_selected" - )) + output$plot <- plotly::renderPlotly({ + req(decorated_output_plot_q()) + logger::log_debug("srv_p_spiderplot rendering plot") + plotly::event_register( + { + rev(teal.code::get_outputs(decorated_output_plot_q()))[[1]] |> + set_plot_data(session$ns("plot_data")) |> + setup_trigger_tooltips(session$ns) + }, + "plotly_selected" + ) + }) plotly_data <- reactive({ data.frame( diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index c82e8f8b2..f0f38e9e4 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -6,8 +6,11 @@ \usage{ tm_g_association( label = "Association", - ref, - vars, + ref = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1)), + vars = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = + TRUE)), show_association = TRUE, plot_height = c(600, 400, 5000), plot_width = NULL, diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index bd1f76af0..51dced013 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -6,8 +6,10 @@ \usage{ tm_g_bivariate( label = "Bivariate Plots", - x, - y, + x = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1)), + y = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2)), row_facet = NULL, col_facet = NULL, facet = !is.null(row_facet) || !is.null(col_facet), From d04c1165f5bad9089349ee59b469e01e9254f8e6 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 16 Sep 2025 15:17:30 +0530 Subject: [PATCH 131/158] feat: move the mdr modules outside tmg + split waterfall module --- NAMESPACE | 4 - R/tm_p_drilldown_bargraph.R | 137 ----------------------- R/tm_p_scatterlineplot.R | 125 --------------------- R/tm_p_spaghettiline.R | 129 ---------------------- R/tm_p_swimlane_table.R | 195 --------------------------------- R/tm_p_waterfall.R | 66 +++++------ man/tm_p_drilldown_bargraph.Rd | 89 --------------- man/tm_p_scatterlineplot.Rd | 78 ------------- man/tm_p_spaghettiline.Rd | 81 -------------- man/tm_p_swimlane_table.Rd | 114 ------------------- man/tm_p_waterfall.Rd | 9 +- 11 files changed, 31 insertions(+), 996 deletions(-) delete mode 100644 R/tm_p_drilldown_bargraph.R delete mode 100644 R/tm_p_scatterlineplot.R delete mode 100644 R/tm_p_spaghettiline.R delete mode 100644 R/tm_p_swimlane_table.R delete mode 100644 man/tm_p_drilldown_bargraph.Rd delete mode 100644 man/tm_p_scatterlineplot.Rd delete mode 100644 man/tm_p_spaghettiline.Rd delete mode 100644 man/tm_p_swimlane_table.Rd diff --git a/NAMESPACE b/NAMESPACE index 39506ce83..4b6975ef7 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,15 +24,11 @@ export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) export(tm_p_bargraph) -export(tm_p_drilldown_bargraph) export(tm_p_lineplot) -export(tm_p_scatterlineplot) export(tm_p_scatterplot) export(tm_p_spaghetti) -export(tm_p_spaghettiline) export(tm_p_spiderplot) export(tm_p_swimlane) -export(tm_p_swimlane_table) export(tm_p_waterfall) export(tm_rmarkdown) export(tm_t_crosstable) diff --git a/R/tm_p_drilldown_bargraph.R b/R/tm_p_drilldown_bargraph.R deleted file mode 100644 index be7d9e688..000000000 --- a/R/tm_p_drilldown_bargraph.R +++ /dev/null @@ -1,137 +0,0 @@ -#' Drilldown Bar Graph Module -#' -#' This module creates two synchronized interactive bar chart visualizations displayed -#' vertically. The top bar chart allows users to select segments by brushing, and the -#' bottom bar chart automatically updates to show a different categorical breakdown of -#' the selected data. Both charts use the same color coding and count variables but -#' display different categorical variables on their y-axes. This is particularly useful -#' for drill-down analysis and exploring relationships between different categorical dimensions. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param y_var (`character(1)`) Name of the categorical variable for the main (top) bar chart y-axis. -#' @param color_var (`character(1)`) Name of the categorical variable used for color coding in both charts. -#' @param count_var (`character(1)`) Name of the variable whose distinct values will be counted for bar heights in both charts. -#' @param secondary_y_var (`character(1)`) Name of the categorical variable for the secondary (bottom) bar chart y-axis. -#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness"), -#' 150, -#' replace = TRUE, prob = c(0.4, 0.3, 0.2, 0.1) -#' ), -#' severity = sample(c("Mild", "Moderate", "Severe"), 150, -#' replace = TRUE, -#' prob = c(0.6, 0.3, 0.1) -#' ), -#' system_organ_class = sample(c("Nervous System", "Gastrointestinal", "General"), -#' 150, -#' replace = TRUE, prob = c(0.5, 0.3, 0.2) -#' ), -#' subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), -#' treatment = sample(c("Active", "Placebo"), 150, replace = TRUE) -#' ) -#' -#' # Add labels -#' attr(df$adverse_event, "label") <- "Adverse Event Term" -#' attr(df$severity, "label") <- "Severity Grade" -#' attr(df$system_organ_class, "label") <- "System Organ Class" -#' attr(df$subject_id, "label") <- "Subject ID" -#' attr(df$treatment, "label") <- "Treatment Group" -#' }) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_drilldown_bargraph( -#' label = "SOC to Term Breakdown", -#' plot_dataname = "df", -#' y_var = "system_organ_class", -#' color_var = "treatment", -#' count_var = "subject_id", -#' secondary_y_var = "adverse_event", -#' tooltip_vars = c("system_organ_class", "adverse_event", "treatment"), -#' bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_drilldown_bargraph <- function(label = "Bar Plot", - plot_dataname, - y_var, - color_var, - count_var, - secondary_y_var, - tooltip_vars = NULL, - bar_colors = NULL) { - module( - label = label, - ui = ui_p_drilldown_bargraph, - server = srv_p_drilldown_bargraph, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - y_var = y_var, - color_var = color_var, - count_var = count_var, - secondary_y_var = secondary_y_var, - tooltip_vars = tooltip_vars, - bar_colors = bar_colors - ) - ) -} - -ui_p_drilldown_bargraph <- function(id) { - ns <- NS(id) - bslib::page_fluid( - ui_p_bargraph(ns("main_bargraph")), - ui_p_bargraph(ns("secondary_bargraph")) - ) -} - -srv_p_drilldown_bargraph <- function(id, - data, - plot_dataname, - y_var, - color_var, - count_var, - secondary_y_var, - tooltip_vars, - bar_colors) { - moduleServer(id, function(input, output, session) { - plot_q <- srv_p_bargraph( - "main_bargraph", - data = data, - plot_dataname = plot_dataname, - y_var = y_var, - color_var = color_var, - count_var = count_var, - tooltip_vars = tooltip_vars, - bar_colors = bar_colors - ) - - brushed_q <- reactive({ - req(attr(plot_q(), "has_brushing")) - plot_q() - }) - - srv_p_bargraph( - "secondary_bargraph", - data = brushed_q, - plot_dataname = plot_dataname, - y_var = secondary_y_var, - color_var = color_var, - count_var = count_var, - tooltip_vars = tooltip_vars, - bar_colors = bar_colors - ) - }) -} diff --git a/R/tm_p_scatterlineplot.R b/R/tm_p_scatterlineplot.R deleted file mode 100644 index 5339e8dd4..000000000 --- a/R/tm_p_scatterlineplot.R +++ /dev/null @@ -1,125 +0,0 @@ -#' Scatter + Line Plot Module -#' -#' This module creates a combined visualization with both scatter plot and line plot views. -#' It displays a scatter plot where users can select points, and the selection is reflected -#' in a corresponding line plot below. -#' -#' The line plot uses `subject_var` as the grouping variable to connect points with lines. -#' When no selection is made in the scatter plot, the line plot shows all data. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param subject_var (`character(1)`) Name of the subject variable used for grouping in the line plot. -#' @param x_var (`character(1)`) Name of the variable to be used for x-axis in both plots. -#' @param y_var (`character(1)`) Name of the variable to be used for y-axis in both plots. -#' @param color_var (`character(1)`) Name of the variable to be used for coloring points in both plots. -#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. -#' @param transformators (`list`) Named list of transformator functions. -#' @param reference_lines (`list` or `NULL`) Reference lines specification for the line plot. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' subject_id = rep(c("S1", "S2", "S3"), each = 4), -#' time_point = rep(c(0, 30, 60, 90), 3), -#' response = rnorm(12, 15, 3), -#' treatment = rep(c("A", "B", "A"), each = 4) -#' ) -#' }) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_scatterlineplot( -#' label = "Scatter + Line Plot", -#' plot_dataname = "df", -#' subject_var = "subject_id", -#' x_var = "time_point", -#' y_var = "response", -#' color_var = "treatment", -#' tooltip_vars = c("subject_id", "treatment") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_scatterlineplot <- function(label = "Scatter + Line Plot", - plot_dataname, - subject_var, - x_var, - y_var, - color_var, - tooltip_vars = NULL, - point_colors = character(0), - transformators = list(), - reference_lines = NULL) { - module( - label = label, - ui = ui_p_scatterlineplot, - server = srv_p_scatterlineplot, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - subject_var = subject_var, - x_var = x_var, - y_var = y_var, - tooltip_vars = tooltip_vars, - color_var = color_var, - point_colors = point_colors, - reference_lines = reference_lines - ), - transformators = transformators - ) -} - -ui_p_scatterlineplot <- function(id) { - ns <- NS(id) - bslib::page_fluid( - ui_p_scatterplot(ns("scatter")), - ui_p_lineplot(ns("line")) - ) -} - -srv_p_scatterlineplot <- function(id, - data, - plot_dataname, - subject_var, - x_var, - y_var, - tooltip_vars, - color_var, - point_colors, - reference_lines) { - moduleServer(id, function(input, output, session) { - plot_q <- srv_p_scatterplot( - "scatter", - data = data, - plot_dataname = plot_dataname, - subject_var = subject_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, - tooltip_vars = tooltip_vars, - point_colors = point_colors, - show_widgets = FALSE - ) - srv_p_lineplot( - "line", - data = plot_q, - plot_dataname = plot_dataname, - x_var = x_var, - y_var = y_var, - color_var = color_var, - group_var = subject_var, - colors = point_colors, - tooltip_vars = tooltip_vars, - reference_lines = reference_lines, - activate_on_brushing = TRUE - ) - }) -} diff --git a/R/tm_p_spaghettiline.R b/R/tm_p_spaghettiline.R deleted file mode 100644 index e9af79788..000000000 --- a/R/tm_p_spaghettiline.R +++ /dev/null @@ -1,129 +0,0 @@ -#' Spaghetti + Line Plot Module -#' -#' This module creates a combined visualization with both spaghetti plot and line plot views. -#' It displays a spaghetti plot where users can select points, and the selection is reflected -#' in a corresponding line plot below. The spaghetti plot shows individual trajectories for -#' each group over time. -#' -#' The spaghetti plot connects points within each `group_var` level to show individual trajectories. -#' The line plot uses the same `group_var` for grouping and updates to show only the selected data -#' when brushing occurs in the spaghetti plot. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param group_var (`character(1)`) Name of the grouping variable used for creating individual -#' trajectories in the spaghetti plot and grouping in the line plot. -#' @param x_var (`character(1)`) Name of the variable to be used for x-axis in both plots. -#' @param y_var (`character(1)`) Name of the variable to be used for y-axis in both plots. -#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines in both plots. -#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. -#' @param transformators (`list`) Named list of transformator functions. -#' @param reference_lines (`list` or `NULL`) Reference lines specification for the line plot. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' subject_id = rep(c("S1", "S2", "S3", "S4"), each = 4), -#' time_point = rep(c(0, 30, 60, 90), 4), -#' response = rnorm(16, 15, 3), -#' treatment = rep(c("A", "B", "A", "B"), each = 4) -#' ) -#' }) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_spaghettiline( -#' label = "Spaghetti + Line Plot", -#' plot_dataname = "df", -#' group_var = "subject_id", -#' x_var = "time_point", -#' y_var = "response", -#' color_var = "treatment", -#' tooltip_vars = c("subject_id", "treatment") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_spaghettiline <- function(label = "Scatter + Line Plot", - plot_dataname, - group_var, - x_var, - y_var, - color_var, - tooltip_vars = NULL, - point_colors = character(0), - transformators = list(), - reference_lines = NULL) { - module( - label = label, - ui = ui_p_spaghettiline, - server = srv_p_spaghettiline, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - group_var = group_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, - point_colors = point_colors, - reference_lines = reference_lines, - tooltip_vars = tooltip_vars - ), - transformators = transformators - ) -} - -ui_p_spaghettiline <- function(id) { - ns <- NS(id) - bslib::page_fluid( - ui_p_spaghetti(ns("scatter")), - ui_p_lineplot(ns("line")) - ) -} - -srv_p_spaghettiline <- function(id, - data, - plot_dataname, - group_var, - x_var, - y_var, - color_var, - tooltip_vars, - point_colors, - reference_lines) { - moduleServer(id, function(input, output, session) { - plot_q <- srv_p_spaghetti( - "scatter", - data = data, - plot_dataname = plot_dataname, - group_var = group_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, - tooltip_vars = tooltip_vars, - point_colors = point_colors, - show_widgets = FALSE - ) - - srv_p_lineplot( - "line", - data = plot_q, - plot_dataname = plot_dataname, - x_var = x_var, - y_var = y_var, - color_var = color_var, - group_var = group_var, - colors = point_colors, - tooltip_vars = tooltip_vars, - reference_lines = reference_lines, - activate_on_brushing = TRUE - ) - }) -} diff --git a/R/tm_p_swimlane_table.R b/R/tm_p_swimlane_table.R deleted file mode 100644 index 5df82b429..000000000 --- a/R/tm_p_swimlane_table.R +++ /dev/null @@ -1,195 +0,0 @@ -#' `teal` module: Swimlane plot -#' -#' Module visualizes subjects' events in time. -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column -#' in `plot_dataname` to be used as x-axis. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to be used as y-axis. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to name and color subject events in time. -#' @param group_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to categorize type of event. -#' (legend is sorted according to this variable, and used in toolip to display type of the event) -#' todo: this can be fixed by ordering factor levels -#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which -#' value determines order of the subjects displayed on the y-axis. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created. -#' @param point_size (`numeric(1)` or `named numeric`) Default point size of the points in the plot. -#' If `point_size` is a named numeric vector, it should be named by levels of `color_var` column. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named -#' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. -#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. -#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") -#' ) -#' -#' swimlane_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' time_var = sample(1:100, 10, replace = TRUE), -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) -#' ) -#' }) -#' join_keys(data) <- join_keys( -#' join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) -#' ) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_swimlane_table( -#' plot_dataname = "swimlane_ds", -#' table_datanames = "subjects", -#' time_var = "time_var", -#' subject_var = "subject_var", -#' color_var = "color_var", -#' group_var = "color_var", -#' sort_var = "time_var", -#' plot_height = c(700, 400, 1200), -#' tooltip_vars = c("subject_var", "color_var"), -#' point_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" -#' ), -#' point_symbols = c( -#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" -#' ) -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_swimlane_table <- function(label = "Swimlane", - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var = time_var, - tooltip_vars = NULL, - point_size = 10, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(700, 400, 1200), - table_datanames = character(0), - reactable_args = list()) { - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - if (is.character(time_var)) { - time_var <- choices_selected(choices = time_var, selected = time_var) - } - if (is.character(subject_var)) { - subject_var <- choices_selected(choices = subject_var, selected = subject_var) - } - if (is.character(color_var)) { - color_var <- choices_selected(choices = color_var, selected = color_var) - } - if (is.character(group_var)) { - group_var <- choices_selected(choices = group_var, selected = group_var) - } - if (is.character(sort_var)) { - sort_var <- choices_selected(choices = sort_var, selected = sort_var) - } - module( - label = label, - ui = ui_p_swimlane_table, - server = srv_p_swimlane_table, - datanames = c(plot_dataname, table_datanames), - ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_var, - point_size = point_size, - point_colors = point_colors, - point_symbols = point_symbols, - table_datanames = table_datanames, - reactable_args = reactable_args, - tooltip_vars = tooltip_vars - ) - ) -} - -ui_p_swimlane_table <- function(id, height) { - ns <- NS(id) - bslib::page_fluid( - ui_p_swimlane(ns("swimlane"), height = height), - ui_t_reactables(ns("subtables")) - ) -} -srv_p_swimlane_table <- function(id, - data, - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var, - point_size = 10, - point_colors, - point_symbols, - table_datanames, - reactable_args = list(), - tooltip_vars = NULL, - filter_panel_api) { - moduleServer(id, function(input, output, session) { - plot_q <- srv_p_swimlane( - "swimlane", - data = data, - plot_dataname = plot_dataname, - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_var, - point_size = point_size, - point_colors = point_colors, - point_symbols = point_symbols, - tooltip_vars = tooltip_vars, - show_widgets = FALSE - ) - - filtered_data_q <- reactive({ - req(plot_q()) - plot_q() |> - within( - { - table_names <- c("recist_listing") - for (table_name in table_names) { - current_table <- get(table_name) - filtered_table <- current_table |> - dplyr::filter(!!sym(subject_var) %in% plot_dataname[[subject_var]]) - assign(table_name, filtered_table) - } - }, - plot_dataname = str2lang(plot_dataname), - subject_var = subject_var$selected - ) - }) - srv_t_reactables( - "subtables", - data = filtered_data_q, - filter_panel_api = filter_panel_api, - datanames = table_datanames, - reactable_args = reactable_args - ) - }) -} diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index f9b36c486..b5a37bf7e 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -18,8 +18,6 @@ #' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal #' lines on the plot. #' @param plot_title (`character`) Title of the plot. -#' @param table_datanames (`character`) Names of the datasets to be displayed in the tables below the plot. -#' @param reactable_args (`list`) Additional arguments passed to the `reactable` function for table customization. #' #' @examples #' data <- teal_data() |> @@ -45,7 +43,6 @@ #' modules = modules( #' tm_p_waterfall( #' plot_dataname = "waterfall_ds", -#' table_datanames = "subjects", #' subject_var = "subject_var", #' value_var = "value_var", #' sort_var = "value_var", @@ -74,9 +71,7 @@ tm_p_waterfall <- function(label = "Waterfall", bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list()) { + plot_height = c(600, 400, 1200)) { if (is.character(subject_var)) { subject_var <- choices_selected(choices = subject_var, selected = subject_var) } @@ -94,11 +89,10 @@ tm_p_waterfall <- function(label = "Waterfall", label = label, ui = ui_p_waterfall, server = srv_p_waterfall, - datanames = union(plot_dataname, table_datanames), + datanames = plot_dataname, ui_args = list(height = plot_height), server_args = list( plot_dataname = plot_dataname, - table_datanames = table_datanames, subject_var = subject_var, value_var = value_var, sort_var = sort_var, @@ -106,7 +100,6 @@ tm_p_waterfall <- function(label = "Waterfall", bar_colors = bar_colors, value_arbitrary_hlines = value_arbitrary_hlines, plot_title = plot_title, - reactable_args = reactable_args, tooltip_vars = tooltip_vars ) ) @@ -115,8 +108,9 @@ tm_p_waterfall <- function(label = "Waterfall", ui_p_waterfall <- function(id, height) { ns <- NS(id) - bslib::page_sidebar( - sidebar = div( + bslib::page_fluid( + div( + style = "display: flex;", selectInput( ns("subject_var"), label = "Subject variable (x-axis):", @@ -138,8 +132,7 @@ ui_p_waterfall <- function(id, height) { tags$div( plotly::plotlyOutput(ns("plot"), height = "100%") ) - ), - ui_t_reactables(ns("subtables")) + ) ) ) } @@ -154,9 +147,7 @@ srv_p_waterfall <- function(id, value_arbitrary_hlines, plot_title, plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list(), - tooltip_vars = NULL, + tooltip_vars, filter_panel_api) { moduleServer(id, function(input, output, session) { .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) @@ -198,7 +189,7 @@ srv_p_waterfall <- function(id, if (!length(color_var_label)) color_var_label <- color_var - p <- dplyr::mutate( + plot_data <- dplyr::mutate( if (identical(sort_var, value_var) || is.null(sort_var)) { dplyr::arrange(dataname, desc(!!as.name(value_var))) } else { @@ -233,10 +224,13 @@ srv_p_waterfall <- function(id, } ) %>% dplyr::filter(!duplicated(!!as.name(subject_var))) %>% - plotly::plot_ly( - source = source, - height = height - ) %>% + dplyr::mutate(customdata = dplyr::row_number()) + p <- plotly::plot_ly( + data = plot_data, + source = source, + customdata = ~customdata, + height = height + ) %>% plotly::add_bars( x = stats::as.formula(sprintf("~%s", subject_var)), y = stats::as.formula(sprintf("~%s", value_var)), @@ -274,20 +268,20 @@ srv_p_waterfall <- function(id, plotly_selected <- reactive(plotly::event_data("plotly_selected", source = session$ns("waterfall"))) - tables_selected_q <- .plotly_selected_filter_children( - data = plotly_q, - plot_dataname = plot_dataname, - xvar = reactive(input$subject_var), - yvar = reactive(input$value_var), - plotly_selected = plotly_selected, - children_datanames = table_datanames - ) - - srv_t_reactables( - "subtables", - data = tables_selected_q, - datanames = table_datanames, - reactable_args = reactable_args - ) + reactive({ + req(plotly_selected()) + plotly_q() |> + within( + { + selected_plot_data <- plot_data |> + dplyr::filter(customdata %in% plotly_selected_customdata) + dataname <- dataname |> + dplyr::filter(!!sym(subject_var) %in% selected_plot_data[[subject_var]]) + }, + dataname = str2lang(plot_dataname), + subject_var = input$subject_var, + plotly_selected_customdata = plotly_selected()$customdata + ) + }) }) } diff --git a/man/tm_p_drilldown_bargraph.Rd b/man/tm_p_drilldown_bargraph.Rd deleted file mode 100644 index a31af7fe3..000000000 --- a/man/tm_p_drilldown_bargraph.Rd +++ /dev/null @@ -1,89 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_drilldown_bargraph.R -\name{tm_p_drilldown_bargraph} -\alias{tm_p_drilldown_bargraph} -\title{Drilldown Bar Graph Module} -\usage{ -tm_p_drilldown_bargraph( - label = "Bar Plot", - plot_dataname, - y_var, - color_var, - count_var, - secondary_y_var, - tooltip_vars = NULL, - bar_colors = NULL -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{y_var}{(\code{character(1)}) Name of the categorical variable for the main (top) bar chart y-axis.} - -\item{color_var}{(\code{character(1)}) Name of the categorical variable used for color coding in both charts.} - -\item{count_var}{(\code{character(1)}) Name of the variable whose distinct values will be counted for bar heights in both charts.} - -\item{secondary_y_var}{(\code{character(1)}) Name of the categorical variable for the secondary (bottom) bar chart y-axis.} - -\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} -} -\description{ -This module creates two synchronized interactive bar chart visualizations displayed -vertically. The top bar chart allows users to select segments by brushing, and the -bottom bar chart automatically updates to show a different categorical breakdown of -the selected data. Both charts use the same color coding and count variables but -display different categorical variables on their y-axes. This is particularly useful -for drill-down analysis and exploring relationships between different categorical dimensions. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness"), - 150, - replace = TRUE, prob = c(0.4, 0.3, 0.2, 0.1) - ), - severity = sample(c("Mild", "Moderate", "Severe"), 150, - replace = TRUE, - prob = c(0.6, 0.3, 0.1) - ), - system_organ_class = sample(c("Nervous System", "Gastrointestinal", "General"), - 150, - replace = TRUE, prob = c(0.5, 0.3, 0.2) - ), - subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), - treatment = sample(c("Active", "Placebo"), 150, replace = TRUE) - ) - - # Add labels - attr(df$adverse_event, "label") <- "Adverse Event Term" - attr(df$severity, "label") <- "Severity Grade" - attr(df$system_organ_class, "label") <- "System Organ Class" - attr(df$subject_id, "label") <- "Subject ID" - attr(df$treatment, "label") <- "Treatment Group" - }) - -app <- init( - data = data, - modules = modules( - tm_p_drilldown_bargraph( - label = "SOC to Term Breakdown", - plot_dataname = "df", - y_var = "system_organ_class", - color_var = "treatment", - count_var = "subject_id", - secondary_y_var = "adverse_event", - tooltip_vars = c("system_organ_class", "adverse_event", "treatment"), - bar_colors = c("Active" = "#E74C3C", "Placebo" = "#3498DB") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_scatterlineplot.Rd b/man/tm_p_scatterlineplot.Rd deleted file mode 100644 index 2a0c4f264..000000000 --- a/man/tm_p_scatterlineplot.Rd +++ /dev/null @@ -1,78 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_scatterlineplot.R -\name{tm_p_scatterlineplot} -\alias{tm_p_scatterlineplot} -\title{Scatter + Line Plot Module} -\usage{ -tm_p_scatterlineplot( - label = "Scatter + Line Plot", - plot_dataname, - subject_var, - x_var, - y_var, - color_var, - tooltip_vars = NULL, - point_colors = character(0), - transformators = list(), - reference_lines = NULL -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{subject_var}{(\code{character(1)}) Name of the subject variable used for grouping in the line plot.} - -\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis in both plots.} - -\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis in both plots.} - -\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points in both plots.} - -\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} - -\item{transformators}{(\code{list}) Named list of transformator functions.} - -\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for the line plot.} -} -\description{ -This module creates a combined visualization with both scatter plot and line plot views. -It displays a scatter plot where users can select points, and the selection is reflected -in a corresponding line plot below. -} -\details{ -The line plot uses \code{subject_var} as the grouping variable to connect points with lines. -When no selection is made in the scatter plot, the line plot shows all data. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - subject_id = rep(c("S1", "S2", "S3"), each = 4), - time_point = rep(c(0, 30, 60, 90), 3), - response = rnorm(12, 15, 3), - treatment = rep(c("A", "B", "A"), each = 4) - ) - }) - -app <- init( - data = data, - modules = modules( - tm_p_scatterlineplot( - label = "Scatter + Line Plot", - plot_dataname = "df", - subject_var = "subject_id", - x_var = "time_point", - y_var = "response", - color_var = "treatment", - tooltip_vars = c("subject_id", "treatment") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_spaghettiline.Rd b/man/tm_p_spaghettiline.Rd deleted file mode 100644 index 5bb4d2ced..000000000 --- a/man/tm_p_spaghettiline.Rd +++ /dev/null @@ -1,81 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_spaghettiline.R -\name{tm_p_spaghettiline} -\alias{tm_p_spaghettiline} -\title{Spaghetti + Line Plot Module} -\usage{ -tm_p_spaghettiline( - label = "Scatter + Line Plot", - plot_dataname, - group_var, - x_var, - y_var, - color_var, - tooltip_vars = NULL, - point_colors = character(0), - transformators = list(), - reference_lines = NULL -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{group_var}{(\code{character(1)}) Name of the grouping variable used for creating individual -trajectories in the spaghetti plot and grouping in the line plot.} - -\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis in both plots.} - -\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis in both plots.} - -\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines in both plots.} - -\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} - -\item{transformators}{(\code{list}) Named list of transformator functions.} - -\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for the line plot.} -} -\description{ -This module creates a combined visualization with both spaghetti plot and line plot views. -It displays a spaghetti plot where users can select points, and the selection is reflected -in a corresponding line plot below. The spaghetti plot shows individual trajectories for -each group over time. -} -\details{ -The spaghetti plot connects points within each \code{group_var} level to show individual trajectories. -The line plot uses the same \code{group_var} for grouping and updates to show only the selected data -when brushing occurs in the spaghetti plot. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - subject_id = rep(c("S1", "S2", "S3", "S4"), each = 4), - time_point = rep(c(0, 30, 60, 90), 4), - response = rnorm(16, 15, 3), - treatment = rep(c("A", "B", "A", "B"), each = 4) - ) - }) - -app <- init( - data = data, - modules = modules( - tm_p_spaghettiline( - label = "Spaghetti + Line Plot", - plot_dataname = "df", - group_var = "subject_id", - x_var = "time_point", - y_var = "response", - color_var = "treatment", - tooltip_vars = c("subject_id", "treatment") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_swimlane_table.Rd b/man/tm_p_swimlane_table.Rd deleted file mode 100644 index c8177cbee..000000000 --- a/man/tm_p_swimlane_table.Rd +++ /dev/null @@ -1,114 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_swimlane_table.R -\name{tm_p_swimlane_table} -\alias{tm_p_swimlane_table} -\title{\code{teal} module: Swimlane plot} -\usage{ -tm_p_swimlane_table( - label = "Swimlane", - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var = time_var, - tooltip_vars = NULL, - point_size = 10, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(700, 400, 1200), - table_datanames = character(0), - reactable_args = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} - -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as x-axis.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as y-axis.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to name and color subject events in time.} - -\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to categorize type of event. -(legend is sorted according to this variable, and used in toolip to display type of the event) -todo: this can be fixed by ordering factor levels} - -\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which -value determines order of the subjects displayed on the y-axis.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. -If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} - -\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} -} -\description{ -Module visualizes subjects' events in time. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - swimlane_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = sample(1:100, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_p_swimlane_table( - plot_dataname = "swimlane_ds", - table_datanames = "subjects", - time_var = "time_var", - subject_var = "subject_var", - color_var = "color_var", - group_var = "color_var", - sort_var = "time_var", - plot_height = c(700, 400, 1200), - tooltip_vars = c("subject_var", "color_var"), - point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ), - point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index efb868a95..eabdeea88 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -15,9 +15,7 @@ tm_p_waterfall( bar_colors = character(0), value_arbitrary_hlines = c(0.2, -0.3), plot_title = "Waterfall plot", - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list() + plot_height = c(600, 400, 1200) ) } \arguments{ @@ -48,10 +46,6 @@ lines on the plot.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{table_datanames}{(\code{character}) Names of the datasets to be displayed in the tables below the plot.} - -\item{reactable_args}{(\code{list}) Additional arguments passed to the \code{reactable} function for table customization.} } \description{ Module visualizes subjects sorted decreasingly by y-values. @@ -80,7 +74,6 @@ app <- init( modules = modules( tm_p_waterfall( plot_dataname = "waterfall_ds", - table_datanames = "subjects", subject_var = "subject_var", value_var = "value_var", sort_var = "value_var", From 0edbeb62fb3107a3940bd2699e55b2cd9b0b9ed7 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 16 Sep 2025 11:45:31 +0000 Subject: [PATCH 132/158] fix scatter and lineplot --- R/tm_p_lineplot.R | 50 +++++-------- R/tm_p_scatterplot.R | 174 ++++++++++++++++++++++++++++--------------- 2 files changed, 133 insertions(+), 91 deletions(-) diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index f6fcb8c68..13728df77 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -17,7 +17,6 @@ #' If `NULL`, default tooltip is created showing group, x, y, and color variables. #' @param transformators (`list`) Named list of transformator functions. #' @param reference_lines (`list` or `NULL`) Reference lines specification for adding horizontal reference lines. -#' @param activate_on_brushing (`logical(1)`) Whether to activate the plot only when brushing occurs in another plot. #' #' @examples #' data <- teal_data() |> @@ -68,25 +67,19 @@ tm_p_lineplot <- function(label = "Line Plot", colors = NULL, tooltip_vars = NULL, transformators = list(), - reference_lines = NULL, - activate_on_brushing = FALSE) { + reference_lines = NULL) { + args <- as.list(environment()) module( label = label, ui = ui_p_lineplot, server = srv_p_lineplot, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - x_var = x_var, - y_var = y_var, - color_var = color_var, - colors = colors, - group_var = group_var, - tooltip_vars = tooltip_vars, - reference_lines = reference_lines, - activate_on_brushing = activate_on_brushing - ), - transformators = transformators + ui_args = args[names(args) %in% names(formals(ui_p_lineplot))], + server_args = args[names(args) %in% names(formals(srv_p_lineplot))], + transformators = transformators, + datanames = { + datanames <- datanames(list(x_var = x_var, y_var = y_var, color_var = color_var, group_var)) + if (length(datanames)) datanames else "all" + } ) } @@ -109,15 +102,20 @@ srv_p_lineplot <- function(id, group_var, colors, tooltip_vars = NULL, - reference_lines, - activate_on_brushing) { + reference_lines) { moduleServer(id, function(input, output, session) { plotly_q <- reactive({ - if (activate_on_brushing) { - req(attr(data(), "has_brushing")) - } + req(data()) data() %>% within( + df = str2lang(plot_dataname), + x_var = x_var(), + y_var = y_var(), + color_var = color_var(), + group_var = group_var(), + colors = colors(), + tooltip_vars = tooltip_vars(), + reference_lines = reference_lines, { validate(need(nrow(df) > 0, "No data after applying filters.")) @@ -271,15 +269,7 @@ srv_p_lineplot <- function(id, annotations = ref_lines$annotations ) } - }, - df = str2lang(plot_dataname), - x_var = x_var, - y_var = y_var, - color_var = color_var, - group_var = group_var, - colors = colors, - tooltip_vars = tooltip_vars, - reference_lines = reference_lines + } ) }) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 3fa69b52b..1cd469125 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -55,46 +55,113 @@ #' #' @export tm_p_scatterplot <- function(label = "Scatter Plot", - plot_dataname, subject_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE) { + transformators = list()) { + checkmate::assert_string(label) + checkmate::assert_class(subject_var, "picks") + checkmate::assert_class(x_var, "picks") + checkmate::assert_class(y_var, "picks") + checkmate::assert_class(color_var, "picks") + args <- as.list(environment()) module( label = label, - ui = ui_p_scatterplot, - server = srv_p_scatterplot, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - subject_var = subject_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, - point_colors = point_colors, - tooltip_vars = tooltip_vars, - show_widgets = show_widgets + ui = ui_p_scatterplot_module, + server = srv_p_scatterplot_module, + ui_args = args[names(args) %in% names(formals(ui_p_scatterplot_module))], + server_args = args[names(args) %in% names(formals(srv_p_scatterplot_module))], + transformators = transformators, + datanames = { + datanames <- datanames(list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var)) + if (length(datanames)) datanames else "all" + } + ) +} + +ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { + ns <- NS(id) + bslib::page_sidebar( + sidebar = div( + class = "standard-layout encoding-panel", + teal::teal_nav_item( + label = tags$strong("Subject Variable:"), + teal.transform::module_input_ui(id = ns("subject_var"), spec = subject_var) + ), + teal::teal_nav_item( + label = tags$strong("X-axis Variable:"), + teal.transform::module_input_ui(id = ns("x_var"), spec = x_var) + ), + teal::teal_nav_item( + label = tags$strong("Y-axis Variable:"), + teal.transform::module_input_ui(id = ns("y_var"), spec = y_var) + ), + teal::teal_nav_item( + label = tags$strong("Color by:"), + teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + colour_picker_ui(ns("colors")) + ) ), - transformators = transformators + ui_p_scatterplot(ns("output")) ) } +srv_p_scatterplot_module <- function(id, + data, + subject_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL) { + moduleServer(id, function(input, output, session) { + selectors <- teal.transform::module_input_srv( + data = data, + spec = list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) + ) + merged_dataname <- "anl" + merged_q <- reactive({ + req(data(), map_merged(selectors)) + obj <- data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Scatterplot data preparation") + qenv_merge_selectors(x = obj, selectors = selectors, output_name = merged_dataname) + }) + + color_inputs <- colour_picker_srv( + "colors", + x = reactive({ + selected_color <- req(map_merged(selectors)$color_var) + merged_q()[[merged_dataname]][[selected_color$variables]] + }), + default_colors = point_colors + ) + + srv_p_scatterplot( + "output", + data = merged_q, + dataname = merged_dataname, + x_var = reactive(map_merged(selectors)$x_var$variables), + y_var = reactive(map_merged(selectors)$y_var$variables), + color_var = reactive(map_merged(selectors)$color_var$variables), + color_inputs = color_inputs, + subject_var = reactive(map_merged(selectors)$subject_var$variables), + tooltip_vars = reactive(map_merged(selectors)$tooltip_vars$variables) + ) + }) +} + ui_p_scatterplot <- function(id) { ns <- NS(id) - bslib::page_fluid( - shinyjs::useShinyjs(), - tags$div( - tags$span(id = ns("colors_span"), colour_picker_ui(ns("colors"))), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) + tags$div( + class = "standard-layout output-panel", + bslib::card( + full_screen = TRUE, + tags$div( + trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") ) ) ) @@ -102,38 +169,26 @@ ui_p_scatterplot <- function(id) { srv_p_scatterplot <- function(id, data, - plot_dataname, + dataname, subject_var, x_var, y_var, color_var, - point_colors, - tooltip_vars = NULL, - show_widgets) { + color_inputs, + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - data()[[plot_dataname]][[color_var]] - }), - default_colors = point_colors - ) - - if (!show_widgets) { - shinyjs::hide("colors_span") - } - plotly_q <- reactive({ - req(color_inputs()) + obj <- req(data(), x_var(), y_var(), subject_var(), color_var()) within( data(), - x_var = x_var, - y_var = y_var, - color_var = color_var, - subject_var = subject_var, + df = str2lang(dataname), + x_var = x_var(), + y_var = y_var(), + color_var = color_var(), + subject_var = subject_var(), colors = color_inputs(), source = session$ns("scatterplot"), - tooltip_vars = tooltip_vars, + tooltip_vars = tooltip_vars(), expr = { # Get label attributes for variables, fallback to column names subject_var_label <- attr(df[[subject_var]], "label") @@ -200,7 +255,7 @@ srv_p_scatterplot <- function(id, } ) - p <- plotly::plot_ly( + plotly::plot_ly( data = plot_data, source = source, colors = colors, @@ -215,27 +270,24 @@ srv_p_scatterplot <- function(id, ) |> plotly::layout(dragmode = "select") |> plotly::event_register("plotly_selected") - - p - }, - df = str2lang(plot_dataname) + } ) }) - - output$plot <- plotly::renderPlotly( - plotly_q()$p |> + output$plot <- plotly::renderPlotly({ + req(plotly_q()) + tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> setup_trigger_tooltips(session$ns) |> set_plot_data(session$ns("plot_data")) |> plotly::event_register("plotly_selected") - ) + }) plotly_selected <- reactive( plotly::event_data("plotly_selected", source = session$ns("scatterplot")) ) reactive({ - if (is.null(plotly_selected()) || is.null(subject_var)) { + if (is.null(plotly_selected()) || is.null(subject_var())) { plotly_q() } else { q <- plotly_q() |> @@ -246,8 +298,8 @@ srv_p_scatterplot <- function(id, df <- df |> dplyr::filter(!!as.name(subject_var_string) %in% selected_plot_data[[subject_var_string]]) }, - df = str2lang(plot_dataname), - subject_var_string = subject_var, + df = str2lang(dataname), + subject_var_string = subject_var(), plotly_selected_customdata = plotly_selected()$customdata ) attr(q, "has_brushing") <- TRUE @@ -255,4 +307,4 @@ srv_p_scatterplot <- function(id, } }) }) -} +} \ No newline at end of file From 0a88128a706894ed150ccd3331f6b7b21f4717b5 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 16 Sep 2025 13:51:28 +0000 Subject: [PATCH 133/158] picks to spaghetti --- R/tm_p_scatterplot.R | 3 + R/tm_p_spaghetti.R | 171 +++++++++++++++++++++++++++++-------------- 2 files changed, 120 insertions(+), 54 deletions(-) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 1cd469125..181b83957 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -67,6 +67,8 @@ tm_p_scatterplot <- function(label = "Scatter Plot", checkmate::assert_class(x_var, "picks") checkmate::assert_class(y_var, "picks") checkmate::assert_class(color_var, "picks") + checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) + args <- as.list(environment()) module( label = label, @@ -157,6 +159,7 @@ ui_p_scatterplot <- function(id) { ns <- NS(id) tags$div( class = "standard-layout output-panel", + shinyjs::useShinyjs(), bslib::card( full_screen = TRUE, tags$div( diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index 63360a0ce..9c2b235f0 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -58,46 +58,121 @@ #' #' @export tm_p_spaghetti <- function(label = "Scatter Plot", - plot_dataname, group_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE) { + transformators = list()) { + checkmate::assert_string(label) + checkmate::assert_class(group_var, "picks") + checkmate::assert_class(x_var, "picks") + checkmate::assert_class(y_var, "picks") + checkmate::assert_class(color_var, "picks") + checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) + + args <- as.list(environment()) module( label = label, - ui = ui_p_spaghetti, - server = srv_p_spaghetti, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - group_var = group_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, - point_colors = point_colors, - tooltip_vars = tooltip_vars, - show_widgets = show_widgets + ui = ui_p_spaghetti_module, + server = srv_p_spaghetti_module, + ui_args = args[names(args) %in% names(formals(ui_p_spaghetti_module))], + server_args = args[names(args) %in% names(formals(srv_p_spaghetti_module))], + transformators = transformators, + datanames = { + datanames <- datanames( + list( + group_var = group_var, x_var = x_var, y_var = y_var, + color_var = color_var, tooltip_vars = tooltip_vars + ) + ) + if (length(datanames)) datanames else "all" + } + ) +} + +ui_p_spaghetti_module <- function(id, group_var, x_var, y_var, color_var, tooltip_vars) { + ns <- NS(id) + bslib::page_sidebar( + sidebar = div( + class = "standard-layout encoding-panel", + teal::teal_nav_item( + label = tags$strong("Group Variable:"), + teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) + ), + teal::teal_nav_item( + label = tags$strong("X-axis Variable:"), + teal.transform::module_input_ui(id = ns("x_var"), spec = x_var) + ), + teal::teal_nav_item( + label = tags$strong("Y-axis Variable:"), + teal.transform::module_input_ui(id = ns("y_var"), spec = y_var) + ), + teal::teal_nav_item( + label = tags$strong("Color by:"), + teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + colour_picker_ui(ns("colors")) + ) ), - transformators = transformators + ui_p_spaghetti(ns("output")) ) } +srv_p_spaghetti_module <- function(id, + data, + group_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL) { + moduleServer(id, function(input, output, session) { + selectors <- teal.transform::module_input_srv( + data = data, + spec = list(group_var = group_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) + ) + merged_dataname <- "anl" + merged_q <- reactive({ + req(data(), map_merged(selectors)) + obj <- data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spaghetti plot data preparation") + qenv_merge_selectors(x = obj, selectors = selectors, output_name = merged_dataname) + }) + + color_inputs <- colour_picker_srv( + "colors", + x = reactive({ + selected_color <- req(map_merged(selectors)$color_var) + merged_q()[[merged_dataname]][[selected_color$variables]] + }), + default_colors = point_colors + ) + + srv_p_spaghetti( + "output", + data = merged_q, + dataname = merged_dataname, + x_var = reactive(map_merged(selectors)$x_var$variables), + y_var = reactive(map_merged(selectors)$y_var$variables), + color_var = reactive(map_merged(selectors)$color_var$variables), + color_inputs = color_inputs, + group_var = reactive(map_merged(selectors)$group_var$variables), + tooltip_vars = reactive(map_merged(selectors)$tooltip_vars$variables) + ) + }) +} + ui_p_spaghetti <- function(id) { ns <- NS(id) - bslib::page_fluid( + tags$div( + class = "standard-layout output-panel", shinyjs::useShinyjs(), - tags$div( - tags$span(id = ns("colors_span"), colour_picker_ui(ns("colors"))), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) + bslib::card( + full_screen = TRUE, + tags$div( + trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") ) ) ) @@ -105,38 +180,26 @@ ui_p_spaghetti <- function(id) { srv_p_spaghetti <- function(id, data, - plot_dataname, + dataname, group_var, x_var, y_var, color_var, - point_colors, - tooltip_vars = NULL, - show_widgets) { + color_inputs, + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - data()[[plot_dataname]][[color_var]] - }), - default_colors = point_colors - ) - - if (!show_widgets) { - shinyjs::hide("colors_span") - } - plotly_q <- reactive({ - req(color_inputs()) + req(data(), color_inputs(), group_var(), x_var(), y_var(), color_var()) within( data(), - group_var = group_var, - x_var = x_var, - y_var = y_var, - color_var = color_var, + df = str2lang(dataname), + group_var = group_var(), + x_var = x_var(), + y_var = y_var(), + color_var = color_var(), colors = color_inputs(), source = session$ns("spaghetti"), - tooltip_vars = tooltip_vars, + tooltip_vars = tooltip_vars(), expr = { # Get label attributes for variables, fallback to column names group_var_label <- attr(df[[group_var]], "label") @@ -240,24 +303,24 @@ srv_p_spaghetti <- function(id, plotly::layout(dragmode = "select") p - }, - df = str2lang(plot_dataname) + } ) }) - output$plot <- plotly::renderPlotly( + output$plot <- plotly::renderPlotly({ + req(plotly_q()) plotly_q()$p |> setup_trigger_tooltips(session$ns) |> set_plot_data(session$ns("plot_data")) |> plotly::event_register("plotly_selected") - ) + }) plotly_selected <- reactive( plotly::event_data("plotly_selected", source = session$ns("spaghetti")) ) reactive({ - if (is.null(plotly_selected()) || is.null(group_var)) { + if (is.null(plotly_selected()) || is.null(group_var())) { plotly_q() } else { q <- plotly_q() |> @@ -268,8 +331,8 @@ srv_p_spaghetti <- function(id, df <- df |> dplyr::filter(!!as.name(group_var_string) %in% selected_plot_data[[group_var_string]]) }, - df = str2lang(plot_dataname), - group_var_string = group_var, + df = str2lang(dataname), + group_var_string = group_var(), plotly_selected_customdata = plotly_selected()$customdata ) attr(q, "has_brushing") <- TRUE From b8eb22a58707c39a36dc47942506ee8de023a53c Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 16 Sep 2025 14:59:13 +0000 Subject: [PATCH 134/158] fixes --- R/tm_p_lineplot.R | 30 ++++++++++++++++++++++-------- R/tm_p_scatterplot.R | 16 ++++++++-------- R/tm_p_spaghetti.R | 7 +++---- man/tm_p_lineplot.Rd | 8 ++------ man/tm_p_scatterplot.Rd | 8 +++----- man/tm_p_spaghetti.Rd | 8 +++----- 6 files changed, 41 insertions(+), 36 deletions(-) diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index 13728df77..378220c5e 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -59,7 +59,6 @@ #' #' @export tm_p_lineplot <- function(label = "Line Plot", - plot_dataname, x_var, y_var, color_var, @@ -68,6 +67,12 @@ tm_p_lineplot <- function(label = "Line Plot", tooltip_vars = NULL, transformators = list(), reference_lines = NULL) { + checkmate::assert_string(label) + checkmate::assert_class(x_var, "picks") + checkmate::assert_class(x_var, "picks") + checkmate::assert_class(color_var, "picks") + checkmate::assert_class(group_var, "picks") + checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) args <- as.list(environment()) module( label = label, @@ -83,19 +88,26 @@ tm_p_lineplot <- function(label = "Line Plot", ) } +# todo: ui/srv_p_lineplot_module + ui_p_lineplot <- function(id) { ns <- NS(id) - bslib::page_fluid( - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") + tags$div( + class = "standard-layout output-panel", + shinyjs::useShinyjs(), + bslib::card( + full_screen = TRUE, + tags$div( + trigger_tooltips_deps(), + plotly::plotlyOutput(ns("plot"), height = "100%") + ) ) ) } srv_p_lineplot <- function(id, data, - plot_dataname, + dataname, x_var, y_var, color_var, @@ -108,7 +120,7 @@ srv_p_lineplot <- function(id, req(data()) data() %>% within( - df = str2lang(plot_dataname), + df = str2lang(dataname), x_var = x_var(), y_var = y_var(), color_var = color_var(), @@ -269,13 +281,15 @@ srv_p_lineplot <- function(id, annotations = ref_lines$annotations ) } + p } ) }) output$plot <- plotly::renderPlotly({ - plotly_q()$p %>% + req(plotly_q()) + tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> plotly::event_register("plotly_selected") }) }) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 181b83957..e0b61f8c3 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -68,7 +68,7 @@ tm_p_scatterplot <- function(label = "Scatter Plot", checkmate::assert_class(y_var, "picks") checkmate::assert_class(color_var, "picks") checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) - + args <- as.list(environment()) module( label = label, @@ -112,13 +112,13 @@ ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { } srv_p_scatterplot_module <- function(id, - data, - subject_var, - x_var, - y_var, - color_var, - point_colors, - tooltip_vars = NULL) { + data, + subject_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { selectors <- teal.transform::module_input_srv( data = data, diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index 9c2b235f0..36a6e1090 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -279,7 +279,7 @@ srv_p_spaghetti <- function(id, ) %>% dplyr::filter(!is.na(xend)) - p <- plotly::plot_ly( + plotly::plot_ly( data = segments_df, customdata = ~customdata, source = source @@ -301,8 +301,6 @@ srv_p_spaghetti <- function(id, hoverinfo = "text" ) |> plotly::layout(dragmode = "select") - - p } ) }) @@ -310,7 +308,7 @@ srv_p_spaghetti <- function(id, output$plot <- plotly::renderPlotly({ req(plotly_q()) - plotly_q()$p |> + tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> setup_trigger_tooltips(session$ns) |> set_plot_data(session$ns("plot_data")) |> plotly::event_register("plotly_selected") @@ -320,6 +318,7 @@ srv_p_spaghetti <- function(id, plotly::event_data("plotly_selected", source = session$ns("spaghetti")) ) reactive({ + req(plotly_selected(), plotly_q(), group_var()) if (is.null(plotly_selected()) || is.null(group_var())) { plotly_q() } else { diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd index 70f2f63aa..a81bb4f77 100644 --- a/man/tm_p_lineplot.Rd +++ b/man/tm_p_lineplot.Rd @@ -6,7 +6,6 @@ \usage{ tm_p_lineplot( label = "Line Plot", - plot_dataname, x_var, y_var, color_var, @@ -14,15 +13,12 @@ tm_p_lineplot( colors = NULL, tooltip_vars = NULL, transformators = list(), - reference_lines = NULL, - activate_on_brushing = FALSE + reference_lines = NULL ) } \arguments{ \item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - \item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} \item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis (typically a measurement).} @@ -40,7 +36,7 @@ If \code{NULL}, default tooltip is created showing group, x, y, and color variab \item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for adding horizontal reference lines.} -\item{activate_on_brushing}{(\code{logical(1)}) Whether to activate the plot only when brushing occurs in another plot.} +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} } \description{ This module creates an interactive line plot visualization that connects data points diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd index 79e402e92..7826bc4a8 100644 --- a/man/tm_p_scatterplot.Rd +++ b/man/tm_p_scatterplot.Rd @@ -6,22 +6,18 @@ \usage{ tm_p_scatterplot( label = "Scatter Plot", - plot_dataname, subject_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE + transformators = list() ) } \arguments{ \item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - \item{subject_var}{(\code{character(1)}) Name of the subject variable.} \item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis.} @@ -37,6 +33,8 @@ If \code{NULL}, default tooltip is created showing x, y, and color variables.} \item{transformators}{(\code{list}) Named list of transformator functions.} +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + \item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} } \description{ diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd index 52a877fda..a65916807 100644 --- a/man/tm_p_spaghetti.Rd +++ b/man/tm_p_spaghetti.Rd @@ -6,22 +6,18 @@ \usage{ tm_p_spaghetti( label = "Scatter Plot", - plot_dataname, group_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE + transformators = list() ) } \arguments{ \item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - \item{group_var}{(\code{character(1)}) Name of the grouping variable that defines individual trajectories.} \item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} @@ -37,6 +33,8 @@ If \code{NULL}, default tooltip is created showing group, x, y, and color variab \item{transformators}{(\code{list}) Named list of transformator functions.} +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} + \item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} } \description{ From 3e3acb7eb26cafcf6e96d37274e3b2113e42fe81 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 23 Sep 2025 06:42:04 +0200 Subject: [PATCH 135/158] fix some modules --- NAMESPACE | 10 + R/tm_a_pca.R | 290 +++--- R/tm_a_pca_old.R | 1023 +++++++++++++++++++++ R/tm_a_regression.R | 298 +++---- R/tm_a_regression_old.R | 880 +++++++++++++++++++ R/tm_g_association.R | 104 ++- R/tm_g_association_old.R | 416 +++++++++ R/tm_g_bivariate.R | 127 ++- R/tm_g_bivariate_old.R | 565 ++++++++++++ R/tm_g_distribution.R | 503 +++++------ R/tm_g_distribution_old.R | 1415 ++++++++++++++++++++++++++++++ man/srv_decorate_teal_data.Rd | 5 - man/tm_a_pca.Rd | 9 +- man/tm_a_regression.Rd | 11 +- man/tm_data_table.Rd | 15 - man/tm_file_viewer.Rd | 3 - man/tm_front_page.Rd | 15 - man/tm_g_association.Rd | 10 +- man/tm_g_bivariate.Rd | 6 - man/tm_g_distribution.Rd | 6 - man/tm_g_distribution.default.Rd | 190 ++++ man/tm_g_response.Rd | 6 - man/tm_g_scatterplot.Rd | 6 - man/tm_g_scatterplotmatrix.Rd | 6 - man/tm_missing_data.Rd | 15 - man/tm_outliers.Rd | 6 - man/tm_p_spiderplot.Rd | 6 - man/tm_p_swimlane.Rd | 3 - man/tm_p_waterfall.Rd | 3 - man/tm_rmarkdown.Rd | 12 - man/tm_t_crosstable.Rd | 6 - man/tm_t_reactables.Rd | 15 - man/tm_variable_browser.Rd | 15 - 33 files changed, 5156 insertions(+), 844 deletions(-) create mode 100644 R/tm_a_pca_old.R create mode 100644 R/tm_a_regression_old.R create mode 100644 R/tm_g_association_old.R create mode 100644 R/tm_g_bivariate_old.R create mode 100644 R/tm_g_distribution_old.R create mode 100644 man/tm_g_distribution.default.Rd diff --git a/NAMESPACE b/NAMESPACE index 4b6975ef7..e7827ca83 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -8,6 +8,16 @@ S3method(create_sparklines,default) S3method(create_sparklines,factor) S3method(create_sparklines,logical) S3method(create_sparklines,numeric) +S3method(tm_a_pca,default) +S3method(tm_a_pca,picks) +S3method(tm_a_regression,default) +S3method(tm_a_regression,picks) +S3method(tm_g_association,default) +S3method(tm_g_association,picks) +S3method(tm_g_bivariate,default) +S3method(tm_g_bivariate,picks) +S3method(tm_g_distribution,default) +S3method(tm_g_distribution,picks) export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index 1cf0d40d4..c76a93f8c 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -125,7 +125,10 @@ #' @export #' tm_a_pca <- function(label = "Principal Component Analysis", - dat, + dat = picks( + datasets(), + variables(choices = tidyselect::where(is.numeric), selected = 1:5, multiple = TRUE) + ), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -138,15 +141,39 @@ tm_a_pca <- function(label = "Principal Component Analysis", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_a_pca", dat) +} + +#' @export +tm_a_pca.picks <- function(label = "Principal Component Analysis", + dat = picks( + datasets(), + variables( + choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), + selected = tidyselect::everything(), + multiple = TRUE + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_a_pca") # Normalize the parameters - if (inherits(dat, "data_extract_spec")) dat <- list(dat) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(dat, types = "data_extract_spec") + checkmate::assert_class(dat, "picks") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -194,42 +221,35 @@ tm_a_pca <- function(label = "Principal Component Analysis", # Make UI args args <- as.list(environment()) - data_extract_list <- list(dat = dat) - ans <- module( label = label, - server = srv_a_pca, - ui = ui_a_pca, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + ui = ui_a_pca.picks, + server = srv_a_pca.picks, + ui_args = args[names(args) %in% names(formals(ui_a_pca.picks))], + server_args = args[names(args) %in% names(formals(srv_a_pca.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(dat)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the PCA module -ui_a_pca <- function(id, ...) { +ui_a_pca.picks <- function(id, + dat, + plot_choices, + ggtheme, + rotate_xaxis_labels, + font_size, + alpha, + size, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) - - color_selector <- args$dat - for (i in seq_along(color_selector)) { - color_selector[[i]]$select$multiple <- FALSE - color_selector[[i]]$select$always_selected <- NULL - color_selector[[i]]$select$selected <- NULL - } - tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -237,12 +257,9 @@ ui_a_pca <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args["dat"]), - teal.transform::data_extract_ui( - id = ns("dat"), - label = "Data selection", - data_extract_spec = args$dat, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Data selection"), + teal.transform::module_input_ui(id = ns("dat"), spec = dat) ), bslib::accordion( open = TRUE, @@ -257,35 +274,35 @@ ui_a_pca <- function(id, ...) { radioButtons( ns("plot_type"), label = "Plot type", - choices = args$plot_choices, - selected = args$plot_choices[1] + choices = plot_choices, + selected = plot_choices[1] ), conditionalPanel( condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_elbow_plot"), - decorators = select_decorators(args$decorators, "elbow_plot") + decorators = select_decorators(decorators, "elbow_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_circle_plot"), - decorators = select_decorators(args$decorators, "circle_plot") + decorators = select_decorators(decorators, "circle_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), ui_decorate_teal_data( ns("d_biplot"), - decorators = select_decorators(args$decorators, "biplot") + decorators = select_decorators(decorators, "biplot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_eigenvector_plot"), - decorators = select_decorators(args$decorators, "eigenvector_plot") + decorators = select_decorators(decorators, "eigenvector_plot") ) ) ), @@ -308,14 +325,14 @@ ui_a_pca <- function(id, ...) { conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), list( - teal.transform::data_extract_ui( - id = ns("response"), + shinyWidgets::pickerInput( + inputId = ns("response"), label = "Color by", - data_extract_spec = color_selector, - is_single_dataset = is_single_dataset_value + choices = NULL, + selected = NULL ), - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE) + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE) ) ) ), @@ -324,70 +341,51 @@ ui_a_pca <- function(id, ...) { collapsed = TRUE, conditionalPanel( condition = sprintf( - "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", - ns("plot_type"), - ns("plot_type") + "input['%1$s'] == 'Elbow plot' || input['%1$s'] == 'Eigenvector plot'", ns("plot_type") ), - list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels)) + list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels)) ), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ), - teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE) + teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", font_size, ticks = FALSE) ) ) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) ) } # Server function for the PCA module -srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { +srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - response <- dat + selectors <- teal.transform::module_input_srv(spec = list(dat = dat), data = data) - for (i in seq_along(response)) { - response[[i]]$select$multiple <- FALSE - response[[i]]$select$always_selected <- NULL - response[[i]]$select$selected <- NULL - all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) - ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) - color_cols <- all_cols[!names(all_cols) %in% ignore_cols] - response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(dat = dat, response = response), - datasets = data, - select_validation_rule = list( - dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", - response = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (isTRUE(is.element(., selector_list()$dat()$select))) { - "Response must not have been used for PCA." - } - ) - ) - ) iv_r <- reactive({ iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) + iv$add_rule( + "dat", + ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", + ) + iv$add_rule( + "response", + ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", + ) }) - iv_extra <- shinyvalidate::InputValidator$new() iv_extra$add_rule("x_axis", function(value) { if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { @@ -428,11 +426,7 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco }) iv_extra$enable() - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - qenv <- reactive({ + anl_merged_q <- reactive({ obj <- data() teal.reporter::teal_card(obj) <- c( @@ -440,39 +434,40 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') # nolint: quotes - }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) + obj %>% + teal.code::eval_code('library("ggplot2");library("dplyr");library("tidyr")') %>% # nolint: quotes + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) + selected_variables <- reactive(map_merged(selectors)$dat$variables) + observeEvent(selected_variables(), { + shinyWidgets::updatePickerInput( + inputId = "response", + choices = selected_variables(), + selected = input$response + ) + }) validation <- reactive({ - req(merged$anl_q_r()) + req(anl_merged_q()) # inputs - keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + keep_cols <- map_merged(selectors)$dat$variables na_action <- input$na_action standardization <- input$standardization center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - ANL <- merged$anl_q_r()[["ANL"]] + anl <- anl_merged_q()[["anl"]] - teal::validate_has_data(ANL, 10) + teal::validate_has_data(anl, 10) validate(need( - na_action != "none" | !anyNA(ANL[keep_cols]), + na_action != "none" | !anyNA(anl[keep_cols]), paste( "There are NAs in the dataset. Please deal with them in preprocessing", "or select \"Drop\" in the NA actions inside the encodings panel (left)." ) )) if (scale) { - not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) + not_single <- vapply(anl[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) msg <- paste0( "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", @@ -482,66 +477,49 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco } }) - # computation ---- computation <- reactive({ validation() - # inputs - keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + keep_cols <- map_merged(selectors)$dat$variables na_action <- input$na_action standardization <- input$standardization center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - ANL <- merged$anl_q_r()[["ANL"]] + anl <- anl_merged_q()[["anl"]] - qenv <- teal.code::eval_code( - merged$anl_q_r(), - substitute( - expr = keep_columns <- keep_cols, - env = list(keep_cols = keep_cols) - ) + qenv <- within( + anl_merged_q(), + keep_columns <- keep_cols, + keep_cols = keep_cols ) if (na_action == "drop") { - qenv <- teal.code::eval_code( - qenv, - quote(ANL <- tidyr::drop_na(ANL, keep_columns)) - ) + qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(keep_columns))) } - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), - env = list(center = center, scale = scale) - ) + pca <- summary(stats::prcomp(anl[keep_columns], center = center, scale. = scale, retx = TRUE)), + center = center, scale = scale ) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Principal Components Table") - qenv <- teal.code::eval_code( - qenv, - quote({ - tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") - tbl_importance - }) - ) + qenv <- within(qenv, { + tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") + tbl_importance + }) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Eigenvectors Table") - teal.code::eval_code( - qenv, - quote({ - tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") - tbl_eigenvector - }) - ) + within(qenv, { + tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") + tbl_eigenvector + }) }) - # plot args ---- output$plot_settings <- renderUI({ # reactivity triggers - req(iv_r()$is_valid()) req(computation()) qenv <- computation() @@ -553,10 +531,7 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco tagList( conditionalPanel( - condition = sprintf( - "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", - ns("plot_type"), ns("plot_type") - ), + condition = sprintf("input['%1$s'] == 'Biplot' || input['%1$s'] == 'Circle plot'", ns("plot_type")), list( teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), @@ -578,8 +553,8 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco ) }) - # plot elbow ---- plot_elbow <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_elbow") ggtheme <- input$ggtheme rotate_xaxis_labels <- input$rotate_xaxis_labels font_size <- input$font_size @@ -652,8 +627,8 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco ) } - # plot circle ---- plot_circle <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_circle") x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -725,14 +700,12 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco ) } - # plot biplot ---- plot_biplot <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_biplot") qenv <- base_q - - ANL <- qenv[["ANL"]] - - resp_col <- as.character(merged$anl_input_r()$columns_source$response) - dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) + anl <- qenv[["anl"]] + dat_cols <- map_merged(selectors)$dat$variables + resp_col <- input$response x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -776,7 +749,7 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco expr = { rot_vars <- rot_vars %>% tibble::column_to_rownames("label") %>% - sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% + sweep(1, apply(anl[keep_columns], 2, mean, na.rm = TRUE)) %>% tibble::rownames_to_column("label") %>% dplyr::mutate( xstart = mean(pca$x[, x_axis], na.rm = TRUE), @@ -811,9 +784,9 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco ) dev_labs <- list() } else { - rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) + rp_keys <- setdiff(colnames(anl), dat_cols) - response <- ANL[[resp_col]] + response <- anl[[resp_col]] aes_biplot <- substitute( ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"), @@ -822,10 +795,10 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco qenv <- teal.code::eval_code( qenv, - substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) + substitute(response <- anl[[resp_col]], env = list(resp_col = resp_col)) ) - dev_labs <- list(color = varname_w_label(resp_col, ANL)) + dev_labs <- list(color = varname_w_label(resp_col, anl)) scales_biplot <- if ( @@ -944,8 +917,8 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco ) } - # plot eigenvector_plot ---- plot_eigenvector <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_eigenvector") req(input$pc) pc <- input$pc ggtheme <- input$ggtheme @@ -1086,6 +1059,7 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco output$tbl_importance <- renderTable( expr = { req("importance" %in% input$tables_display, computation()) + logger::log_debug("srv_a_pca rerender tbl_importance") computation()[["tbl_importance"]] }, bordered = TRUE, @@ -1106,6 +1080,7 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco output$tbl_eigenvector <- renderTable( expr = { req("eigenvector" %in% input$tables_display, req(computation())) + logger::log_debug("srv_a_pca rerender tbl_eigenvector") computation()[["tbl_eigenvector"]] }, bordered = TRUE, @@ -1124,9 +1099,6 @@ srv_a_pca <- function(id, data, dat, plot_height, plot_width, ggplot2_args, deco }) output$all_plots <- renderUI({ - teal::validate_inputs(iv_r()) - teal::validate_inputs(iv_extra, header = "Plot settings are required") - validation() tags$div( uiOutput(session$ns("tbl_importance_ui")), diff --git a/R/tm_a_pca_old.R b/R/tm_a_pca_old.R new file mode 100644 index 000000000..ed25e8a96 --- /dev/null +++ b/R/tm_a_pca_old.R @@ -0,0 +1,1023 @@ +#' @export +tm_a_pca.default <- function(label = "Principal Component Analysis", + dat, + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_a_pca") + + # Normalize the parameters + if (inherits(dat, "data_extract_spec")) dat <- list(dat) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(dat, types = "data_extract_spec") + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + ggtheme <- match.arg(ggtheme) + + plot_choices <- c("Elbow plot", "Circle plot", "Biplot", "Eigenvector plot") + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + checkmate::assert_flag(rotate_xaxis_labels) + + if (length(font_size) == 1) { + checkmate::assert_numeric(font_size, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) + } else { + checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE, lower = 8, upper = 20) + checkmate::assert_numeric(font_size[1], lower = font_size[2], upper = font_size[3], .var.name = "font_size") + } + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE, lower = 0, upper = 1) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE, lower = 1, upper = 8) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + available_decorators <- c("elbow_plot", "circle_plot", "biplot", "eigenvector_plot") + assert_decorators(decorators, available_decorators) + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list(dat = dat) + + ans <- module( + label = label, + server = srv_a_pca.default, + ui = ui_a_pca.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- FALSE + ans +} + +# UI function for the PCA module +ui_a_pca.default <- function(id, ...) { + ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) + + color_selector <- args$dat + for (i in seq_along(color_selector)) { + color_selector[[i]]$select$multiple <- FALSE + color_selector[[i]]$select$always_selected <- NULL + color_selector[[i]]$select$selected <- NULL + } + + tagList( + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + uiOutput(ns("all_plots")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args["dat"]), + teal.transform::data_extract_ui( + id = ns("dat"), + label = "Data selection", + data_extract_spec = args$dat, + is_single_dataset = is_single_dataset_value + ), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Display", + checkboxGroupInput( + ns("tables_display"), + "Tables display", + choices = c("PC importance" = "importance", "Eigenvectors" = "eigenvector"), + selected = c("importance", "eigenvector") + ), + radioButtons( + ns("plot_type"), + label = "Plot type", + choices = args$plot_choices, + selected = args$plot_choices[1] + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_elbow_plot"), + decorators = select_decorators(args$decorators, "elbow_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_circle_plot"), + decorators = select_decorators(args$decorators, "circle_plot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_biplot"), + decorators = select_decorators(args$decorators, "biplot") + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), + ui_decorate_teal_data( + ns("d_eigenvector_plot"), + decorators = select_decorators(args$decorators, "eigenvector_plot") + ) + ) + ), + bslib::accordion_panel( + title = "Pre-processing", + radioButtons( + ns("standardization"), "Standardization", + choices = c("None" = "none", "Center" = "center", "Center & Scale" = "center_scale"), + selected = "center_scale" + ), + radioButtons( + ns("na_action"), "NA action", + choices = c("None" = "none", "Drop" = "drop"), + selected = "none" + ) + ), + bslib::accordion_panel( + title = "Selected plot specific settings", + uiOutput(ns("plot_settings")), + conditionalPanel( + condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), + list( + teal.transform::data_extract_ui( + id = ns("response"), + label = "Color by", + data_extract_spec = color_selector, + is_single_dataset = is_single_dataset_value + ), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE) + ) + ) + ), + bslib::accordion_panel( + title = "Plot settings", + collapsed = TRUE, + conditionalPanel( + condition = sprintf( + "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", + ns("plot_type"), + ns("plot_type") + ), + list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels)) + ), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ), + teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) + ) +} + +# Server function for the PCA module +srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + response <- dat + + for (i in seq_along(response)) { + response[[i]]$select$multiple <- FALSE + response[[i]]$select$always_selected <- NULL + response[[i]]$select$selected <- NULL + all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) + ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) + color_cols <- all_cols[!names(all_cols) %in% ignore_cols] + response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(dat = dat, response = response), + datasets = data, + select_validation_rule = list( + dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", + response = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (isTRUE(is.element(., selector_list()$dat()$select))) { + "Response must not have been used for PCA." + } + ) + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + iv_extra <- shinyvalidate::InputValidator$new() + iv_extra$add_rule("x_axis", function(value) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (!shinyvalidate::input_provided(value)) { + "Need X axis" + } + } + }) + iv_extra$add_rule("y_axis", function(value) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (!shinyvalidate::input_provided(value)) { + "Need Y axis" + } + } + }) + rule_dupl <- function(...) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (isTRUE(input$x_axis == input$y_axis)) { + "Please choose different X and Y axes." + } + } + } + iv_extra$add_rule("x_axis", rule_dupl) + iv_extra$add_rule("y_axis", rule_dupl) + iv_extra$add_rule("variables", function(value) { + if (identical(input$plot_type, "Circle plot")) { + if (!shinyvalidate::input_provided(value)) { + "Need Original Coordinates" + } + } + }) + iv_extra$add_rule("pc", function(value) { + if (identical(input$plot_type, "Eigenvector plot")) { + if (!shinyvalidate::input_provided(value)) { + "Need PC" + } + } + }) + iv_extra$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Principal Component Analysis"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') # nolint: quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + validation <- reactive({ + req(merged$anl_q_r()) + # inputs + keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + na_action <- input$na_action + standardization <- input$standardization + center <- standardization %in% c("center", "center_scale") + scale <- standardization == "center_scale" + ANL <- merged$anl_q_r()[["ANL"]] + + teal::validate_has_data(ANL, 10) + validate(need( + na_action != "none" | !anyNA(ANL[keep_cols]), + paste( + "There are NAs in the dataset. Please deal with them in preprocessing", + "or select \"Drop\" in the NA actions inside the encodings panel (left)." + ) + )) + if (scale) { + not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) + + msg <- paste0( + "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", + "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + ) + validate(need(all(not_single), msg)) + } + }) + + # computation ---- + computation <- reactive({ + validation() + + # inputs + keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + na_action <- input$na_action + standardization <- input$standardization + center <- standardization %in% c("center", "center_scale") + scale <- standardization == "center_scale" + ANL <- merged$anl_q_r()[["ANL"]] + + qenv <- teal.code::eval_code( + merged$anl_q_r(), + substitute( + expr = keep_columns <- keep_cols, + env = list(keep_cols = keep_cols) + ) + ) + + if (na_action == "drop") { + qenv <- teal.code::eval_code( + qenv, + quote(ANL <- tidyr::drop_na(ANL, keep_columns)) + ) + } + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), + env = list(center = center, scale = scale) + ) + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Principal Components Table") + + qenv <- teal.code::eval_code( + qenv, + quote({ + tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") + tbl_importance + }) + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Eigenvectors Table") + + teal.code::eval_code( + qenv, + quote({ + tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") + tbl_eigenvector + }) + ) + }) + + # plot args ---- + output$plot_settings <- renderUI({ + # reactivity triggers + req(iv_r()$is_valid()) + req(computation()) + qenv <- computation() + + ns <- session$ns + + pca <- qenv[["pca"]] + chcs_pcs <- colnames(pca$rotation) + chcs_vars <- qenv[["keep_columns"]] + + tagList( + conditionalPanel( + condition = sprintf( + "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", + ns("plot_type"), ns("plot_type") + ), + list( + teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), + teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), + teal.widgets::optionalSelectInput( + ns("variables"), "Original coordinates", + choices = chcs_vars, selected = chcs_vars, + multiple = TRUE + ) + ) + ), + conditionalPanel( + condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), + helpText("No plot specific settings available.") + ), + conditionalPanel( + condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"), + teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) + ) + ) + }) + + # plot elbow ---- + plot_elbow <- function(base_q) { + ggtheme <- input$ggtheme + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle_value <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust_value <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list(x = "Principal component", y = "Proportion of variance explained", color = "", fill = "Legend"), + theme = list( + legend.position = "right", + legend.spacing.y = quote(grid::unit(-5, "pt")), + legend.title = quote(ggplot2::element_text(vjust = 25)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_value, hjust = hjust_value), + list(angle_value = angle_value, hjust_value = hjust_value) + ), + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)) + ) + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Elbow plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ), + ggtheme = ggtheme + ) + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Elbow plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + elb_dat <- pca$importance[c("Proportion of Variance", "Cumulative Proportion"), ] %>% + dplyr::as_tibble(rownames = "metric") %>% + tidyr::gather("component", "value", -metric) %>% + dplyr::mutate( + component = factor(component, levels = unique(stringr::str_sort(component, numeric = TRUE))) + ) + + cols <- c(getOption("ggplot2.discrete.colour"), c("lightblue", "darkred", "black"))[1:3] + elbow_plot <- ggplot2::ggplot(mapping = ggplot2::aes_string(x = "component", y = "value")) + + ggplot2::geom_bar( + ggplot2::aes(fill = "Single variance"), + data = dplyr::filter(elb_dat, metric == "Proportion of Variance"), + color = "black", + stat = "identity" + ) + + ggplot2::geom_point( + ggplot2::aes(color = "Cumulative variance"), + data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") + ) + + ggplot2::geom_line( + ggplot2::aes(group = 1, color = "Cumulative variance"), + data = dplyr::filter(elb_dat, metric == "Cumulative Proportion") + ) + + labs + + ggplot2::scale_color_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[3])) + + ggplot2::scale_fill_manual(values = c("Cumulative variance" = cols[2], "Single variance" = cols[1])) + + ggthemes + + themes + }, + env = list( + ggthemes = parsed_ggplot2_args$ggtheme, + labs = parsed_ggplot2_args$labs, + themes = parsed_ggplot2_args$theme + ) + ) + ) + } + + # plot circle ---- + plot_circle <- function(base_q) { + x_axis <- input$x_axis + y_axis <- input$y_axis + variables <- input$variables + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Circle plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Circle plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + pca_rot <- pca$rotation[, c(x_axis, y_axis)] %>% + dplyr::as_tibble(rownames = "label") %>% + dplyr::filter(label %in% variables) + + circle_data <- data.frame( + x = cos(seq(0, 2 * pi, length.out = 100)), + y = sin(seq(0, 2 * pi, length.out = 100)) + ) + + circle_plot <- ggplot2::ggplot(pca_rot) + + ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis)) + + ggplot2::geom_label( + ggplot2::aes_string(x = x_axis, y = y_axis, label = "label"), + nudge_x = 0.1, nudge_y = 0.05, + fontface = "bold" + ) + + ggplot2::geom_path(ggplot2::aes(x, y, group = 1), data = circle_data) + + ggplot2::geom_point(ggplot2::aes(x = x, y = y), data = data.frame(x = 0, y = 0), shape = "x", size = 5) + + labs + + ggthemes + + themes + }, + env = list( + x_axis = x_axis, + y_axis = y_axis, + variables = variables, + ggthemes = parsed_ggplot2_args$ggtheme, + labs = `if`(is.null(parsed_ggplot2_args$labs), quote(labs()), parsed_ggplot2_args$labs), + themes = parsed_ggplot2_args$theme + ) + ) + ) + } + + # plot biplot ---- + plot_biplot <- function(base_q) { + qenv <- base_q + + ANL <- qenv[["ANL"]] + + resp_col <- as.character(merged$anl_input_r()$columns_source$response) + dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) + x_axis <- input$x_axis + y_axis <- input$y_axis + variables <- input$variables + pca <- qenv[["pca"]] + + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + alpha <- input$alpha + size <- input$size + font_size <- input$font_size + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Biplot") + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = pca_rot <- dplyr::as_tibble(pca$x[, c(x_axis, y_axis)]), + env = list(x_axis = x_axis, y_axis = y_axis) + ) + ) + + # rot_vars = data frame that displays arrows in the plot, need to be scaled to data + if (!is.null(input$variables)) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + r <- sqrt(qchisq(0.69, df = 2)) * prod(colMeans(pca_rot ^ 2)) ^ (1 / 4) # styler: off + v_scale <- rowSums(pca$rotation ^ 2) # styler: off + + rot_vars <- pca$rotation[, c(x_axis, y_axis)] %>% + dplyr::as_tibble(rownames = "label") %>% + dplyr::mutate_at(vars(c(x_axis, y_axis)), function(x) r * x / sqrt(max(v_scale))) + }, + env = list(x_axis = x_axis, y_axis = y_axis) + ) + ) %>% + teal.code::eval_code( + if (is.logical(pca$center) && !pca$center) { + substitute( + expr = { + rot_vars <- rot_vars %>% + tibble::column_to_rownames("label") %>% + sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% + tibble::rownames_to_column("label") %>% + dplyr::mutate( + xstart = mean(pca$x[, x_axis], na.rm = TRUE), + ystart = mean(pca$x[, y_axis], na.rm = TRUE) + ) + }, + env = list(x_axis = x_axis, y_axis = y_axis) + ) + } else { + quote(rot_vars <- rot_vars %>% dplyr::mutate(xstart = 0, ystart = 0)) + } + ) %>% + teal.code::eval_code( + substitute( + expr = rot_vars <- rot_vars %>% dplyr::filter(label %in% variables), + env = list(variables = variables) + ) + ) + } + + pca_plot_biplot_expr <- list(quote(ggplot())) + + if (length(resp_col) == 0) { + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_point(ggplot2::aes_string(x = x_axis, y = y_axis), + data = pca_rot, alpha = alpha, size = size + ), + list(x_axis = input$x_axis, y_axis = input$y_axis, alpha = input$alpha, size = input$size) + ) + ) + dev_labs <- list() + } else { + rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) + + response <- ANL[[resp_col]] + + aes_biplot <- substitute( + ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"), + env = list(x_axis = x_axis, y_axis = y_axis) + ) + + qenv <- teal.code::eval_code( + qenv, + substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) + ) + + dev_labs <- list(color = varname_w_label(resp_col, ANL)) + + scales_biplot <- + if ( + is.character(response) || + is.factor(response) || + (is.numeric(response) && length(unique(response)) <= 6) + ) { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- as.factor(response)) + ) + quote(ggplot2::scale_color_brewer(palette = "Dark2")) + } else if (inherits(response, "Date")) { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- numeric(response)) + ) + + quote( + ggplot2::scale_color_gradient( + low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1], + high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1], + labels = function(x) as.Date(x, origin = "1970-01-01") + ) + ) + } else { + qenv <- teal.code::eval_code( + qenv, + quote(pca_rot$response <- response) + ) + quote(ggplot2::scale_color_gradient( + low = c(getOption("ggplot2.discrete.colour")[2], "darkred")[1], + high = c(getOption("ggplot2.discrete.colour"), "lightblue")[1] + )) + } + + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_point(aes_biplot, data = pca_rot, alpha = alpha, size = size), + env = list(aes_biplot = aes_biplot, alpha = alpha, size = size) + ), + scales_biplot + ) + } + + if (!is.null(input$variables)) { + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + substitute( + ggplot2::geom_segment( + ggplot2::aes_string(x = "xstart", y = "ystart", xend = x_axis, yend = y_axis), + data = rot_vars, + lineend = "round", linejoin = "round", + arrow = grid::arrow(length = grid::unit(0.5, "cm")) + ), + env = list(x_axis = x_axis, y_axis = y_axis) + ), + substitute( + ggplot2::geom_label( + ggplot2::aes_string( + x = x_axis, + y = y_axis, + label = "label" + ), + data = rot_vars, + nudge_y = 0.1, + fontface = "bold" + ), + env = list(x_axis = x_axis, y_axis = y_axis) + ), + quote(ggplot2::geom_point(ggplot2::aes(x = xstart, y = ystart), data = rot_vars, shape = "x", size = 5)) + ) + } + + angle <- ifelse(isTRUE(rotate_xaxis_labels), 45, 0) + hjust <- ifelse(isTRUE(rotate_xaxis_labels), 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = dev_labs, + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Biplot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + pca_plot_biplot_expr <- c( + pca_plot_biplot_expr, + parsed_ggplot2_args + ) + + teal.code::eval_code( + qenv, + substitute( + expr = { + biplot <- plot_call + }, + env = list( + plot_call = Reduce(function(x, y) call("+", x, y), pca_plot_biplot_expr) + ) + ) + ) + } + + # plot eigenvector_plot ---- + plot_eigenvector <- function(base_q) { + req(input$pc) + pc <- input$pc + ggtheme <- input$ggtheme + + rotate_xaxis_labels <- input$rotate_xaxis_labels + font_size <- input$font_size + + angle <- ifelse(rotate_xaxis_labels, 45, 0) + hjust <- ifelse(rotate_xaxis_labels, 1, 0.5) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + theme = list( + text = substitute(ggplot2::element_text(size = font_size), list(font_size = font_size)), + axis.text.x = substitute( + ggplot2::element_text(angle = angle_val, hjust = hjust_val), + list(angle_val = angle, hjust_val = hjust) + ) + ) + ) + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Eigenvector plot"]], + user_default = ggplot2_args$default, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + ggplot_exprs <- c( + list( + quote(ggplot(pca_rot)), + substitute( + ggplot2::geom_bar( + ggplot2::aes_string(x = "Variable", y = pc), + stat = "identity", + color = "black", + fill = c(getOption("ggplot2.discrete.colour"), "lightblue")[1] + ), + env = list(pc = pc) + ), + substitute( + ggplot2::geom_text( + ggplot2::aes( + x = Variable, + y = pc_name, + label = round(pc_name, 3), + vjust = ifelse(pc_name > 0, -0.5, 1.3) + ) + ), + env = list(pc_name = as.name(pc)) + ) + ), + parsed_ggplot2_args$labs, + parsed_ggplot2_args$ggtheme, + parsed_ggplot2_args$theme + ) + + teal.reporter::teal_card(base_q) <- c(teal.reporter::teal_card(base_q), "## Eigenvector plot") + teal.code::eval_code( + base_q, + substitute( + expr = { + pca_rot <- pca$rotation[, pc, drop = FALSE] %>% + dplyr::as_tibble(rownames = "Variable") + eigenvector_plot <- plot_call + }, + env = list( + pc = pc, + plot_call = Reduce(function(x, y) call("+", x, y), ggplot_exprs) + ) + ) + ) + } + + # qenvs --- + output_q <- lapply( + list( + elbow_plot = plot_elbow, + circle_plot = plot_circle, + biplot = plot_biplot, + eigenvector_plot = plot_eigenvector + ), + function(fun) { + reactive({ + req(computation()) + teal::validate_inputs(iv_r()) + teal::validate_inputs(iv_extra, header = "Plot settings are required") + fun(computation()) + }) + } + ) + + decorated_q <- mapply( + function(obj_name, q) { + srv_decorate_teal_data( + id = sprintf("d_%s", obj_name), + data = q, + decorators = select_decorators(decorators, obj_name), + expr = reactive({ + substitute(.plot, env = list(.plot = as.name(obj_name))) + }) + ) + }, + names(output_q), + output_q + ) + + # plot final ---- + decorated_output_q <- reactive({ + switch(req(input$plot_type), + "Elbow plot" = decorated_q$elbow_plot(), + "Circle plot" = decorated_q$circle_plot(), + "Biplot" = decorated_q$biplot(), + "Eigenvector plot" = decorated_q$eigenvector_plot(), + stop("Unknown plot") + ) + }) + + plot_r <- reactive({ + plot_name <- gsub(" ", "_", tolower(req(input$plot_type))) + req(decorated_output_q())[[plot_name]] + }) + + pws <- teal.widgets::plot_with_settings_srv( + id = "pca_plot", + plot_r = plot_r, + height = plot_height, + width = plot_width, + graph_align = "center" + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) + + # tables ---- + output$tbl_importance <- renderTable( + expr = { + req("importance" %in% input$tables_display, computation()) + computation()[["tbl_importance"]] + }, + bordered = TRUE, + align = "c", + digits = 3 + ) + + output$tbl_importance_ui <- renderUI({ + req("importance" %in% input$tables_display) + tags$div( + align = "center", + tags$h4("Principal components importance"), + tableOutput(session$ns("tbl_importance")), + tags$hr() + ) + }) + + output$tbl_eigenvector <- renderTable( + expr = { + req("eigenvector" %in% input$tables_display, req(computation())) + computation()[["tbl_eigenvector"]] + }, + bordered = TRUE, + align = "c", + digits = 3 + ) + + output$tbl_eigenvector_ui <- renderUI({ + req("eigenvector" %in% input$tables_display) + tags$div( + align = "center", + tags$h4("Eigenvectors"), + tableOutput(session$ns("tbl_eigenvector")), + tags$hr() + ) + }) + + output$all_plots <- renderUI({ + teal::validate_inputs(iv_r()) + teal::validate_inputs(iv_extra, header = "Plot settings are required") + + validation() + tags$div( + uiOutput(session$ns("tbl_importance_ui")), + uiOutput(session$ns("tbl_eigenvector_ui")), + teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot")) + ) + }) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "R Code for PCA" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 3ed9f29d6..07cd6d8cd 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -162,8 +162,14 @@ #' @export #' tm_a_regression <- function(label = "Regression Analysis", - regressor, - response, + regressor = picks( + datasets(), + variables(choices = tidyselect::where(is.numeric), selected = -1, multiple = TRUE) + ), + response = picks( + datasets(), + variables(choices = tidyselect::where(is.numeric)) + ), plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -177,19 +183,47 @@ tm_a_regression <- function(label = "Regression Analysis", label_segment_threshold = c(0.5, 0, 10), transformators = list(), decorators = list()) { - message("Initializing tm_a_regression") + UseMethod("tm_a_regression", regressor) +} - # Normalize the parameters - if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) - if (inherits(response, "data_extract_spec")) response <- list(response) - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) +#' @export +tm_a_regression.picks <- function(label = "Regression Analysis", + regressor = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric), + selected = tidyselect::last_col(), + multiple = TRUE + ) + ), + response = picks( + datasets(), + variables(choices = tidyselect::where(is.numeric)) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { + message("Initializing tm_a_regression") # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(regressor, types = "data_extract_spec") + checkmate::assert_class(regressor, "picks") - checkmate::assert_list(response, types = "data_extract_spec") - assert_single_selection(response) + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("response accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE + } checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -219,6 +253,7 @@ tm_a_regression <- function(label = "Regression Analysis", ggtheme <- match.arg(ggtheme) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) plot_choices <- c( "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" @@ -248,39 +283,37 @@ tm_a_regression <- function(label = "Regression Analysis", # Make UI args args <- as.list(environment()) - args[["plot_choices"]] <- plot_choices - data_extract_list <- list( - regressor = regressor, - response = response - ) ans <- module( label = label, - server = srv_a_regression, - ui = ui_a_regression, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - default_outlier_label = default_outlier_label, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + server = srv_a_regression.picks, + ui = ui_a_regression.picks, + ui_args = args[names(args) %in% names(formals(ui_a_regression.picks))], + server_args = args[names(args) %in% names(formals(srv_a_regression.picks))], , transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(regressor, response)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the regression module -ui_a_regression <- function(id, ...) { +ui_a_regression.picks <- function(id, + response, + regressor, + plot_choices, + default_plot_type, + alpha, + size, + label_segment_threshold, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) teal.widgets::standard_layout( output = teal.widgets::white_small_well(tags$div( teal.widgets::plot_with_settings_ui(id = ns("myplot")), @@ -288,24 +321,19 @@ ui_a_regression <- function(id, ...) { )), encoding = tags$div( tags$label("Encodings", class = "text-primary"), tags$br(), - teal.transform::datanames_input(args[c("response", "regressor")]), - teal.transform::data_extract_ui( - id = ns("response"), - label = "Response variable", - data_extract_spec = args$response, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Response variable"), + teal.transform::module_input_ui(id = ns("response"), spec = response) ), - teal.transform::data_extract_ui( - id = ns("regressor"), - label = "Regressor variables", - data_extract_spec = args$regressor, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Regressor variables"), + teal.transform::module_input_ui(id = ns("regressor"), spec = regressor) ), radioButtons( ns("plot_type"), label = "Plot type:", - choices = args$plot_choices, - selected = args$plot_choices[args$default_plot_type] + choices = plot_choices, + selected = plot_choices[default_plot_type] ), checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE), conditionalPanel( @@ -334,13 +362,13 @@ ui_a_regression <- function(id, ...) { label = "Outlier label" ) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE), teal.widgets::optionalSliderInputValMinMax( inputId = ns("label_min_segment"), label = tags$div( @@ -358,7 +386,7 @@ ui_a_regression <- function(id, ...) { ) ) ), - value_min_max = args$label_segment_threshold, + value_min_max = label_segment_threshold, # Extra parameters to sliderInput ticks = FALSE, step = .1, @@ -368,7 +396,7 @@ ui_a_regression <- function(id, ...) { inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -377,112 +405,71 @@ ui_a_regression <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the regression module -srv_a_regression <- function(id, - data, - response, - regressor, - plot_height, - plot_width, - ggplot2_args, - default_outlier_label, - decorators) { +srv_a_regression.picks <- function(id, + data, + response, + regressor, + plot_height, + plot_width, + ggplot2_args, + default_outlier_label, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - ns <- session$ns - rule_rvr1 <- function(value) { - if (isTRUE(input$plot_type == "Response vs Regressor")) { - if (length(value) > 1L) { - "This plot can only have one regressor." - } - } - } - rule_rvr2 <- function(other) { - function(value) { - if (isTRUE(input$plot_type == "Response vs Regressor")) { - otherval <- selector_list()[[other]]()$select - if (isTRUE(value == otherval)) { - "Response and Regressor must be different." - } - } - } - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(response = response, regressor = regressor), - datasets = data, - select_validation_rule = list( - regressor = shinyvalidate::compose_rules( - shinyvalidate::sv_required("At least one regressor should be selected."), - rule_rvr1, - rule_rvr2("response") - ), - response = shinyvalidate::compose_rules( - shinyvalidate::sv_required("At least one response should be selected."), - rule_rvr2("regressor") - ) - ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - iv_out <- shinyvalidate::InputValidator$new() - iv_out$condition(~ isTRUE(input$show_outlier)) - iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) - iv_out$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data + selectors <- teal.transform::module_input_srv( + spec = list(response = response, regressor = regressor), + data = data ) - regression_var <- reactive({ - teal::validate_inputs(iv_r()) - list( - response = as.vector(anl_merged_input()$columns_source$response), - regressor = as.vector(anl_merged_input()$columns_source$regressor) - ) - }) + rule_selectors <- function(value) { + condition <- setequal(selectors$response()$variables$selected, selectors$regressor()$variables$selected) + if (condition) "Response and Regressor must be different." + } + iv_selector <- shinyvalidate::InputValidator$new() + iv_selector$add_rule("response", rule_selectors) + iv_selector$add_rule("regressor", rule_selectors) - qenv <- reactive({ + anl_merged_q <- reactive({ obj <- data() + teal::validate_inputs(iv_selector) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Linear Regression Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') # nolint: quotes + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') %>% # nolint: quotes + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) + regression_var <- reactive({ + list( + response = map_merged(selectors)$response$variables, + regressor = map_merged(selectors)$regressor$variables + ) }) # sets qenv object and populates it with data merge call and fit expression fit_r <- reactive({ - ANL <- anl_merged_q()[["ANL"]] - teal::validate_has_data(ANL, 10) + req(anl_merged_q()) + anl <- anl_merged_q()[["anl"]] + teal::validate_has_data(anl, 10) - validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) + validate(need(is.numeric(anl[regression_var()$response][[1]]), "Response variable should be numeric.")) teal::validate_has_data( - ANL[, c(regression_var()$response, regression_var()$regressor)], 10, + anl[, c(regression_var()$response, regression_var()$regressor)], 10, complete = TRUE, allow_inf = FALSE ) @@ -498,7 +485,7 @@ srv_a_regression <- function(id, ) if (input$show_outlier) { - opts <- teal.transform::variable_choices(ANL) + opts <- teal.transform::variable_choices(anl) selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) { isolate(input$label_var) } else { @@ -515,7 +502,7 @@ srv_a_regression <- function(id, selected = restoreInput(ns("label_var"), selected) ) - data <- ggplot2::fortify(stats::lm(form, data = ANL)) + data <- ggplot2::fortify(stats::lm(form, data = anl)) cooksd <- data$.cooksd[!is.nan(data$.cooksd)] max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) cur_outlier <- isolate(input$outlier) @@ -529,10 +516,10 @@ srv_a_regression <- function(id, } anl_fit <- anl_merged_q() %>% - teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% + teal.code::eval_code(substitute(fit <- stats::lm(form, data = anl), env = list(form = form))) %>% teal.code::eval_code(quote({ for (regressor in names(fit$contrasts)) { - alts <- paste0(levels(ANL[[regressor]]), collapse = "|") + alts <- paste0(levels(anl[[regressor]]), collapse = "|") names(fit$coefficients) <- gsub( paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) ) @@ -546,13 +533,17 @@ srv_a_regression <- function(id, anl_fit }) - label_col <- reactive({ - teal::validate_inputs(iv_out) + iv_label <- shinyvalidate::InputValidator$new() + iv_label$condition(~ isTRUE(input$show_outlier)) + iv_label$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) + iv_label$enable() + label_col <- reactive({ + teal::validate_inputs(iv_label) substitute( expr = dplyr::if_else( data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), - as.character(stats::na.omit(ANL)[[label_var]]), + as.character(stats::na.omit(anl)[[label_var]]), "" ) %>% dplyr::if_else(is.na(.), "cooksd == NaN", .), @@ -600,13 +591,21 @@ srv_a_regression <- function(id, ) }) + + output_0_rule <- function(value) { + if (isTRUE(input$plot_type == "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1) { + "This plot can only have one regressor." + } + } + iv_output_0 <- shinyvalidate::InputValidator$new() + iv_output_0$add_rule("plot_type", output_0_rule) + iv_output_0$enable() output_plot_0 <- reactive({ fit <- fit_r()[["fit"]] - ANL <- anl_merged_q()[["ANL"]] + anl <- anl_merged_q()[["anl"]] + validate(need(ncol(fit$model) == 2, "This plot can only have one regressor.")) - stopifnot(ncol(fit$model) == 2) - - if (!is.factor(ANL[[regression_var()$regressor]])) { + if (!is.factor(anl[[regression_var()$regressor]])) { shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -646,8 +645,8 @@ srv_a_regression <- function(id, module_plot = teal.widgets::ggplot2_args( labs = list( title = "Response vs Regressor", - x = varname_w_label(regression_var()$regressor, ANL), - y = varname_w_label(regression_var()$response, ANL) + x = varname_w_label(regression_var()$regressor, anl), + y = varname_w_label(regression_var()$response, anl) ), theme = list() ) @@ -985,15 +984,16 @@ srv_a_regression <- function(id, }) output_q <- reactive({ - teal::validate_inputs(iv_r()) + # teal::validate_inputs(iv_r()) + switch(input$plot_type, - "Response vs Regressor" = output_plot_0(), - "Residuals vs Fitted" = output_plot_1(), - "Normal Q-Q" = output_plot_2(), - "Scale-Location" = output_plot_3(), - "Cook's distance" = output_plot_4(), - "Residuals vs Leverage" = output_plot_5(), - "Cook's dist vs Leverage" = output_plot_6() + "Response vs Regressor" = req(output_plot_0()), + "Residuals vs Fitted" = req(output_plot_1()), + "Normal Q-Q" = req(output_plot_2()), + "Scale-Location" = req(output_plot_3()), + "Cook's distance" = req(output_plot_4()), + "Residuals vs Leverage" = req(output_plot_5()), + "Cook's dist vs Leverage" = req(output_plot_6()) ) }) @@ -1024,8 +1024,8 @@ srv_a_regression <- function(id, decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) output$text <- renderText({ - req(iv_r()$is_valid()) - req(iv_out$is_valid()) + # req(iv_r()$is_valid()) + # req(iv_out$is_valid()) paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") }) diff --git a/R/tm_a_regression_old.R b/R/tm_a_regression_old.R new file mode 100644 index 000000000..d7b8ab987 --- /dev/null +++ b/R/tm_a_regression_old.R @@ -0,0 +1,880 @@ +#' @export +tm_a_regression.default <- function(label = "Regression Analysis", + regressor, + response, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { + message("Initializing tm_a_regression") + + # Normalize the parameters + if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) + if (inherits(response, "data_extract_spec")) response <- list(response) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(regressor, types = "data_extract_spec") + + checkmate::assert_list(response, types = "data_extract_spec") + assert_single_selection(response) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], + upper = plot_width[3], + null.ok = TRUE, + .var.name = "plot_width" + ) + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + ggtheme <- match.arg(ggtheme) + + plot_choices <- c( + "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", + "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" + ) + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) + checkmate::assert_string(default_outlier_label) + checkmate::assert_list(decorators, "teal_transform_module") + + if (length(label_segment_threshold) == 1) { + checkmate::assert_numeric(label_segment_threshold, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(label_segment_threshold, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric( + label_segment_threshold[1], + lower = label_segment_threshold[2], + upper = label_segment_threshold[3], + .var.name = "label_segment_threshold" + ) + } + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + args[["plot_choices"]] <- plot_choices + data_extract_list <- list( + regressor = regressor, + response = response + ) + + ans <- module( + label = label, + server = srv_a_regression, + ui = ui_a_regression, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + default_outlier_label = default_outlier_label, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- FALSE + ans +} + +# UI function for the regression module +ui_a_regression <- function(id, ...) { + ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well(tags$div( + teal.widgets::plot_with_settings_ui(id = ns("myplot")), + tags$div(verbatimTextOutput(ns("text"))) + )), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), tags$br(), + teal.transform::datanames_input(args[c("response", "regressor")]), + teal.transform::data_extract_ui( + id = ns("response"), + label = "Response variable", + data_extract_spec = args$response, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("regressor"), + label = "Regressor variables", + data_extract_spec = args$regressor, + is_single_dataset = is_single_dataset_value + ), + radioButtons( + ns("plot_type"), + label = "Plot type:", + choices = args$plot_choices, + selected = args$plot_choices[args$default_plot_type] + ), + checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE), + conditionalPanel( + condition = "input['show_outlier']", + ns = ns, + teal.widgets::optionalSliderInput( + ns("outlier"), + tags$div( + tagList( + "Outlier definition:", + bslib::tooltip( + icon("fas fa-circle-info"), + paste( + "Use the slider to choose the cut-off value to define outliers.", + "Points with a Cook's distance greater than", + "the value on the slider times the mean of the Cook's distance of the dataset will have labels." + ) + ) + ) + ), + min = 1, max = 10, value = 9, ticks = FALSE, step = .1 + ), + teal.widgets::optionalSelectInput( + ns("label_var"), + multiple = FALSE, + label = "Outlier label" + ) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax( + inputId = ns("label_min_segment"), + label = tags$div( + tagList( + "Label min. segment:", + bslib::tooltip( + icon("circle-info"), + tags$span( + paste( + "Use the slider to choose the cut-off value to define minimum distance between label and point", + "that generates a line segment.", + "It's only valid when 'Display outlier labels' is checked." + ) + ) + ) + ) + ), + value_min_max = args$label_segment_threshold, + # Extra parameters to sliderInput + ticks = FALSE, + step = .1, + round = FALSE + ), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the regression module +srv_a_regression <- function(id, + data, + response, + regressor, + plot_height, + plot_width, + ggplot2_args, + default_outlier_label, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + ns <- session$ns + + rule_rvr1 <- function(value) { + if (isTRUE(input$plot_type == "Response vs Regressor")) { + if (length(value) > 1L) { + "This plot can only have one regressor." + } + } + } + rule_rvr2 <- function(other) { + function(value) { + if (isTRUE(input$plot_type == "Response vs Regressor")) { + otherval <- selector_list()[[other]]()$select + if (isTRUE(value == otherval)) { + "Response and Regressor must be different." + } + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(response = response, regressor = regressor), + datasets = data, + select_validation_rule = list( + regressor = shinyvalidate::compose_rules( + shinyvalidate::sv_required("At least one regressor should be selected."), + rule_rvr1, + rule_rvr2("response") + ), + response = shinyvalidate::compose_rules( + shinyvalidate::sv_required("At least one response should be selected."), + rule_rvr2("regressor") + ) + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + iv_out <- shinyvalidate::InputValidator$new() + iv_out$condition(~ isTRUE(input$show_outlier)) + iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) + iv_out$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + + regression_var <- reactive({ + teal::validate_inputs(iv_r()) + + list( + response = as.vector(anl_merged_input()$columns_source$response), + regressor = as.vector(anl_merged_input()$columns_source$regressor) + ) + }) + + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Linear Regression Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') # nolint: quotes + }) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + # sets qenv object and populates it with data merge call and fit expression + fit_r <- reactive({ + ANL <- anl_merged_q()[["ANL"]] + teal::validate_has_data(ANL, 10) + + validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) + + teal::validate_has_data( + ANL[, c(regression_var()$response, regression_var()$regressor)], 10, + complete = TRUE, allow_inf = FALSE + ) + + form <- stats::as.formula( + paste( + regression_var()$response, + paste( + regression_var()$regressor, + collapse = " + " + ), + sep = " ~ " + ) + ) + + if (input$show_outlier) { + opts <- teal.transform::variable_choices(ANL) + selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) { + isolate(input$label_var) + } else { + if (length(opts[as.character(opts) == default_outlier_label]) == 0) { + opts[[1]] + } else { + opts[as.character(opts) == default_outlier_label] + } + } + teal.widgets::updateOptionalSelectInput( + session = session, + inputId = "label_var", + choices = opts, + selected = restoreInput(ns("label_var"), selected) + ) + + data <- ggplot2::fortify(stats::lm(form, data = ANL)) + cooksd <- data$.cooksd[!is.nan(data$.cooksd)] + max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) + cur_outlier <- isolate(input$outlier) + updateSliderInput( + session = session, + inputId = "outlier", + min = 1, + max = max_outlier, + value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9) + ) + } + + anl_fit <- anl_merged_q() %>% + teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% + teal.code::eval_code(quote({ + for (regressor in names(fit$contrasts)) { + alts <- paste0(levels(ANL[[regressor]]), collapse = "|") + names(fit$coefficients) <- gsub( + paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) + ) + } + })) %>% + teal.code::eval_code(quote({ + fit_summary <- summary(fit) + fit_summary + })) + teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "## Plot") + anl_fit + }) + + label_col <- reactive({ + teal::validate_inputs(iv_out) + + substitute( + expr = dplyr::if_else( + data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), + as.character(stats::na.omit(ANL)[[label_var]]), + "" + ) %>% + dplyr::if_else(is.na(.), "cooksd == NaN", .), + env = list(outliers = input$outlier, label_var = input$label_var) + ) + }) + + label_min_segment <- reactive({ + input$label_min_segment + }) + + outlier_label <- reactive({ + substitute( + expr = ggrepel::geom_text_repel( + label = label_col, + color = "red", + hjust = 0, + vjust = 1, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = 0.5, + seed = 123 + ), + env = list(label_col = label_col(), label_min_segment = label_min_segment()) + ) + }) + + output_plot_base <- reactive({ + base_fit <- fit_r() + teal.code::eval_code( + base_fit, + quote({ + class(fit$residuals) <- NULL + + data <- ggplot2::fortify(fit) + + smooth <- function(x, y) { + as.data.frame(stats::lowess(x, y, f = 2 / 3, iter = 3)) + } + + smoothy_aes <- ggplot2::aes_string(x = "x", y = "y") + + reg_form <- deparse(fit$call[[2]]) + }) + ) + }) + + output_plot_0 <- reactive({ + fit <- fit_r()[["fit"]] + ANL <- anl_merged_q()[["ANL"]] + + stopifnot(ncol(fit$model) == 2) + + if (!is.factor(ANL[[regression_var()$regressor]])) { + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), + env = list( + regressor = regression_var()$regressor, + response = regression_var()$response, + size = input$size, + alpha = input$alpha + ) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label()) + ) + } + } else { + shinyjs::hide("size") + shinyjs::hide("alpha") + plot <- substitute( + expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + + ggplot2::geom_boxplot(), + env = list(regressor = regression_var()$regressor, response = regression_var()$response) + ) + if (input$show_outlier) { + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + } + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Response vs Regressor"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + title = "Response vs Regressor", + x = varname_w_label(regression_var()$regressor, ANL), + y = varname_w_label(regression_var()$response, ANL) + ), + theme = list() + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + fit_r(), + substitute( + expr = { + class(fit$residuals) <- NULL + data <- ggplot2::fortify(fit) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_1 <- reactive({ + plot_base <- output_plot_base() + shinyjs::show("size") + shinyjs::show("alpha") + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, .resid)) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_hline(yintercept = 0, linetype = "dashed", size = 1) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Residuals vs Fitted"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Fitted values\nlm(", reg_form, ")")), + y = "Residuals", + title = "Residuals vs Fitted" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.fitted, data$.resid) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_2 <- reactive({ + shinyjs::show("size") + shinyjs::show("alpha") + plot_base <- output_plot_base() + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) + + ggplot2::stat_qq(size = size, alpha = alpha) + + ggplot2::geom_abline(linetype = "dashed"), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + + ggplot2::stat_qq( + geom = ggrepel::GeomTextRepel, + label = label_col %>% + data.frame(label = .) %>% + dplyr::filter(label != "cooksd == NaN") %>% + unlist(), + color = "red", + hjust = 0, + vjust = 0, + max.overlaps = Inf, + min.segment.length = label_min_segment, + segment.alpha = .5, + seed = 123 + ), + env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Normal Q-Q"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Theoretical Quantiles\nlm(", reg_form, ")")), + y = "Standardized residuals", + title = "Normal Q-Q" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_3 <- reactive({ + shinyjs::show("size") + shinyjs::show("alpha") + plot_base <- output_plot_base() + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Scale-Location"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Fitted values\nlm(", reg_form, ")")), + y = quote(expression(sqrt(abs(`Standardized residuals`)))), + title = "Scale-Location" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_4 <- reactive({ + shinyjs::hide("size") + shinyjs::show("alpha") + plot_base <- output_plot_base() + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) + + ggplot2::geom_col(alpha = alpha), + env = list(alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute( + expr = plot + + ggplot2::geom_hline( + yintercept = c( + outlier * mean(data$.cooksd, na.rm = TRUE), + mean(data$.cooksd, na.rm = TRUE) + ), + color = "red", + linetype = "dashed" + ) + + ggplot2::annotate( + geom = "text", + x = 0, + y = mean(data$.cooksd, na.rm = TRUE), + label = paste("mu", "=", round(mean(data$.cooksd, na.rm = TRUE), 4)), + vjust = -1, + hjust = 0, + color = "red", + angle = 90 + ) + + outlier_label, + env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Cook's distance"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Obs. number\nlm(", reg_form, ")")), + y = "Cook's distance", + title = "Cook's distance" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_5 <- reactive({ + shinyjs::show("size") + shinyjs::show("alpha") + plot_base <- output_plot_base() + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) + + ggplot2::geom_vline( + size = 1, + colour = "black", + linetype = "dashed", + xintercept = 0 + ) + + ggplot2::geom_hline( + size = 1, + colour = "black", + linetype = "dashed", + yintercept = 0 + ) + + ggplot2::geom_point(size = size, alpha = alpha) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Residuals vs Leverage"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Standardized residuals\nlm(", reg_form, ")")), + y = "Leverage", + title = "Residuals vs Leverage" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.hat, data$.stdresid) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_plot_6 <- reactive({ + shinyjs::show("size") + shinyjs::show("alpha") + plot_base <- output_plot_base() + plot <- substitute( + expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) + + ggplot2::geom_vline(xintercept = 0, colour = NA) + + ggplot2::geom_abline( + slope = seq(0, 3, by = 0.5), + colour = "black", + linetype = "dashed", + size = 1 + ) + + ggplot2::geom_line(data = smoothy, mapping = smoothy_aes) + + ggplot2::geom_point(size = size, alpha = alpha), + env = list(size = input$size, alpha = input$alpha) + ) + if (input$show_outlier) { + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Cook's dist vs Leverage"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args( + labs = list( + x = quote(paste0("Leverage\nlm(", reg_form, ")")), + y = "Cooks's distance", + title = "Cook's dist vs Leverage" + ) + ) + ), + ggtheme = input$ggtheme + ) + + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.hat, data$.cooksd) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) + ) + }) + + output_q <- reactive({ + teal::validate_inputs(iv_r()) + switch(input$plot_type, + "Response vs Regressor" = output_plot_0(), + "Residuals vs Fitted" = output_plot_1(), + "Normal Q-Q" = output_plot_2(), + "Scale-Location" = output_plot_3(), + "Cook's distance" = output_plot_4(), + "Residuals vs Leverage" = output_plot_5(), + "Cook's dist vs Leverage" = output_plot_6() + ) + }) + + decorated_output_q <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + fitted <- reactive({ + req(decorated_output_q()) + decorated_output_q()[["fit"]] + }) + plot_r <- reactive({ + req(decorated_output_q()) + decorated_output_q()[["plot"]] + }) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) + + output$text <- renderText({ + req(iv_r()$is_valid()) + req(iv_out$is_valid()) + paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") + }) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "R code for the regression plot", + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 51f258b63..8e20a400f 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -144,7 +144,6 @@ #' } #' #' @export -#' tm_g_association <- function(label = "Association", ref = picks( datasets(), @@ -152,7 +151,8 @@ tm_g_association <- function(label = "Association", choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1 - ) + ), + values() ), vars = picks( datasets(), @@ -161,7 +161,8 @@ tm_g_association <- function(label = "Association", teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = TRUE - ) + ), + values() ), show_association = TRUE, plot_height = c(600, 400, 5000), @@ -173,6 +174,40 @@ tm_g_association <- function(label = "Association", ggplot2_args = teal.widgets::ggplot2_args(), transformators = list(), decorators = list()) { + UseMethod("tm_g_association", ref) +} + +#' @export +tm_g_association.picks <- function(label = "Association", + ref = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ), + values() + ), + vars = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2, + multiple = TRUE + ), + values() + ), + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_association") # Normalize the parameters @@ -204,28 +239,13 @@ tm_g_association <- function(label = "Association", assert_decorators(decorators, "plot") # End of assertions + args <- as.list(environment()) ans <- module( label = label, - server = srv_tm_g_association, - ui = ui_tm_g_association, - ui_args = list( - ref = ref, - vars = vars, - show_association = show_association, - distribution_theme = distribution_theme, - association_theme = association_theme, - pre_output = pre_output, - post_output = post_output, - decorators = decorators - ), - server_args = list( - ref = ref, - vars = vars, - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ), + ui = ui_g_association.picks, + server = srv_g_association.picks, + ui_args = args[names(args) %in% names(formals(ui_g_association.picks))], + server_args = args[names(args) %in% names(formals(srv_g_association.picks))], transformators = transformators, datanames = { datanames <- datanames(list(ref = ref, vars = vars)) @@ -237,15 +257,15 @@ tm_g_association <- function(label = "Association", } # UI function for the association module -ui_tm_g_association <- function(id, - ref, - vars, - show_association, - distribution_theme, - association_theme, - pre_output, - post_output, - decorators) { +ui_g_association.picks <- function(id, + ref, + vars, + show_association, + distribution_theme, + association_theme, + pre_output, + post_output, + decorators) { ns <- NS(id) teal.widgets::standard_layout( @@ -262,7 +282,7 @@ ui_tm_g_association <- function(id, ), teal::teal_nav_item( label = tags$strong("Associated variables"), - teal.transform::module_input_ui(id = ns("vars"), spec = vars), + teal.transform::module_input_ui(id = ns("vars"), spec = vars) ), checkboxInput(ns("association"), "Association with reference variable", value = show_association), checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), @@ -302,14 +322,14 @@ ui_tm_g_association <- function(id, } # Server function for the association module -srv_tm_g_association <- function(id, - data, - ref, - vars, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_association.picks <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") @@ -351,12 +371,12 @@ srv_tm_g_association <- function(id, teal.code::eval_code(data(), 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') # nolint quotes anl_merged_q <- reactive({ req(qenv()) - teal::validate_inputs(iv) teal.transform::qenv_merge_selectors(x = qenv(), selectors = selectors) }) output_q <- reactive({ req(anl_merged_q()) + logger::log_debug("srv_g_association@1 recalculating a plot") merged <- anl_merged_q()[["merged"]] ref_name <- map_merged(selectors)$ref$variables vars_names <- map_merged(selectors)$vars$variables diff --git a/R/tm_g_association_old.R b/R/tm_g_association_old.R new file mode 100644 index 000000000..4117a829e --- /dev/null +++ b/R/tm_g_association_old.R @@ -0,0 +1,416 @@ +#' @export +tm_g_association.default <- function(label = "Association", + ref, + vars, + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_g_association") + + # Normalize the parameters + if (inherits(ref, "data_extract_spec")) ref <- list(ref) + if (inherits(vars, "data_extract_spec")) vars <- list(vars) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_list(ref, types = "data_extract_spec") + if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) { + stop("'ref' should not allow multiple selection") + } + + checkmate::assert_list(vars, types = "data_extract_spec") + checkmate::assert_flag(show_association) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + distribution_theme <- match.arg(distribution_theme) + association_theme <- match.arg(association_theme) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + plot_choices <- c("Bivariate1", "Bivariate2") + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list( + ref = ref, + vars = vars + ) + + ans <- module( + label = label, + server = srv_tm_g_association.default, + ui = ui_tm_g_association.default, + ui_args = args, + server_args = c( + data_extract_list, + list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the association module +ui_tm_g_association.default <- function(id, ...) { + ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("title")), + tags$br(), + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("ref", "vars")]), + teal.transform::data_extract_ui( + id = ns("ref"), + label = "Reference variable", + data_extract_spec = args$ref, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("vars"), + label = "Associated variables", + data_extract_spec = args$vars, + is_single_dataset = is_single_dataset_value + ), + checkboxInput( + ns("association"), + "Association with reference variable", + value = args$show_association + ), + checkboxInput( + ns("show_dist"), + "Scaled frequencies", + value = FALSE + ), + checkboxInput( + ns("log_transformation"), + "Log transformed", + value = FALSE + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Scatterplot opacity:", c(0.5, 0, 1), ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Scatterplot points size:", c(2, 1, 8), ticks = FALSE), + checkboxInput(ns("swap_axes"), "Swap axes", value = FALSE), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = FALSE), + selectInput( + inputId = ns("distribution_theme"), + label = "Distribution theme (by ggplot):", + choices = ggplot_themes, + selected = args$distribution_theme, + multiple = FALSE + ), + selectInput( + inputId = ns("association_theme"), + label = "Association theme (by ggplot):", + choices = ggplot_themes, + selected = args$association_theme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the association module +srv_tm_g_association.default <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(ref = ref, vars = vars), + datasets = data, + select_validation_rule = list( + ref = shinyvalidate::compose_rules( + shinyvalidate::sv_required("A reference variable needs to be selected."), + ~ if ((.) %in% selector_list()$vars()$select) { + "Associated variables and reference variable cannot overlap" + } + ), + vars = shinyvalidate::compose_rules( + shinyvalidate::sv_required("An associated variable needs to be selected."), + ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) { + "Associated variables and reference variable cannot overlap" + } + ) + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list + ) + + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Association Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("ggmosaic")') # nolint: quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + output_q <- reactive({ + teal::validate_inputs(iv_r()) + + ANL <- merged$anl_q_r()[["ANL"]] + teal::validate_has_data(ANL, 3) + + vars_names <- merged$anl_input_r()$columns_source$vars + + ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) + association <- input$association + show_dist <- input$show_dist + log_transformation <- input$log_transformation + rotate_xaxis_labels <- input$rotate_xaxis_labels + swap_axes <- input$swap_axes + distribution_theme <- input$distribution_theme + association_theme <- input$association_theme + + is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) + if (is_scatterplot) { + shinyjs::show("alpha") + shinyjs::show("size") + alpha <- input$alpha + size <- input$size + } else { + shinyjs::hide("alpha") + shinyjs::hide("size") + alpha <- 0.5 + size <- 2 + } + + teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) + + # reference + ref_class <- class(ANL[[ref_name]])[1] + if (is.numeric(ANL[[ref_name]]) && log_transformation) { + # works for both integers and doubles + ref_cl_name <- call("log", as.name(ref_name)) + ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") + } else { + # silently ignore when non-numeric even if `log` is selected because some + # variables may be numeric and others not + ref_cl_name <- as.name(ref_name) + ref_cl_lbl <- varname_w_label(ref_name, ANL) + } + + user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Bivariate1"]], + user_default = ggplot2_args$default + ) + + ref_call <- bivariate_plot_call( + data_name = "ANL", + x = ref_cl_name, + x_class = ref_class, + x_label = ref_cl_lbl, + freq = !show_dist, + theme = distribution_theme, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = FALSE, + size = size, + alpha = alpha, + ggplot2_args = user_ggplot2_args + ) + + # association + ref_class_cov <- ifelse(association, ref_class, "NULL") + + var_calls <- lapply(vars_names, function(var_i) { + var_class <- class(ANL[[var_i]])[1] + if (is.numeric(ANL[[var_i]]) && log_transformation) { + # works for both integers and doubles + var_cl_name <- call("log", as.name(var_i)) + var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") + } else { + # silently ignore when non-numeric even if `log` is selected because some + # variables may be numeric and others not + var_cl_name <- as.name(var_i) + var_cl_lbl <- varname_w_label(var_i, ANL) + } + + user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Bivariate2"]], + user_default = ggplot2_args$default + ) + + bivariate_plot_call( + data_name = "ANL", + x = ref_cl_name, + y = var_cl_name, + x_class = ref_class_cov, + y_class = var_class, + x_label = ref_cl_lbl, + y_label = var_cl_lbl, + theme = association_theme, + freq = !show_dist, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = swap_axes, + alpha = alpha, + size = size, + ggplot2_args = user_ggplot2_args + ) + }) + + # helper function to format variable name + format_varnames <- function(x) { + if (is.numeric(ANL[[x]]) && log_transformation) { + varname_w_label(x, ANL, prefix = "Log of ") + } else { + varname_w_label(x, ANL) + } + } + new_title <- + if (association) { + switch(as.character(length(vars_names)), + "0" = sprintf("Value distribution for %s", ref_cl_lbl), + "1" = sprintf( + "Association between %s and %s", + ref_cl_lbl, + format_varnames(vars_names) + ), + sprintf( + "Associations between %s and: %s", + ref_cl_lbl, + paste(lapply(vars_names, format_varnames), collapse = ", ") + ) + ) + } else { + switch(as.character(length(vars_names)), + "0" = sprintf("Value distribution for %s", ref_cl_lbl), + sprintf( + "Value distributions for %s and %s", + ref_cl_lbl, + paste(lapply(vars_names, format_varnames), collapse = ", ") + ) + ) + } + obj <- merged$anl_q_r() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") + teal.code::eval_code( + obj, + substitute( + expr = title <- new_title, + env = list(new_title = new_title) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = { + plots <- plot_calls + plot <- gridExtra::arrangeGrob(plots[[1]], plots[[2]], ncol = 1) + }, + env = list( + plot_calls = do.call( + "call", + c(list("list", ref_call), var_calls), + quote = TRUE + ) + ) + ) + ) + }) + + decorated_output_grob_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote({ + grid::grid.newpage() + grid::grid.draw(plot) + }) + ) + + plot_r <- reactive({ + req(iv_r()$is_valid()) + req(decorated_output_grob_q())[["plot"]] + }) + + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_grob_q) + + output$title <- renderText(output_q()[["title"]]) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Association Plot" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 06e449721..e3df2c73d 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -228,9 +228,48 @@ tm_g_bivariate <- function(label = "Bivariate Plots", post_output = NULL, transformators = list(), decorators = list()) { - message("Initializing tm_g_bivariate") - + UseMethod("tm_g_bivariate", x) +} +#' @export +tm_g_bivariate.picks <- function(label = "Bivariate Plots", + x = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ) + ), + y = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2 + ) + ), + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_bivariate") extracted_filters <- extract_filters(list(x, y, row_facet, col_facet, color, fill, size)) transformators <- c( transformators, @@ -247,11 +286,11 @@ tm_g_bivariate <- function(label = "Bivariate Plots", # Start of assertions checkmate::assert_class(x, "picks") checkmate::assert_class(y, "picks") - if (attr(x$variables, "multiple")) { + if (isTRUE(attr(x$variables, "multiple"))) { warning("`x`-axis doesn't accept multiple variables. Changing automatically.") attr(x$variables, "multiple") <- FALSE } - if (attr(y$variables, "multiple")) { + if (isTRUE(attr(y$variables, "multiple"))) { warning("`y`-axis doesn't accept multiple variables. Changing automatically.") attr(x$variables, "multiple") <- FALSE } @@ -311,15 +350,13 @@ tm_g_bivariate <- function(label = "Bivariate Plots", ans <- module( label = label, - server = srv_g_bivariate, - ui = ui_g_bivariate, - ui_args = args[names(args) %in% names(formals(ui_g_bivariate))], - server_args = args[names(args) %in% names(formals(srv_g_bivariate))], + server = srv_g_bivariate.picks, + ui = ui_g_bivariate.picks, + ui_args = args[names(args) %in% names(formals(ui_g_bivariate.picks))], + server_args = args[names(args) %in% names(formals(srv_g_bivariate.picks))], transformators = transformators, datanames = { - datanames <- datanames( - list(x = x, y = y, row_facet = row_facet, col_facet = col_facet, color = color, fill = fill, size = size) - ) + datanames <- teal.transform::datanames(list(x, y, row_facet, col_facet, color, fill, size)) if (length(datanames)) datanames else "all" } ) @@ -328,26 +365,26 @@ tm_g_bivariate <- function(label = "Bivariate Plots", } # UI function for the bivariate module -ui_g_bivariate <- function(id, - x, - y, - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), - color = NULL, - fill = NULL, - size = NULL, - use_density = FALSE, - color_settings = FALSE, - free_x_scales = FALSE, - free_y_scales = FALSE, - rotate_xaxis_labels = FALSE, - swap_axes = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - decorators = list()) { +ui_g_bivariate.picks <- function(id, + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + decorators = list()) { ns <- NS(id) teal::standard_layout2( output = bslib::card( @@ -459,20 +496,20 @@ ui_g_bivariate <- function(id, } # Server function for the bivariate module -srv_g_bivariate <- function(id, - data, - x, - y, - row_facet, - col_facet, - color_settings = FALSE, - color, - fill, - size, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_bivariate.picks <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { diff --git a/R/tm_g_bivariate_old.R b/R/tm_g_bivariate_old.R new file mode 100644 index 000000000..ae764fd0f --- /dev/null +++ b/R/tm_g_bivariate_old.R @@ -0,0 +1,565 @@ +#' @export +tm_g_bivariate.default <- function(label = "Bivariate Plots", + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_bivariate") + + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + if (inherits(color, "data_extract_spec")) color <- list(color) + if (inherits(fill, "data_extract_spec")) fill <- list(fill) + if (inherits(size, "data_extract_spec")) size <- list(size) + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_list(x, types = "data_extract_spec") + assert_single_selection(x) + + checkmate::assert_list(y, types = "data_extract_spec") + assert_single_selection(y) + + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(row_facet) + + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(col_facet) + + checkmate::assert_flag(facet) + + checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(color) + + checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(fill) + + checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(size) + + checkmate::assert_flag(use_density) + + # Determines color, fill & size if they are not explicitly set + checkmate::assert_flag(color_settings) + if (color_settings) { + if (is.null(color)) { + color <- x + color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) + } + if (is.null(fill)) { + fill <- x + fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) + } + if (is.null(size)) { + size <- x + size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) + } + } else { + if (!is.null(c(color, fill, size))) { + stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.") + } + } + + checkmate::assert_flag(free_x_scales) + checkmate::assert_flag(free_y_scales) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(swap_axes) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list( + x = x, + y = y, + row_facet = row_facet, + col_facet = col_facet, + color_settings = color_settings, + color = color, + fill = fill, + size = size + ) + + ans <- module( + label = label, + server = srv_g_bivariate.default, + ui = ui_g_bivariate.default, + ui_args = args, + server_args = c( + data_extract_list, + list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the bivariate module +ui_g_bivariate.default <- function(id, ...) { + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset( + args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size + ) + + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot"))) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]), + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("y"), + label = "Y variable", + data_extract_spec = args$y, + is_single_dataset = is_single_dataset_value + ), + conditionalPanel( + condition = + "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || + $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", + shinyWidgets::radioGroupButtons( + inputId = ns("use_density"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(args$use_density, "density", "frequency"), + justified = TRUE + ) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + if (!is.null(args$row_facet) || !is.null(args$col_facet)) { + tags$div( + class = "data-extract-box", + tags$br(), + bslib::input_switch( + id = ns("facetting"), + label = "Facetting", + value = args$facet + ), + conditionalPanel( + condition = paste0("input['", ns("facetting"), "']"), + tags$div( + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting variable", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting variable", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value + ) + }, + checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales), + checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales) + ) + ) + ) + }, + if (args$color_settings) { + # Put a grey border around the coloring settings + tags$div( + class = "data-extract-box", + tags$label("Color settings"), + bslib::input_switch( + id = ns("coloring"), + label = "Color settings", + value = TRUE + ), + conditionalPanel( + condition = paste0("input['", ns("coloring"), "']"), + tags$div( + teal.transform::data_extract_ui( + id = ns("color"), + label = "Outline color by variable", + data_extract_spec = args$color, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("fill"), + label = "Fill color by variable", + data_extract_spec = args$fill, + is_single_dataset = is_single_dataset_value + ), + tags$div( + id = ns("size_settings"), + teal.transform::data_extract_ui( + id = ns("size"), + label = "Size of points by variable (only if x and y are numeric)", + data_extract_spec = args$size, + is_single_dataset = is_single_dataset_value + ) + ) + ) + ) + ) + }, + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ), + sliderInput( + ns("alpha"), "Opacity Scatterplot:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("fixed_size"), "Scatterplot point size:", + min = 1, max = 8, + step = 1, value = 2, ticks = FALSE + ), + checkboxInput(ns("add_lines"), "Add lines"), + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the bivariate module +srv_g_bivariate.default <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + ns <- session$ns + + data_extract <- list( + x = x, y = y, row_facet = row_facet, col_facet = col_facet, + color = color, fill = fill, size = size + ) + + rule_var <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()$select + if (length(value) == 0L && length(othervalue) == 0L) { + "Please select at least one of x-variable or y-variable" + } + } + } + rule_diff <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + x = rule_var("y"), + y = rule_var("x"), + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("row_facet") + ) + ) + ) + + iv_r <- reactive({ + iv_facet <- shinyvalidate::InputValidator$new() + iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, + validator_names = c("row_facet", "col_facet") + ) + iv_child$condition(~ isTRUE(input$facetting)) + + iv <- shinyvalidate::InputValidator$new() + iv$add_validator(iv_child) + teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y")) + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + + anl_merged_q <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Bivariate Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + obj %>% + teal.code::eval_code( + c( + 'library("ggplot2");library("dplyr")', # nolint: quotes + as.expression(anl_merged_input()$expr) + ) + ) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + output_q <- reactive({ + teal::validate_inputs(iv_r()) + + ANL <- merged$anl_q_r()[["ANL"]] + teal::validate_has_data(ANL, 3) + + x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) + x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) + y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) + y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) + + row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) + col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) + color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$color) + } else { + character(0) + } + fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$fill) + } else { + character(0) + } + size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$size) + } else { + character(0) + } + + use_density <- input$use_density == "density" + free_x_scales <- input$free_x_scales + free_y_scales <- input$free_y_scales + ggtheme <- input$ggtheme + rotate_xaxis_labels <- input$rotate_xaxis_labels + swap_axes <- input$swap_axes + + is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && + length(x_name) > 0 && length(y_name) > 0 + + if (is_scatterplot) { + shinyjs::show("alpha") + alpha <- input$alpha + shinyjs::show("add_lines") + + if (color_settings && input$coloring) { + shinyjs::hide("fixed_size") + shinyjs::show("size_settings") + size <- NULL + } else { + shinyjs::show("fixed_size") + size <- input$fixed_size + } + } else { + shinyjs::hide("add_lines") + updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE)) + shinyjs::hide("alpha") + shinyjs::hide("fixed_size") + shinyjs::hide("size_settings") + alpha <- 1 + size <- NULL + } + + teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + + cl <- bivariate_plot_call( + data_name = "ANL", + x = x_name, + y = y_name, + x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), + y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, ANL), + y_label = varname_w_label(y_name, ANL), + freq = !use_density, + theme = ggtheme, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = swap_axes, + alpha = alpha, + size = size, + ggplot2_args = ggplot2_args + ) + + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + + if (facetting) { + facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) + + if (!is.null(facet_cl)) { + cl <- call("+", cl, facet_cl) + } + } + + if (input$add_lines) { + cl <- call("+", cl, quote(geom_line(size = 1))) + } + + coloring_cl <- NULL + if (color_settings) { + if (input$coloring) { + coloring_cl <- coloring_ggplot_call( + colour = color_name, + fill = fill_name, + size = size_name, + is_point = any(grepl("geom_point", cl %>% deparse())) + ) + legend_lbls <- substitute( + expr = labs(color = color_name, fill = fill_name, size = size_name), + env = list( + color_name = varname_w_label(color_name, ANL), + fill_name = varname_w_label(fill_name, ANL), + size_name = varname_w_label(size_name, ANL) + ) + ) + } + if (!is.null(coloring_cl)) { + cl <- call("+", call("+", cl, coloring_cl), legend_lbls) + } + } + + obj <- merged$anl_q_r() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") + teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) + }) + + decorated_output_q_facets <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = reactive({ + ANL <- merged$anl_q_r()[["ANL"]] + row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) + col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) + + # Add labels to facets + nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) + nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting + + print_call <- if (without_facet) { + quote(plot) + } else { + substitute( + expr = { + teal.modules.general::add_facet_labels( + plot, + xfacet_label = nulled_col_facet_name, + yfacet_label = nulled_row_facet_name + ) + }, + env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) + ) + } + print_call + }) + ) + + plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q_facets) + + # Render R code. + + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Bivariate Plot" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 1e8ae5a61..d22ae5e15 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -151,26 +151,44 @@ tm_g_distribution <- function(label = "Distribution Module", post_output = NULL, transformators = list(), decorators = list()) { + UseMethod("tm_g_distribution", dist_var) +} + +#' @export +tm_g_distribution.picks <- function(label = "Distribution Module", + dist_var = picks(datasets(), variables(where(is.numeric))), + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_distribution") - # Normalize the parameters - if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) - if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) - if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(dist_var, "data_extract_spec") - checkmate::assert_false(dist_var[[1L]]$select$multiple) + checkmate::assert_class(dist_var, "picks") + if (isTRUE(attr(dist_var$variables, "multiple"))) { + warning("dist_var accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(dist_var$variables, "multiple") <- FALSE + } + checkmate::assert_class(strata_var, "picks", null.ok = TRUE) + checkmate::assert_class(group_var, "picks", null.ok = TRUE) - checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) checkmate::assert_flag(freq) ggtheme <- match.arg(ggtheme) plot_choices <- c("Histogram", "QQplot") + + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) checkmate::assert_list(ggplot2_args, types = "ggplot2_args") checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) @@ -199,39 +217,34 @@ tm_g_distribution <- function(label = "Distribution Module", # Make UI args args <- as.list(environment()) - data_extract_list <- list( - dist_var = dist_var, - strata_var = strata_var, - group_var = group_var - ) - ans <- module( label = label, - server = srv_distribution, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), - ui = ui_distribution, - ui_args = args, + server = srv_g_distribution.picks, + ui = ui_g_distribution.picks, + ui_args = args[names(args) %in% names(formals(ui_g_distribution.picks))], + server_args = args[names(args) %in% names(formals(srv_g_distribution.picks))], , transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(dist_var, strata_var, group_var)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the distribution module -ui_distribution <- function(id, ...) { - args <- list(...) +ui_g_distribution.picks <- function(id, + strata_var, + dist_var, + group_var, + freq, + bins, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) - teal.widgets::standard_layout( output = teal.widgets::white_small_well( tabsetPanel( @@ -256,30 +269,25 @@ ui_distribution <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("dist_var", "strata_var")]), - teal.transform::data_extract_ui( - id = ns("dist_i"), - label = "Variable", - data_extract_spec = args$dist_var, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Variable"), + teal.transform::module_input_ui(id = ns("dist_var"), spec = dist_var) ), - if (!is.null(args$group_var)) { + if (!is.null(group_var)) { tagList( - teal.transform::data_extract_ui( - id = ns("group_i"), - label = "Group by", - data_extract_spec = args$group_var, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Group by:"), + teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) ), uiOutput(ns("scales_types_ui")) ) }, - if (!is.null(args$strata_var)) { - teal.transform::data_extract_ui( - id = ns("strata_i"), - label = "Stratify by", - data_extract_spec = args$strata_var, - is_single_dataset = is_single_dataset_value + if (!is.null(strata_var)) { + tagList( + teal::teal_nav_item( + label = tags$strong("Stratify by:"), + teal.transform::module_input_ui(id = ns("strata_var"), spec = strata_var) + ) ) }, bslib::accordion( @@ -287,19 +295,19 @@ ui_distribution <- function(id, ...) { condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), bslib::accordion_panel( "Histogram", - teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1), + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), shinyWidgets::prettyRadioButtons( ns("main_type"), label = "Plot Type:", choices = c("Density", "Frequency"), - selected = if (!args$freq) "Density" else "Frequency", + selected = if (!freq) "Density" else "Frequency", bigger = FALSE, inline = TRUE ), checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), ui_decorate_teal_data( ns("d_density"), - decorators = select_decorators(args$decorators, "histogram_plot") + decorators = select_decorators(decorators, "histogram_plot") ) ) ), @@ -310,7 +318,7 @@ ui_distribution <- function(id, ...) { checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), ui_decorate_teal_data( ns("d_qq"), - decorators = select_decorators(args$decorators, "qq_plot") + decorators = select_decorators(decorators, "qq_plot") ), collapsed = FALSE ) @@ -349,14 +357,14 @@ ui_distribution <- function(id, ...) { "Tests:", choices = c( "Shapiro-Wilk", - if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", - if (!is.null(args$strata_var)) "one-way ANOVA", - if (!is.null(args$strata_var)) "Fligner-Killeen", - if (!is.null(args$strata_var)) "F-test", + if (!is.null(strata_var)) "t-test (two-samples, not paired)", + if (!is.null(strata_var)) "one-way ANOVA", + if (!is.null(strata_var)) "Fligner-Killeen", + if (!is.null(strata_var)) "F-test", "Kolmogorov-Smirnov (one-sample)", "Anderson-Darling (one-sample)", "Cramer-von Mises (one-sample)", - if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" + if (!is.null(strata_var)) "Kolmogorov-Smirnov (two-samples)" ), selected = NULL ) @@ -371,7 +379,7 @@ ui_distribution <- function(id, ...) { inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -380,28 +388,27 @@ ui_distribution <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the distribution module -srv_distribution <- function(id, - data, - dist_var, - strata_var, - group_var, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_distribution.picks <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") setBookmarkExclude("params_reset") - ns <- session$ns rule_req <- function(value) { @@ -427,28 +434,21 @@ srv_distribution <- function(id, } } - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list( - dist_i = dist_var, - strata_i = strata_var, - group_i = group_var - ), - data, - select_validation_rule = list( - dist_i = shinyvalidate::sv_required("Please select a variable") - ), - filter_validation_rule = list( - strata_i = shinyvalidate::compose_rules( - rule_req, - rule_dupl - ), - group_i = rule_dupl - ) + selectors <- teal.transform::module_input_srv( + spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), + data = data ) + iv_r <- reactive({ iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") + # teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") + # dist_i = shinyvalidate::sv_required("Please select a variable") + # strata_i = shinyvalidate::compose_rules( + # rule_req, + # rule_dupl + # ), + # group_i = rule_dupl }) iv_r_dist <- reactive({ @@ -518,28 +518,23 @@ srv_distribution <- function(id, iv_dist$add_rule("dist_param2", rule_dist_2) iv_dist$enable() - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - - qenv <- reactive( - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes - ) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) + req(data()) + qenv <- data() + teal.code::eval_code(qenv, 'library("ggplot2");library("dplyr")') %>% + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q + merge_vars <- reactive( + list( + dist_var = map_merged(selectors)$dist_var$variables, + strata_var = map_merged(selectors)$strata_var$variables, + group_var = map_merged(selectors)$group_var$variables + ) ) output$scales_types_ui <- renderUI({ - if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) { + if (length(merge_vars()$group_var) > 0) { shinyWidgets::prettyRadioButtons( ns("scales_type"), label = "Scales:", @@ -555,7 +550,7 @@ srv_distribution <- function(id, eventExpr = list( input$t_dist, input$params_reset, - selector_list()$dist_i()$select + selectors$dist_var()$variables$selected ), handlerExpr = { params <- @@ -570,8 +565,8 @@ srv_distribution <- function(id, ) } - ANL <- merged$anl_q_r()[["ANL"]] - round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) + anl <- anl_merged_q()[["anl"]] + round(get_dist_params(as.numeric(stats::na.omit(anl[[merge_vars()$dist_var]])), input$t_dist), 2) } else { c("param1" = NA_real_, "param2" = NA_real_) } @@ -608,47 +603,19 @@ srv_distribution <- function(id, updateActionButton(inputId = "params_reset", label = "Reset params") }) - merge_vars <- reactive({ - teal::validate_inputs(iv_r()) - - dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) - s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) - g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) - - dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL - s_var_name <- if (length(s_var)) as.name(s_var) else NULL - g_var_name <- if (length(g_var)) as.name(g_var) else NULL - - list( - dist_var = dist_var, - s_var = s_var, - g_var = g_var, - dist_var_name = dist_var_name, - s_var_name = s_var_name, - g_var_name = g_var_name - ) - }) - # common qenv common_q <- reactive({ + req(anl_merged_q()) # Create a private stack for this function only. - - obj <- merged$anl_q_r() - teal.reporter::teal_card(obj) <- + qenv <- anl_merged_q() + teal.reporter::teal_card(qenv) <- c( teal.reporter::teal_card("# Distribution Plot"), - teal.reporter::teal_card(obj), + teal.reporter::teal_card(qenv), teal.reporter::teal_card("## Module's code") ) - ANL <- obj[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + anl <- qenv[["anl"]] roundn <- input$roundn dist_param1 <- input$dist_param1 @@ -656,45 +623,39 @@ srv_distribution <- function(id, # isolated as dist_param1/dist_param2 already triggered the reactivity t_dist <- isolate(input$t_dist) - qenv <- obj - - if (length(g_var) > 0) { + if (length(merge_vars()$group_var) > 0) { validate( need( - inherits(ANL[[g_var]], c("integer", "factor", "character")), + inherits(anl[[merge_vars()$group_var]], c("integer", "factor", "character")), "Group by variable must be `factor`, `character`, or `integer`" ) ) - qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes - qenv <- teal.code::eval_code( + qenv <- within(qenv, library("forcats")) + qenv <- within( qenv, - substitute( - expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), - env = list(g_var = g_var) - ) + expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), + group_var = merge_vars()$group_var ) } - if (length(s_var) > 0) { + if (length(merge_vars()$strata_var) > 0) { validate( need( - inherits(ANL[[s_var]], c("integer", "factor", "character")), + inherits(anl[[merge_vars()$strata_var]], c("integer", "factor", "character")), "Stratify by variable must be `factor`, `character`, or `integer`" ) ) - qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes - qenv <- teal.code::eval_code( + qenv <- within(qenv, library("forcats")) + qenv <- within( qenv, - substitute( - expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), - env = list(s_var = s_var) - ) + expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), + strata_var = merge_vars()$strata_var ) } - validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) - teal::validate_has_data(ANL, 1, complete = TRUE) + validate(need(is.numeric(anl[[merge_vars()$dist_var]]), "Please select a numeric variable.")) + teal::validate_has_data(anl, 1, complete = TRUE) if (length(t_dist) != 0) { map_distr_nams <- list( @@ -705,66 +666,53 @@ srv_distribution <- function(id, ) params_names_raw <- map_distr_nams[[t_dist]] - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = { - params <- as.list(c(dist_param1, dist_param2)) - names(params) <- params_names_raw - }, - env = list( - dist_param1 = dist_param1, - dist_param2 = dist_param2, - params_names_raw = params_names_raw - ) - ) + expr = { + params <- as.list(c(dist_param1, dist_param2)) + names(params) <- params_names_raw + }, + dist_param1 = dist_param1, + dist_param2 = dist_param2, + params_names_raw = params_names_raw ) } - if (length(s_var) == 0 && length(g_var) == 0) { - teal.code::eval_code( + if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { + within( qenv, - substitute( - expr = { - summary_table_data <- ANL %>% - dplyr::summarise( - min = round(min(dist_var_name, na.rm = TRUE), roundn), - median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), - mean = round(mean(dist_var_name, na.rm = TRUE), roundn), - max = round(max(dist_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - env = list( - dist_var_name = as.name(dist_var), - roundn = roundn - ) - ) + expr = { + summary_table_data <- anl %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + roundn = roundn ) } else { - teal.code::eval_code( + within( qenv, - substitute( - expr = { - strata_vars <- strata_vars_raw - summary_table_data <- ANL %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% - dplyr::summarise( - min = round(min(dist_var_name, na.rm = TRUE), roundn), - median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), - mean = round(mean(dist_var_name, na.rm = TRUE), roundn), - max = round(max(dist_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - env = list( - dist_var_name = dist_var_name, - strata_vars_raw = c(g_var, s_var), - roundn = roundn - ) - ) + expr = { + summary_table_data <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), + roundn = roundn ) } }) @@ -780,12 +728,13 @@ srv_distribution <- function(id, is.null(input$ggtheme) }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + d_var_name <- as.name(d_var) + s_var_name <- if (!is.null(s_var)) as.name(s_var) + g_var_name <- if (!is.null(g_var)) as.name(g_var) + t_dist <- input$t_dist dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -798,7 +747,7 @@ srv_distribution <- function(id, add_dens_var <- input$add_dens ggtheme <- input$ggtheme - teal::validate_inputs(iv_dist) + # teal::validate_inputs(iv_dist) qenv <- common_q() @@ -806,17 +755,17 @@ srv_distribution <- function(id, plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name)) + + expr = ggplot2::ggplot(anl, ggplot2::aes(d_var_name)) + ggplot2::geom_histogram( position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 ), env = list( - m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) + m_type = as.name(m_type), bins_var = bins_var, d_var_name = d_var_name ) ) } else if (length(s_var) != 0 && length(g_var) == 0) { substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name, col = s_var_name)) + + expr = ggplot2::ggplot(anl, ggplot2::aes(d_var_name, col = s_var_name)) + ggplot2::geom_histogram( position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 @@ -824,7 +773,7 @@ srv_distribution <- function(id, env = list( m_type = as.name(m_type), bins_var = bins_var, - dist_var_name = dist_var_name, + d_var_name = d_var_name, s_var = as.name(s_var), s_var_name = s_var_name ) @@ -832,7 +781,7 @@ srv_distribution <- function(id, } else if (length(s_var) == 0 && length(g_var) != 0) { req(scales_type) substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name)) + + expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes(d_var_name)) + ggplot2::geom_histogram( position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 ) + @@ -840,7 +789,7 @@ srv_distribution <- function(id, env = list( m_type = as.name(m_type), bins_var = bins_var, - dist_var_name = dist_var_name, + d_var_name = d_var_name, g_var = g_var, g_var_name = g_var_name, scales_raw = tolower(scales_type) @@ -849,7 +798,7 @@ srv_distribution <- function(id, } else { req(scales_type) substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name, col = s_var_name)) + + expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes(d_var_name, col = s_var_name)) + ggplot2::geom_histogram( position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 @@ -858,7 +807,7 @@ srv_distribution <- function(id, env = list( m_type = as.name(m_type), bins_var = bins_var, - dist_var_name = dist_var_name, + d_var_name = d_var_name, g_var = g_var, s_var = as.name(s_var), g_var_name = g_var_name, @@ -884,7 +833,7 @@ srv_distribution <- function(id, const = if (main_type_var == "Density") { 1 } else { - diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var + diff(range(qenv[["anl"]][[dist_var]], na.rm = TRUE)) / bins_var }, m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"), ndensity = ndensity @@ -927,7 +876,7 @@ srv_distribution <- function(id, ) plot_call <- substitute( expr = plot_call + stat_function( - data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), + data = data.frame(x = range(anl[[dist_var]]), color = mapped_dist), ggplot2::aes(x, color = color), fun = mapped_dist_name, n = ndensity, @@ -976,38 +925,41 @@ srv_distribution <- function(id, input$tabs }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + browser() + + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + d_var_name <- as.name(s_var) + s_var_name <- if (!is.null(s_var)) as.name(s_var) + g_var_name <- if (!is.null(g_var)) as.name(g_var) + dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 scales_type <- input$scales_type ggtheme <- input$ggtheme - teal::validate_inputs(iv_r_dist(), iv_dist) + # teal::validate_inputs(iv_r_dist(), iv_dist) t_dist <- req(input$t_dist) # Not validated when tab is not selected qenv <- common_q() plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var)), - env = list(dist_var = dist_var) + expr = ggplot2::ggplot(anl, ggplot2::aes_string(sample = d_var)), + env = list(d_var = d_var) ) } else if (length(s_var) != 0 && length(g_var) == 0) { substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var, color = s_var)), - env = list(dist_var = dist_var, s_var = s_var) + expr = ggplot2::ggplot(anl, ggplot2::aes_string(sample = d_var, color = s_var)), + env = list(d_var = d_var, s_var = s_var) ) } else if (length(s_var) == 0 && length(g_var) != 0) { substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var)) + + expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes_string(sample = d_var)) + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), env = list( - dist_var = dist_var, + d_var = d_var, g_var = g_var, g_var_name = g_var_name, scales_raw = tolower(scales_type) @@ -1015,10 +967,10 @@ srv_distribution <- function(id, ) } else { substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var, color = s_var)) + + expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes_string(sample = d_var, color = s_var)) + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), env = list( - dist_var = dist_var, + d_var = d_var, g_var = g_var, s_var = s_var, g_var_name = g_var_name, @@ -1108,15 +1060,14 @@ srv_distribution <- function(id, }, valueExpr = { # Create a private stack for this function only. - ANL <- common_q()[["ANL"]] - - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var + anl <- common_q()[["anl"]] - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + d_var_name <- as.name(s_var) + s_var_name <- if (!is.null(s_var)) as.name(s_var) + g_var_name <- if (!is.null(g_var)) as.name(g_var) dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -1125,10 +1076,10 @@ srv_distribution <- function(id, req(dist_tests) - teal::validate_inputs(iv_dist) + # teal::validate_inputs(iv_dist) if (length(s_var) > 0 || length(g_var) > 0) { - counts <- ANL %>% + counts <- anl %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% dplyr::summarise(n = dplyr::n()) @@ -1143,14 +1094,14 @@ srv_distribution <- function(id, )) { if (length(g_var) == 0 && length(s_var) > 0) { validate(need( - length(unique(ANL[[s_var]])) == 2, + length(unique(anl[[s_var]])) == 2, "Please select stratify variable with 2 levels." )) } if (length(g_var) > 0 && length(s_var) > 0) { validate(need( all(stats::na.omit(as.vector( - tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 + tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 ))), "Please select stratify variable with 2 levels, per each group." )) @@ -1163,47 +1114,47 @@ srv_distribution <- function(id, ) sks_args <- list( test = quote(stats::ks.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) ssw_args <- list( test = quote(stats::shapiro.test), - args = bquote(list(.[[.(dist_var)]])), + args = bquote(list(.[[.(d_var)]])), groups = c(g_var, s_var) ) mfil_args <- list( test = quote(stats::fligner.test), - args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), + args = bquote(list(.[[.(d_var)]], .[[.(s_var)]])), groups = c(g_var) ) sad_args <- list( test = quote(goftest::ad.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) scvm_args <- list( test = quote(goftest::cvm.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) manov_args <- list( test = quote(stats::aov), - args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), + args = bquote(list(stats::formula(.(d_var_name) ~ .(s_var_name)), .)), groups = c(g_var) ) mt_args <- list( test = quote(stats::t.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) mv_args <- list( test = quote(stats::var.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) mks_args <- list( test = quote(stats::ks.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) @@ -1221,13 +1172,13 @@ srv_distribution <- function(id, env <- list( t_test = t_dist, - dist_var = dist_var, + d_var = d_var, g_var = g_var, s_var = s_var, args = tests_base$args, groups = tests_base$groups, test = tests_base$test, - dist_var_name = dist_var_name, + d_var_name = d_var_name, g_var_name = g_var_name, s_var_name = s_var_name ) @@ -1240,8 +1191,8 @@ srv_distribution <- function(id, qenv, substitute( expr = { - test_table_data <- ANL %>% - dplyr::select(dist_var) %>% + test_table_data <- anl %>% + dplyr::select(d_var) %>% with(., generics::glance(do.call(test, args))) %>% dplyr::mutate_if(is.numeric, round, 3) }, @@ -1254,8 +1205,8 @@ srv_distribution <- function(id, qenv, substitute( expr = { - test_table_data <- ANL %>% - dplyr::select(dist_var, s_var, g_var) %>% + test_table_data <- anl %>% + dplyr::select(d_var, s_var, g_var) %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% dplyr::do(tests = generics::glance(do.call(test, args))) %>% tidyr::unnest(tests) %>% @@ -1269,8 +1220,6 @@ srv_distribution <- function(id, ) # outputs ---- - output_dist_q <- reactive(c(common_q(), req(dist_q()))) - output_qq_q <- reactive(c(common_q(), req(qq_q()))) # Summary table listing has to be created separately to allow for qenv join q_common <- common_q() @@ -1313,14 +1262,14 @@ srv_distribution <- function(id, decorated_output_dist_q <- srv_decorate_teal_data( "d_density", - data = output_dist_q, + data = dist_q, decorators = select_decorators(decorators, "histogram_plot"), expr = quote(histogram_plot) ) decorated_output_qq_q <- srv_decorate_teal_data( "d_qq", - data = output_qq_q, + data = qq_q, decorators = select_decorators(decorators, "qq_plot"), expr = quote(qq_plot) ) diff --git a/R/tm_g_distribution_old.R b/R/tm_g_distribution_old.R new file mode 100644 index 000000000..a7ff967dd --- /dev/null +++ b/R/tm_g_distribution_old.R @@ -0,0 +1,1415 @@ +#' `teal` module: Distribution analysis +#' +#' Module is designed to explore the distribution of a single variable within a given dataset. +#' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to +#' visually and statistically analyze the variable's distribution. +#' +#' @inheritParams teal::module +#' @inheritParams teal.widgets::standard_layout +#' @inheritParams shared_params +#' +#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' Variable(s) for which the distribution will be analyzed. +#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' Categorical variable used to split the distribution analysis. +#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' Variable used for faceting plot into multiple panels. +#' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). +#' Defaults to density (`FALSE`). +#' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram. +#' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided. +#' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`, +#' and `max`. +#' Defaults to `c(30L, 1L, 100L)`. +#' +#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")` +#' +#' @inherit shared_params return +#' +#' @section Decorating Module: +#' +#' This module generates the following objects, which can be modified in place using decorators:: +#' - `histogram_plot` (`ggplot`) +#' - `qq_plot` (`ggplot`) +#' +#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects. +#' The name of this list corresponds to the name of the output to which the decorator is applied. +#' See code snippet below: +#' +#' ``` +#' tm_g_distribution( +#' ..., # arguments for module +#' decorators = list( +#' histogram_plot = teal_transform_module(...), # applied only to `histogram_plot` output +#' qq_plot = teal_transform_module(...) # applied only to `qq_plot` output +#' ) +#' ) +#' ``` +#' +#' For additional details and examples of decorators, refer to the vignette +#' `vignette("decorate-module-output", package = "teal.modules.general")`. +#' +#' To learn more please refer to the vignette +#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation. +#' +#' @inheritSection teal::example_module Reporting +#' +#' @examplesShinylive +#' library(teal.modules.general) +#' interactive <- function() TRUE +#' {{ next_example }} +# nolint start: line_length_linter. +#' @examples +# nolint end: line_length_linter. +#' # general data example +#' data <- teal_data() +#' data <- within(data, { +#' iris <- iris +#' }) +#' +#' app <- init( +#' data = data, +#' modules = list( +#' tm_g_distribution( +#' dist_var = data_extract_spec( +#' dataname = "iris", +#' select = select_spec(variable_choices("iris"), "Petal.Length") +#' ) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @examplesShinylive +#' library(teal.modules.general) +#' interactive <- function() TRUE +#' {{ next_example }} +# nolint start: line_length_linter. +#' @examples +# nolint end: line_length_linter. +#' # CDISC data example +#' data <- teal_data() +#' data <- within(data, { +#' ADSL <- teal.data::rADSL +#' }) +#' join_keys(data) <- default_cdisc_join_keys[names(data)] +#' +#' vars1 <- choices_selected( +#' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), +#' selected = NULL +#' ) +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_g_distribution( +#' dist_var = data_extract_spec( +#' dataname = "ADSL", +#' select = select_spec( +#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), +#' selected = "BMRKR1", +#' multiple = FALSE, +#' fixed = FALSE +#' ) +#' ), +#' strata_var = data_extract_spec( +#' dataname = "ADSL", +#' filter = filter_spec( +#' vars = vars1, +#' multiple = TRUE +#' ) +#' ), +#' group_var = data_extract_spec( +#' dataname = "ADSL", +#' filter = filter_spec( +#' vars = vars1, +#' multiple = TRUE +#' ) +#' ) +#' ) +#' ) +#' ) +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' @export +#' +tm_g_distribution.default <- function(label = "Distribution Module", + dist_var, + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_distribution") + + # Normalize the parameters + if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) + if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) + if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_list(dist_var, "data_extract_spec") + checkmate::assert_false(dist_var[[1L]]$select$multiple) + + checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_flag(freq) + ggtheme <- match.arg(ggtheme) + + plot_choices <- c("Histogram", "QQplot") + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + if (length(bins) == 1) { + checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) + } else { + checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) + checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") + } + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, names = c("histogram_plot", "qq_plot")) + + # End of assertions + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list( + dist_var = dist_var, + strata_var = strata_var, + group_var = group_var + ) + + ans <- module( + label = label, + ui = ui_g_distribution.default, + server = srv_g_distribution.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the distribution module +ui_g_distribution.default <- function(id, ...) { + args <- list(...) + ns <- NS(id) + is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tabsetPanel( + id = ns("tabs"), + tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))), + tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot"))) + ), + tags$h3("Statistics Table"), + DT::dataTableOutput(ns("summary_table")), + tags$h3("Tests"), + conditionalPanel( + sprintf("input['%s'].length === 0", ns("dist_tests")), + div( + id = ns("please_select_a_test"), + "Please select a test" + ) + ), + conditionalPanel( + sprintf("input['%s'].length > 0", ns("dist_tests")), + DT::dataTableOutput(ns("t_stats")) + ) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("dist_var", "strata_var")]), + teal.transform::data_extract_ui( + id = ns("dist_i"), + label = "Variable", + data_extract_spec = args$dist_var, + is_single_dataset = is_single_dataset_value + ), + if (!is.null(args$group_var)) { + tagList( + teal.transform::data_extract_ui( + id = ns("group_i"), + label = "Group by", + data_extract_spec = args$group_var, + is_single_dataset = is_single_dataset_value + ), + uiOutput(ns("scales_types_ui")) + ) + }, + if (!is.null(args$strata_var)) { + teal.transform::data_extract_ui( + id = ns("strata_i"), + label = "Stratify by", + data_extract_spec = args$strata_var, + is_single_dataset = is_single_dataset_value + ) + }, + bslib::accordion( + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), + bslib::accordion_panel( + "Histogram", + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1), + shinyWidgets::prettyRadioButtons( + ns("main_type"), + label = "Plot Type:", + choices = c("Density", "Frequency"), + selected = if (!args$freq) "Density" else "Frequency", + bigger = FALSE, + inline = TRUE + ), + checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), + ui_decorate_teal_data( + ns("d_density"), + decorators = select_decorators(args$decorators, "histogram_plot") + ) + ) + ), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), + bslib::accordion_panel( + "QQ Plot", + checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), + ui_decorate_teal_data( + ns("d_qq"), + decorators = select_decorators(args$decorators, "qq_plot") + ), + collapsed = FALSE + ) + ), + conditionalPanel( + condition = paste0("input['", ns("main_type"), "'] == 'Density'"), + bslib::accordion_panel( + "Theoretical Distribution", + teal.widgets::optionalSelectInput( + ns("t_dist"), + tags$div( + tagList( + "Distribution:", + bslib::tooltip( + icon("circle-info"), + tags$span( + "Default parameters are optimized with MASS::fitdistr function." + ) + ) + ) + ), + choices = c("normal", "lognormal", "gamma", "unif"), + selected = NULL, + multiple = FALSE + ), + numericInput(ns("dist_param1"), label = "param1", value = NULL), + numericInput(ns("dist_param2"), label = "param2", value = NULL), + tags$span(actionButton(ns("params_reset"), "Default params")), + collapsed = FALSE + ) + ), + bslib::accordion_panel( + title = "Tests", + teal.widgets::optionalSelectInput( + ns("dist_tests"), + "Tests:", + choices = c( + "Shapiro-Wilk", + if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", + if (!is.null(args$strata_var)) "one-way ANOVA", + if (!is.null(args$strata_var)) "Fligner-Killeen", + if (!is.null(args$strata_var)) "F-test", + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)", + if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" + ), + selected = NULL + ) + ), + bslib::accordion_panel( + title = "Statistics Table", + sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2) + ), + bslib::accordion_panel( + title = "Plot settings", + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the distribution module +srv_g_distribution.default <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + setBookmarkExclude("params_reset") + + ns <- session$ns + + rule_req <- function(value) { + if (isTRUE(input$dist_tests %in% c( + "Fligner-Killeen", + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)", + "one-way ANOVA" + ))) { + if (!shinyvalidate::input_provided(value)) { + "Please select stratify variable." + } + } + } + rule_dupl <- function(...) { + if (identical(input$dist_tests, "Fligner-Killeen")) { + strata <- selector_list()$strata_i()$select + group <- selector_list()$group_i()$select + if (isTRUE(strata == group)) { + "Please select different variables for strata and group." + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list( + dist_i = dist_var, + strata_i = strata_var, + group_i = group_var + ), + data, + select_validation_rule = list( + dist_i = shinyvalidate::sv_required("Please select a variable") + ), + filter_validation_rule = list( + strata_i = shinyvalidate::compose_rules( + rule_req, + rule_dupl + ), + group_i = rule_dupl + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") + }) + + iv_r_dist <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators( + iv, selector_list, + validator_names = c("strata_i", "group_i") + ) + }) + rule_dist_1 <- function(value) { + if (!is.null(input$t_dist)) { + switch(input$t_dist, + "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", + "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", + "gamma" = { + if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" + }, + "unif" = NULL + ) + } + } + rule_dist_2 <- function(value) { + if (!is.null(input$t_dist)) { + switch(input$t_dist, + "normal" = { + if (!shinyvalidate::input_provided(value)) { + "sd is required" + } else if (value < 0) { + "sd must be non-negative" + } + }, + "lognormal" = { + if (!shinyvalidate::input_provided(value)) { + "sdlog is required" + } else if (value < 0) { + "sdlog must be non-negative" + } + }, + "gamma" = { + if (!shinyvalidate::input_provided(value)) { + "rate is required" + } else if (value <= 0) { + "rate must be positive" + } + }, + "unif" = NULL + ) + } + } + + rule_dist <- function(value) { + if (isTRUE(input$tabs == "QQplot") || + isTRUE(input$dist_tests %in% c( + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)" + ))) { + if (!shinyvalidate::input_provided(value)) { + "Please select the theoretical distribution." + } + } + } + + iv_dist <- shinyvalidate::InputValidator$new() + iv_dist$add_rule("t_dist", rule_dist) + iv_dist$add_rule("dist_param1", rule_dist_1) + iv_dist$add_rule("dist_param2", rule_dist_2) + iv_dist$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + + qenv <- reactive( + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + ) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + output$scales_types_ui <- renderUI({ + if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) { + shinyWidgets::prettyRadioButtons( + ns("scales_type"), + label = "Scales:", + choices = c("Fixed", "Free"), + selected = "Fixed", + bigger = FALSE, + inline = TRUE + ) + } + }) + + observeEvent( + eventExpr = list( + input$t_dist, + input$params_reset, + selector_list()$dist_i()$select + ), + handlerExpr = { + params <- + if (length(input$t_dist) != 0) { + get_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) + } + + ANL <- merged$anl_q_r()[["ANL"]] + round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) + } else { + c("param1" = NA_real_, "param2" = NA_real_) + } + + params_vals <- unname(params) + map_distr_nams <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) + + if (!is.null(input$t_dist) && input$t_dist %in% names(map_distr_nams)) { + params_names <- map_distr_nams[[input$t_dist]] + } else { + params_names <- names(params) + } + + updateNumericInput( + inputId = "dist_param1", + label = params_names[1], + value = restoreInput(ns("dist_param1"), params_vals[1]) + ) + updateNumericInput( + inputId = "dist_param2", + label = params_names[2], + value = restoreInput(ns("dist_param1"), params_vals[2]) + ) + }, + ignoreInit = TRUE + ) + + observeEvent(input$params_reset, { + updateActionButton(inputId = "params_reset", label = "Reset params") + }) + + merge_vars <- reactive({ + teal::validate_inputs(iv_r()) + + dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) + s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) + g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) + + dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL + s_var_name <- if (length(s_var)) as.name(s_var) else NULL + g_var_name <- if (length(g_var)) as.name(g_var) else NULL + + list( + dist_var = dist_var, + s_var = s_var, + g_var = g_var, + dist_var_name = dist_var_name, + s_var_name = s_var_name, + g_var_name = g_var_name + ) + }) + + # common qenv + common_q <- reactive({ + # Create a private stack for this function only. + + obj <- merged$anl_q_r() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Distribution Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + + ANL <- obj[["ANL"]] + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + + roundn <- input$roundn + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + # isolated as dist_param1/dist_param2 already triggered the reactivity + t_dist <- isolate(input$t_dist) + + qenv <- obj + + if (length(g_var) > 0) { + validate( + need( + inherits(ANL[[g_var]], c("integer", "factor", "character")), + "Group by variable must be `factor`, `character`, or `integer`" + ) + ) + qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), + env = list(g_var = g_var) + ) + ) + } + + if (length(s_var) > 0) { + validate( + need( + inherits(ANL[[s_var]], c("integer", "factor", "character")), + "Stratify by variable must be `factor`, `character`, or `integer`" + ) + ) + + qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), + env = list(s_var = s_var) + ) + ) + } + + validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) + teal::validate_has_data(ANL, 1, complete = TRUE) + + if (length(t_dist) != 0) { + map_distr_nams <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) + params_names_raw <- map_distr_nams[[t_dist]] + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + params <- as.list(c(dist_param1, dist_param2)) + names(params) <- params_names_raw + }, + env = list( + dist_param1 = dist_param1, + dist_param2 = dist_param2, + params_names_raw = params_names_raw + ) + ) + ) + } + + if (length(s_var) == 0 && length(g_var) == 0) { + teal.code::eval_code( + qenv, + substitute( + expr = { + summary_table_data <- ANL %>% + dplyr::summarise( + min = round(min(dist_var_name, na.rm = TRUE), roundn), + median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), + mean = round(mean(dist_var_name, na.rm = TRUE), roundn), + max = round(max(dist_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + env = list( + dist_var_name = as.name(dist_var), + roundn = roundn + ) + ) + ) + } else { + teal.code::eval_code( + qenv, + substitute( + expr = { + strata_vars <- strata_vars_raw + summary_table_data <- ANL %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(dist_var_name, na.rm = TRUE), roundn), + median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), + mean = round(mean(dist_var_name, na.rm = TRUE), roundn), + max = round(max(dist_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + env = list( + dist_var_name = dist_var_name, + strata_vars_raw = c(g_var, s_var), + roundn = roundn + ) + ) + ) + } + }) + + # distplot qenv ---- + dist_q <- eventReactive( + eventExpr = { + common_q() + input$scales_type + input$main_type + input$bins + input$add_dens + is.null(input$ggtheme) + }, + valueExpr = { + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + t_dist <- input$t_dist + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + + scales_type <- input$scales_type + + ndensity <- 512 + main_type_var <- input$main_type + bins_var <- input$bins + add_dens_var <- input$add_dens + ggtheme <- input$ggtheme + + teal::validate_inputs(iv_dist) + + qenv <- common_q() + + m_type <- if (main_type_var == "Density") "density" else "count" + + plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 + ), + env = list( + m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) + ) + ) + } else if (length(s_var) != 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name, col = s_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), + bins = bins_var, alpha = 0.3 + ), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + s_var = as.name(s_var), + s_var_name = s_var_name + ) + ) + } else if (length(s_var) == 0 && length(g_var) != 0) { + req(scales_type) + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 + ) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + g_var = g_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) + ) + ) + } else { + req(scales_type) + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name, col = s_var_name)) + + ggplot2::geom_histogram( + position = "identity", + ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 + ) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + g_var = g_var, + s_var = as.name(s_var), + g_var_name = g_var_name, + s_var_name = s_var_name, + scales_raw = tolower(scales_type) + ) + ) + } + + if (add_dens_var) { + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_density( + ggplot2::aes(y = ggplot2::after_stat(const * m_type2)), + geom = "line", + position = "identity", + alpha = 0.5, + size = 2, + n = ndensity + ), + env = list( + plot_call = plot_call, + const = if (main_type_var == "Density") { + 1 + } else { + diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var + }, + m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"), + ndensity = ndensity + ) + ) + } + + if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + df_params <- as.data.frame(append(params, list(name = t_dist))), + env = list(t_dist = t_dist) + ) + ) + datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) + label <- quote(tb) + + plot_call <- substitute( + expr = plot_call + ggpp::geom_table_npc( + data = data, + ggplot2::aes(npcx = x, npcy = y, label = label), + hjust = 0, vjust = 1, size = 4 + ), + env = list(plot_call = plot_call, data = datas, label = label) + ) + } + + if ( + length(s_var) == 0 && + length(g_var) == 0 && + main_type_var == "Density" && + length(t_dist) != 0 && + main_type_var == "Density" + ) { + map_dist <- stats::setNames( + c("dnorm", "dlnorm", "dgamma", "dunif"), + c("normal", "lognormal", "gamma", "unif") + ) + plot_call <- substitute( + expr = plot_call + stat_function( + data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), + ggplot2::aes(x, color = color), + fun = mapped_dist_name, + n = ndensity, + size = 2, + args = params + ) + + ggplot2::scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"), + env = list( + plot_call = plot_call, + dist_var = dist_var, + ndensity = ndensity, + mapped_dist = unname(map_dist[t_dist]), + mapped_dist_name = as.name(unname(map_dist[t_dist])) + ) + ) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Histogram"]], + user_default = ggplot2_args$default + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Histogram Plot") + teal.code::eval_code( + qenv, + substitute( + expr = histogram_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + # qqplot qenv ---- + qq_q <- eventReactive( + eventExpr = { + common_q() + input$scales_type + input$qq_line + is.null(input$ggtheme) + input$tabs + }, + valueExpr = { + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + + scales_type <- input$scales_type + ggtheme <- input$ggtheme + + teal::validate_inputs(iv_r_dist(), iv_dist) + t_dist <- req(input$t_dist) # Not validated when tab is not selected + qenv <- common_q() + + plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var)), + env = list(dist_var = dist_var) + ) + } else if (length(s_var) != 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var, color = s_var)), + env = list(dist_var = dist_var, s_var = s_var) + ) + } else if (length(s_var) == 0 && length(g_var) != 0) { + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var)) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + dist_var = dist_var, + g_var = g_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) + ) + ) + } else { + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var, color = s_var)) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + dist_var = dist_var, + g_var = g_var, + s_var = s_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) + ) + ) + } + + map_dist <- stats::setNames( + c("qnorm", "qlnorm", "qgamma", "qunif"), + c("normal", "lognormal", "gamma", "unif") + ) + + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_qq(distribution = mapped_dist, dparams = params), + env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) + ) + + if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + df_params <- as.data.frame(append(params, list(name = t_dist))), + env = list(t_dist = t_dist) + ) + ) + datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) + label <- quote(tb) + + plot_call <- substitute( + expr = plot_call + + ggpp::geom_table_npc( + data = data, + ggplot2::aes(npcx = x, npcy = y, label = label), + hjust = 0, + vjust = 1, + size = 4 + ), + env = list( + plot_call = plot_call, + data = datas, + label = label + ) + ) + } + + if (isTRUE(input$qq_line)) { + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_qq_line(distribution = mapped_dist, dparams = params), + env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) + ) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["QQplot"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## QQ Plot") + teal.code::eval_code( + qenv, + substitute( + expr = qq_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + # test qenv ---- + test_q <- eventReactive( + ignoreNULL = FALSE, + eventExpr = { + common_q() + input$dist_param1 + input$dist_param2 + input$dist_tests + }, + valueExpr = { + # Create a private stack for this function only. + ANL <- common_q()[["ANL"]] + + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + dist_tests <- input$dist_tests + t_dist <- input$t_dist + + req(dist_tests) + + teal::validate_inputs(iv_dist) + + if (length(s_var) > 0 || length(g_var) > 0) { + counts <- ANL %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% + dplyr::summarise(n = dplyr::n()) + + validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) + } + + + if (dist_tests %in% c( + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)" + )) { + if (length(g_var) == 0 && length(s_var) > 0) { + validate(need( + length(unique(ANL[[s_var]])) == 2, + "Please select stratify variable with 2 levels." + )) + } + if (length(g_var) > 0 && length(s_var) > 0) { + validate(need( + all(stats::na.omit(as.vector( + tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 + ))), + "Please select stratify variable with 2 levels, per each group." + )) + } + } + + map_dist <- stats::setNames( + c("pnorm", "plnorm", "pgamma", "punif"), + c("normal", "lognormal", "gamma", "unif") + ) + sks_args <- list( + test = quote(stats::ks.test), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + groups = c(g_var, s_var) + ) + ssw_args <- list( + test = quote(stats::shapiro.test), + args = bquote(list(.[[.(dist_var)]])), + groups = c(g_var, s_var) + ) + mfil_args <- list( + test = quote(stats::fligner.test), + args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), + groups = c(g_var) + ) + sad_args <- list( + test = quote(goftest::ad.test), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + groups = c(g_var, s_var) + ) + scvm_args <- list( + test = quote(goftest::cvm.test), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), + groups = c(g_var, s_var) + ) + manov_args <- list( + test = quote(stats::aov), + args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), + groups = c(g_var) + ) + mt_args <- list( + test = quote(stats::t.test), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mv_args <- list( + test = quote(stats::var.test), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mks_args <- list( + test = quote(stats::ks.test), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + + tests_base <- switch(dist_tests, + "Kolmogorov-Smirnov (one-sample)" = sks_args, + "Shapiro-Wilk" = ssw_args, + "Fligner-Killeen" = mfil_args, + "one-way ANOVA" = manov_args, + "t-test (two-samples, not paired)" = mt_args, + "F-test" = mv_args, + "Kolmogorov-Smirnov (two-samples)" = mks_args, + "Anderson-Darling (one-sample)" = sad_args, + "Cramer-von Mises (one-sample)" = scvm_args + ) + + env <- list( + t_test = t_dist, + dist_var = dist_var, + g_var = g_var, + s_var = s_var, + args = tests_base$args, + groups = tests_base$groups, + test = tests_base$test, + dist_var_name = dist_var_name, + g_var_name = g_var_name, + s_var_name = s_var_name + ) + + qenv <- common_q() + + if (length(s_var) == 0 && length(g_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("generics")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + test_table_data <- ANL %>% + dplyr::select(dist_var) %>% + with(., generics::glance(do.call(test, args))) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } else { + qenv <- teal.code::eval_code(qenv, 'library("tidyr")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + test_table_data <- ANL %>% + dplyr::select(dist_var, s_var, g_var) %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% + dplyr::do(tests = generics::glance(do.call(test, args))) %>% + tidyr::unnest(tests) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } + } + ) + + # outputs ---- + output_dist_q <- reactive(c(common_q(), req(dist_q()))) + output_qq_q <- reactive(c(common_q(), req(qq_q()))) + + # Summary table listing has to be created separately to allow for qenv join + q_common <- common_q() + teal.reporter::teal_card(q_common) <- c( + teal.reporter::teal_card(q_common), + "## Statistics table" + ) + output_summary_q <- reactive({ + if (iv_r()$is_valid()) { + within(q_common, { + summary_table <- rtables::df_to_tt(summary_table_data) + }) + } else { + within( + q_common, + summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) + ) + } + }) + + output_test_q <- reactive({ + # wrapped in if since could lead into validate error - we do want to continue + test_q_out <- try(test_q(), silent = TRUE) + q_common <- common_q() + teal.reporter::teal_card(q_common) <- c( + teal.reporter::teal_card(q_common), + "## Distribution Tests table" + ) + if (inherits(test_q_out, c("try-error", "error"))) { + within( + q_common, + test_table <- rtables::rtable(header = rtables::rheader("No data available in table"), rtables::rrow()) + ) + } else { + within(c(q_common, test_q_out), { + test_table <- rtables::df_to_tt(test_table_data) + }) + } + }) + + decorated_output_dist_q <- srv_decorate_teal_data( + "d_density", + data = output_dist_q, + decorators = select_decorators(decorators, "histogram_plot"), + expr = quote(histogram_plot) + ) + + decorated_output_qq_q <- srv_decorate_teal_data( + "d_qq", + data = output_qq_q, + decorators = select_decorators(decorators, "qq_plot"), + expr = quote(qq_plot) + ) + + decorated_output_summary_q <- srv_decorate_teal_data( + "d_summary", + data = output_summary_q, + decorators = select_decorators(decorators, "summary_table"), + expr = quote(summary_table) + ) + + decorated_output_test_q <- srv_decorate_teal_data( + "d_test", + data = output_test_q, + decorators = select_decorators(decorators, "test_table"), + expr = quote(test_table) + ) + + dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]]) + qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]]) + + summary_r <- reactive({ + q <- req(output_summary_q()) + + DT::datatable( + q[["summary_table_data"]], + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) + }) + + output$summary_table <- DT::renderDataTable(summary_r()) + + tests_r <- reactive({ + q <- req(output_test_q()) + DT::datatable(q[["test_table_data"]]) + }) + + pws1 <- teal.widgets::plot_with_settings_srv( + id = "hist_plot", + plot_r = dist_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + pws2 <- teal.widgets::plot_with_settings_srv( + id = "qq_plot", + plot_r = qq_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + decorated_output_dist_dims_q <- set_chunk_dims(pws1, decorated_output_dist_q) + + decorated_output_qq_dims_q <- set_chunk_dims(pws2, decorated_output_qq_q) + + decorated_output_q <- reactive({ + tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement + test_q_out <- output_test_q() + + out_q <- switch(tab, + Histogram = decorated_output_dist_dims_q(), + QQplot = decorated_output_qq_dims_q() + ) + withCallingHandlers( + c(out_q, output_summary_q(), test_q_out), + warning = function(w) { + if (grepl("Restoring original content and adding only", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + } + ) + }) + + output$t_stats <- DT::renderDataTable(tests_r()) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "R Code for distribution" + ) + decorated_output_q + }) +} diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd index 988dc6eec..d1dcbc08a 100644 --- a/man/srv_decorate_teal_data.Rd +++ b/man/srv_decorate_teal_data.Rd @@ -10,11 +10,6 @@ srv_decorate_teal_data(id, data, decorators, expr) ui_decorate_teal_data(id, decorators, ...) } \arguments{ -\item{id}{(\code{character(1)}) \code{shiny} module instance id.} - -\item{data}{(\code{teal_data}, \code{teal_data_module}, or \code{reactive} returning \code{teal_data}) -The data which application will depend on.} - \item{expr}{(\code{reactive}) with expression to evaluate on the output of the decoration. It must be compatible with \code{code} argument of \code{\link[teal.code:eval_code]{teal.code::eval_code()}}. Default is \code{NULL} which won't evaluate any appending code.} diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 5d8440667..f42bc5e29 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -6,7 +6,8 @@ \usage{ tm_a_pca( label = "Principal Component Analysis", - dat, + dat = picks(datasets(), variables(choices = tidyselect::where(is.numeric), selected = + 1:5, multiple = TRUE)), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -22,9 +23,6 @@ tm_a_pca( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{dat}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) specifying columns used to compute PCA.} @@ -73,9 +71,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index d401eb46a..65a841226 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -6,8 +6,9 @@ \usage{ tm_a_regression( label = "Regression Analysis", - regressor, - response, + regressor = picks(datasets(), variables(choices = tidyselect::where(is.numeric), + selected = -1, multiple = TRUE)), + response = picks(datasets(), variables(choices = tidyselect::where(is.numeric))), plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -24,9 +25,6 @@ tm_a_regression( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{regressor}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Regressor variables from an incoming dataset with filtering and selecting.} @@ -97,9 +95,6 @@ It takes the form of \code{c(value, min, max)} and it is passed to the \code{val argument in \code{teal.widgets::optionalSliderInputValMinMax}. }} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index e5084fbf8..629bc71bd 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -19,9 +19,6 @@ tm_data_table( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{variables_selected}{(\verb{named list}) Character vectors of the variables (i.e. columns) which should be initially shown for each dataset. Names of list elements should correspond to the names of the datasets available in the app. @@ -31,15 +28,6 @@ dataset will initially be shown.} \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A vector of datasets which should be shown and in what order. Use \code{datanames} instead.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{dt_args}{(\verb{named list}) Additional arguments to be passed to \code{\link[DT:datatable]{DT::datatable()}} (must not include \code{data} or \code{options}).} @@ -55,9 +43,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index a1617b9db..839a410d5 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -10,9 +10,6 @@ tm_file_viewer( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{input_path}{(\code{list}) of the input paths, optional. Each element can be: Paths can be specified as absolute paths or relative to the running directory of the application. diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 36a288b5a..60556c83a 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -16,9 +16,6 @@ tm_front_page( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{header_text}{(\code{character} vector) text to be shown at the top of the module, for each element, if named the name is shown first in bold as a header followed by the value. The first element's header is displayed larger than the others.} @@ -35,18 +32,6 @@ element, if named the name is shown first in bold, followed by the value.} \item{show_metadata}{(\code{logical}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} indicating whether the metadata of the datasets be available on the module. Metadata shown automatically when \code{datanames} set.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index f0f38e9e4..542e145e8 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -7,10 +7,10 @@ tm_g_association( label = "Association", ref = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1)), + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1), values()), vars = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = - TRUE)), + TRUE), values()), show_association = TRUE, plot_height = c(600, 400, 5000), plot_width = NULL, @@ -26,9 +26,6 @@ tm_g_association( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{ref}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Reference variable, must accepts a \code{data_extract_spec} with \code{select_spec(multiple = FALSE)} to ensure single selection option.} @@ -61,9 +58,6 @@ List names should match the following: \code{c("default", "Bivariate1", "Bivaria For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 51dced013..460c3628b 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -33,9 +33,6 @@ tm_g_bivariate( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Variable names selected to plot along the x-axis by default. Can be numeric, factor or character. @@ -105,9 +102,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index e9d356930..9d802d151 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -22,9 +22,6 @@ tm_g_distribution( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Variable(s) for which the distribution will be analyzed.} @@ -65,9 +62,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_distribution.default.Rd b/man/tm_g_distribution.default.Rd new file mode 100644 index 000000000..b1f19ac40 --- /dev/null +++ b/man/tm_g_distribution.default.Rd @@ -0,0 +1,190 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_g_distribution_old.R +\name{tm_g_distribution.default} +\alias{tm_g_distribution.default} +\title{\code{teal} module: Distribution analysis} +\usage{ +\method{tm_g_distribution}{default}( + label = "Distribution Module", + dist_var, + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list() +) +} +\arguments{ +\item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +Variable(s) for which the distribution will be analyzed.} + +\item{strata_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +Categorical variable used to split the distribution analysis.} + +\item{group_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +Variable used for faceting plot into multiple panels.} + +\item{freq}{(\code{logical}) optional, whether to display frequency (\code{TRUE}) or density (\code{FALSE}). +Defaults to density (\code{FALSE}).} + +\item{ggtheme}{(\code{character}) optional, \code{ggplot2} theme to be used by default. Defaults to \code{"gray"}.} + +\item{ggplot2_args}{(\code{ggplot2_args}) optional, object created by \code{\link[teal.widgets:ggplot2_args]{teal.widgets::ggplot2_args()}} with settings for all the plots or named list of \code{ggplot2_args} objects for plot-specific settings. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. + +List names should match the following: \code{c("default", "Histogram", "QQplot")}. + +For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} + +\item{bins}{(\code{integer(1)} or \code{integer(3)}) optional, specifies the number of bins for the histogram. +\itemize{ +\item When the length of \code{bins} is one: The histogram bins will have a fixed size based on the \code{bins} provided. +\item When the length of \code{bins} is three: The histogram bins are dynamically adjusted based on vector of \code{value}, \code{min}, +and \code{max}. +Defaults to \code{c(30L, 1L, 100L)}. +}} + +\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of +\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} + +\item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of +\code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} + +\item{pre_output}{(\code{shiny.tag}) optional,\cr +with text placed before the output to put the output into context. For example a title.} + +\item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output +into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} + +\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} +(named \code{list} of lists of \code{teal_transform_module}) optional, +decorator for tables or plots included in the module output reported. +The decorators are applied to the respective output objects.} +} +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} +\description{ +Module is designed to explore the distribution of a single variable within a given dataset. +It offers several tools, such as histograms, Q-Q plots, and various statistical tests to +visually and statistically analyze the variable's distribution. +} +\section{Decorating Module}{ + + +This module generates the following objects, which can be modified in place using decorators:: +\itemize{ +\item \code{histogram_plot} (\code{ggplot}) +\item \code{qq_plot} (\code{ggplot}) +} + +A Decorator is applied to the specific output using a named list of \code{teal_transform_module} objects. +The name of this list corresponds to the name of the output to which the decorator is applied. +See code snippet below: + +\if{html}{\out{
}}\preformatted{tm_g_distribution( + ..., # arguments for module + decorators = list( + histogram_plot = teal_transform_module(...), # applied only to `histogram_plot` output + qq_plot = teal_transform_module(...) # applied only to `qq_plot` output + ) +) +}\if{html}{\out{
}} + +For additional details and examples of decorators, refer to the vignette +\code{vignette("decorate-module-output", package = "teal.modules.general")}. + +To learn more please refer to the vignette +\code{vignette("transform-module-output", package = "teal")} or the \code{\link[teal:teal_transform_module]{teal::teal_transform_module()}} documentation. +} + +\examples{ +# general data example +data <- teal_data() +data <- within(data, { + iris <- iris +}) + +app <- init( + data = data, + modules = list( + tm_g_distribution( + dist_var = data_extract_spec( + dataname = "iris", + select = select_spec(variable_choices("iris"), "Petal.Length") + ) + ) + ) +) +if (interactive()) { + shinyApp(app$ui, app$server) +} + +# CDISC data example +data <- teal_data() +data <- within(data, { + ADSL <- teal.data::rADSL +}) +join_keys(data) <- default_cdisc_join_keys[names(data)] + +vars1 <- choices_selected( + variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), + selected = NULL +) + +app <- init( + data = data, + modules = modules( + tm_g_distribution( + dist_var = data_extract_spec( + dataname = "ADSL", + select = select_spec( + choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), + selected = "BMRKR1", + multiple = FALSE, + fixed = FALSE + ) + ), + strata_var = data_extract_spec( + dataname = "ADSL", + filter = filter_spec( + vars = vars1, + multiple = TRUE + ) + ), + group_var = data_extract_spec( + dataname = "ADSL", + filter = filter_spec( + vars = vars1, + multiple = TRUE + ) + ) + ) + ) +) +if (interactive()) { + shinyApp(app$ui, app$server) +} + +} +\section{Examples in Shinylive}{ +\describe{ + \item{example-1}{ + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDo1CJYdvqpImiqHAEi0dHKdDwFwpg1bU-4yWb0qojgIg0F1B4Puj2e7DONSg9BEiQI+SItAIYj6v0aPzkpR+AAU4EEeAAZCgSAr4w7LNpHBm6NptWgmXTsFTkZiWHQ2WzlIGiQoQVgAQXQ7E6ABJBLRSjLQYwdIw2s0lGBmgBdIA}{Open in Shinylive} + \if{html}{\out{}} + \if{html}{\out{}} + } + \item{example-2}{ + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTcILRZRAEY2ghLxgjE00TgRDTh+dlqujujFoUHoIk2r1o73OuWAwAUYD6zURl0uVQIAKRWAAsoiqoivAB5RwAOQcAE18bpEQFnAANRFyOS4QFfH7kfi6AC8ulJjmaKIgwyUaFQbRUxQBEDqmR5IVyrJluj4QhEonlquEYmldTqpBgaQkGR2pBB9EEmmsgL1IVNaWB8syaWiZvUG1EqDgmJttoV4VOel5iOR+N9tvZ3tI8sjGk+Xp9yr9epebzE8uBoPBcEhadh4XhIaaKLAaIxWPqAHFXHgaWAAEI4rAAaSwDyZLPDftjnPliMbLbbYaTyZV61ocSDugAYvVmnSlaO9SZaFE-vLZ-PXCPbcNk52d7pRG7wg6WE7ci6om6457vbrR5lA32kcXh0uV9RyIx5Z-v-H7y7W1gQ1XkQIeRclzHL8JxEeUHBcIDdD3P0D2TCRGCIQRUDPH9eWdV1mFvBMH2TJ9YCnIt+jwJC-xkX9aC-GQAMTKCgXuDN7ggpC6hgcdJ3gpxtyXFDd19FDhmGWgTF0dgVG-d1tDgGxbBqZVRDKCBWHqdB2DFAASQRaCqAyvkYHRGGGAYlDAAZLiAA}{Open in Shinylive} + \if{html}{\out{}} + \if{html}{\out{}} + } +} +} + diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 44ce0a985..7dd9c93fc 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -25,9 +25,6 @@ tm_g_response( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Which variable to use as the response. You can define one fixed column by setting \code{fixed = TRUE} inside the \code{select_spec}. @@ -83,9 +80,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 383eeae00..868b475d9 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -29,9 +29,6 @@ tm_g_scatterplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies variable names selected to plot along the x-axis by default.} @@ -96,9 +93,6 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index f4b8bfe8c..05628b5a5 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -16,9 +16,6 @@ tm_g_scatterplotmatrix( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{variables}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if plot elements should be @@ -37,9 +34,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index ef6abaf03..7da0234f1 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -21,24 +21,12 @@ tm_missing_data( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} \item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of \code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{parent_dataname}{(\code{character(1)}) Specifies the parent dataset name. Default is \code{ADSL} for \code{CDISC} data. If provided and exists, enables additional analysis "by subject". For non-\code{CDISC} data, this parameter can be ignored.} @@ -58,9 +46,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index f5118a117..c86019d0a 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -19,9 +19,6 @@ tm_outliers( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{outlier_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies variable(s) to be analyzed for outliers.} @@ -49,9 +46,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 1f8cdcce3..740cd0a08 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -20,9 +20,6 @@ tm_p_spiderplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} @@ -49,9 +46,6 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 85f7598fc..0404d54ec 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -21,9 +21,6 @@ tm_p_swimlane( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} \item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index eabdeea88..f33b9a993 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -19,9 +19,6 @@ tm_p_waterfall( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index 7b0c159ab..f506b10b7 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -12,24 +12,12 @@ tm_rmarkdown( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{text}{(\code{character}) arbitrary Rmd code} \item{params}{A list of named parameters that override custom params specified within the YAML front-matter (e.g. specifying a dataset to read or a date range to confine output to). Pass \code{"ask"} to start an application that helps guide parameter configuration.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index 5f2b07110..54ef70ac0 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -19,9 +19,6 @@ tm_t_crosstable( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Object with all available choices with pre-selected option for variable X - row values. In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if table elements should be @@ -57,9 +54,6 @@ The argument is merged with options variable \code{teal.basic_table_args} and de For more details see the vignette: \code{vignette("custom-basic-table-arguments", package = "teal.widgets")}} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd index 6257d9d2f..0db9451c3 100644 --- a/man/tm_t_reactables.Rd +++ b/man/tm_t_reactables.Rd @@ -14,21 +14,6 @@ tm_t_reactables( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 9f439c157..408d6b5ed 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -16,21 +16,9 @@ tm_variable_browser( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} vector of datasets to show, please use the \code{datanames} argument.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{parent_dataname}{(\code{character(1)}) string specifying a parent dataset. If it exists in \code{datanames} then an extra checkbox will be shown to allow users to not show variables in other datasets which exist in this \code{dataname}. @@ -49,9 +37,6 @@ with settings for the module plot. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. From 61b2cfd2eb6bf3cb6913d888e3d8525353d2148e Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 23 Sep 2025 15:51:59 +0200 Subject: [PATCH 136/158] minor --- R/tm_g_association.R | 55 +++++++++++----------- R/tm_g_bivariate.R | 107 ++++++++++++++++++++----------------------- 2 files changed, 78 insertions(+), 84 deletions(-) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 8e20a400f..4b49140bf 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -337,41 +337,44 @@ srv_g_association.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) - iv <- shinyvalidate::InputValidator$new() - iv$add_rule( - "ref-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_required("A reference variable needs to be selected."), - ~ if (any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected)) { - "Associated variables and reference variable cannot overlap" - } + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule( + "ref-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_required("A reference variable needs to be selected."), + ~ if (any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected)) { + "Associated variables and reference variable cannot overlap" + } + ) ) - ) - iv$add_rule( - "vars-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_required("An associated variable needs to be selected."), - ~ if (any(selectors$vars()$variables$selected %in% selectors$ref()$variables$selected)) { - "Associated variables and reference variable cannot overlap" - } + iv$add_rule( + "vars-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_required("An associated variable needs to be selected."), + ~ if (any(selectors$vars()$variables$selected %in% selectors$ref()$variables$selected)) { + "Associated variables and reference variable cannot overlap" + } + ) ) - ) - iv$enable() + iv$enable() + }) + + - qenv <- reactive({ - obj <- data() + anl_merged_q <- reactive({ + teal::validate_inputs(iv_r()) + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Association Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("ggmosaic")') # nolint: quotes - }) - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') # nolint quotes - anl_merged_q <- reactive({ - req(qenv()) - teal.transform::qenv_merge_selectors(x = qenv(), selectors = selectors) + obj |> + teal.code::eval_code('library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') |> # nolint + teal.transform::qenv_merge_selectors(selectors = selectors) }) output_q <- reactive({ diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index e3df2c73d..86fd38009 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -530,64 +530,57 @@ srv_g_bivariate.picks <- function(id, ) iv <- shinyvalidate::InputValidator$new() - iv_r <- reactive({ - # iv$add_rule( - # "x-variables-selected", - # shinyvalidate::compose_rules( - # ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { - # "Please select at least one of x-variable or y-variable" - # } - # ) - # ) - # iv$add_rule( - # "y-variables-selected", - # shinyvalidate::compose_rules( - # ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { - # "Please select at least one of x-variable or y-variable" - # } - # ) - # ) - # if (!is.null(col_facet)) { - # iv$add_rule( - # "row_facet-variables-selected", - # shinyvalidate::compose_rules( - # shinyvalidate::sv_optional(), - # ~ if ( - # !is.null(selectors$row_facet()$variables$selected) && - # identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) - # ) { - # "Row and column facetting variables must be different." - # } - # ) - # ) - # } - - # if (!is.null(row_facet)) { - # iv$add_rule( - # "col_facet-variables-selected", - # shinyvalidate::compose_rules( - # shinyvalidate::sv_optional(), - # ~ if ( - # !is.null(selectors$row_facet()$variables$selected) && - # identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) - # ) { - # "Row and column facetting variables must be different." - # } - # ) - # ) - # } - - iv$enable() - }) - - qenv <- reactive( - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint: quotes. + iv$add_rule( + "x-variables-selected", + shinyvalidate::compose_rules( + ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { + "Please select at least one of x-variable or y-variable" + } + ) + ) + iv$add_rule( + "y-variables-selected", + shinyvalidate::compose_rules( + ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { + "Please select at least one of x-variable or y-variable" + } + ) + ) + iv$add_rule( + "row_facet-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if ( + length(selectors$row_facet()$variables$selected) && + identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) + ) { + "Row and column facetting variables must be different." + } + ) + ) + iv$add_rule( + "col_facet-variables-selected", + shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if ( + length(selectors$col_facet()$variables$selected) && + identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) + ) { + "Row and column facetting variables must be different." + } + ) ) + iv$enable() + anl_merged_q <- reactive({ - isolate(teal::validate_inputs(iv_r())) - req(data()) - obj <- data() + teal::validate_inputs(iv) + # todo: validation mechanism is wrong as $add_rule(inputId, rule) triggers on inputId and rule + # it is problematic when using input->to->reactiveVal as reactiveVal is observed in teal + # and shinyvalidate triggers on inputId. It creates a mismatch between module-reactivity + # and how shinyvalidate detects/throws validation errors + # Quickest solution is to have a shinyvalidate and validate(need()) with the same condition. + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Bivariate Plot"), teal.reporter::teal_card(obj), @@ -664,9 +657,7 @@ srv_g_bivariate.picks <- function(id, ggplot2_args = ggplot2_args ) - facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) - - if (facetting) { + if (!is.null(row_facet_name) || !is.null(col_facet_name)) { facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) if (!is.null(facet_cl)) { From 8764312303165d503ebc3329fcb695a26da991d0 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 23 Sep 2025 16:25:42 +0200 Subject: [PATCH 137/158] link remotes --- DESCRIPTION | 4 ++-- R/tm_g_bivariate.R | 5 ----- man/srv_decorate_teal_data.Rd | 5 +++++ man/tm_a_pca.Rd | 6 ++++++ man/tm_a_regression.Rd | 6 ++++++ man/tm_data_table.Rd | 15 +++++++++++++++ man/tm_file_viewer.Rd | 3 +++ man/tm_front_page.Rd | 15 +++++++++++++++ man/tm_g_association.Rd | 6 ++++++ man/tm_g_bivariate.Rd | 6 ++++++ man/tm_g_distribution.Rd | 6 ++++++ man/tm_g_distribution.default.Rd | 6 ++++++ man/tm_g_response.Rd | 6 ++++++ man/tm_g_scatterplot.Rd | 6 ++++++ man/tm_g_scatterplotmatrix.Rd | 6 ++++++ man/tm_missing_data.Rd | 15 +++++++++++++++ man/tm_outliers.Rd | 6 ++++++ man/tm_p_spiderplot.Rd | 6 ++++++ man/tm_p_swimlane.Rd | 3 +++ man/tm_p_waterfall.Rd | 3 +++ man/tm_rmarkdown.Rd | 12 ++++++++++++ man/tm_t_crosstable.Rd | 6 ++++++ man/tm_t_reactables.Rd | 15 +++++++++++++++ man/tm_variable_browser.Rd | 15 +++++++++++++++ 24 files changed, 175 insertions(+), 7 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 74f186d37..658aaaa70 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -90,8 +90,8 @@ VignetteBuilder: knitr, rmarkdown Remotes: - insightsengineering/teal, - insightsengineering/teal.reporter + insightsengineering/teal@redesign_extraction@main, + insightsengineering/teal.transform@redesign_extraction@main Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 86fd38009..12d494598 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -270,11 +270,6 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", transformators = list(), decorators = list()) { message("Initializing tm_g_bivariate") - extracted_filters <- extract_filters(list(x, y, row_facet, col_facet, color, fill, size)) - transformators <- c( - transformators, - lapply(extracted_filters, teal.transform:::teal_transform_filter) - ) x <- des_to_picks(x) y <- des_to_picks(y) row_facet <- des_to_picks(row_facet) diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd index d1dcbc08a..988dc6eec 100644 --- a/man/srv_decorate_teal_data.Rd +++ b/man/srv_decorate_teal_data.Rd @@ -10,6 +10,11 @@ srv_decorate_teal_data(id, data, decorators, expr) ui_decorate_teal_data(id, decorators, ...) } \arguments{ +\item{id}{(\code{character(1)}) \code{shiny} module instance id.} + +\item{data}{(\code{teal_data}, \code{teal_data_module}, or \code{reactive} returning \code{teal_data}) +The data which application will depend on.} + \item{expr}{(\code{reactive}) with expression to evaluate on the output of the decoration. It must be compatible with \code{code} argument of \code{\link[teal.code:eval_code]{teal.code::eval_code()}}. Default is \code{NULL} which won't evaluate any appending code.} diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index f42bc5e29..f980a4d62 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -23,6 +23,9 @@ tm_a_pca( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{dat}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) specifying columns used to compute PCA.} @@ -71,6 +74,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 65a841226..094febdb4 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -25,6 +25,9 @@ tm_a_regression( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{regressor}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Regressor variables from an incoming dataset with filtering and selecting.} @@ -95,6 +98,9 @@ It takes the form of \code{c(value, min, max)} and it is passed to the \code{val argument in \code{teal.widgets::optionalSliderInputValMinMax}. }} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index 629bc71bd..e5084fbf8 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -19,6 +19,9 @@ tm_data_table( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{variables_selected}{(\verb{named list}) Character vectors of the variables (i.e. columns) which should be initially shown for each dataset. Names of list elements should correspond to the names of the datasets available in the app. @@ -28,6 +31,15 @@ dataset will initially be shown.} \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A vector of datasets which should be shown and in what order. Use \code{datanames} instead.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{dt_args}{(\verb{named list}) Additional arguments to be passed to \code{\link[DT:datatable]{DT::datatable()}} (must not include \code{data} or \code{options}).} @@ -43,6 +55,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index 839a410d5..a1617b9db 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -10,6 +10,9 @@ tm_file_viewer( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{input_path}{(\code{list}) of the input paths, optional. Each element can be: Paths can be specified as absolute paths or relative to the running directory of the application. diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 60556c83a..36a288b5a 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -16,6 +16,9 @@ tm_front_page( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{header_text}{(\code{character} vector) text to be shown at the top of the module, for each element, if named the name is shown first in bold as a header followed by the value. The first element's header is displayed larger than the others.} @@ -32,6 +35,18 @@ element, if named the name is shown first in bold, followed by the value.} \item{show_metadata}{(\code{logical}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} indicating whether the metadata of the datasets be available on the module. Metadata shown automatically when \code{datanames} set.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 542e145e8..db4af75df 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -26,6 +26,9 @@ tm_g_association( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{ref}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Reference variable, must accepts a \code{data_extract_spec} with \code{select_spec(multiple = FALSE)} to ensure single selection option.} @@ -58,6 +61,9 @@ List names should match the following: \code{c("default", "Bivariate1", "Bivaria For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 460c3628b..51dced013 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -33,6 +33,9 @@ tm_g_bivariate( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Variable names selected to plot along the x-axis by default. Can be numeric, factor or character. @@ -102,6 +105,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 9d802d151..e9d356930 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -22,6 +22,9 @@ tm_g_distribution( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Variable(s) for which the distribution will be analyzed.} @@ -62,6 +65,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_distribution.default.Rd b/man/tm_g_distribution.default.Rd index b1f19ac40..bcb3c55cc 100644 --- a/man/tm_g_distribution.default.Rd +++ b/man/tm_g_distribution.default.Rd @@ -22,6 +22,9 @@ ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Variable(s) for which the distribution will be analyzed.} @@ -62,6 +65,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 7dd9c93fc..44ce0a985 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -25,6 +25,9 @@ tm_g_response( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Which variable to use as the response. You can define one fixed column by setting \code{fixed = TRUE} inside the \code{select_spec}. @@ -80,6 +83,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 868b475d9..383eeae00 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -29,6 +29,9 @@ tm_g_scatterplot( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies variable names selected to plot along the x-axis by default.} @@ -93,6 +96,9 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index 05628b5a5..f4b8bfe8c 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -16,6 +16,9 @@ tm_g_scatterplotmatrix( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{variables}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if plot elements should be @@ -34,6 +37,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index 7da0234f1..ef6abaf03 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -21,12 +21,24 @@ tm_missing_data( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} \item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of \code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{parent_dataname}{(\code{character(1)}) Specifies the parent dataset name. Default is \code{ADSL} for \code{CDISC} data. If provided and exists, enables additional analysis "by subject". For non-\code{CDISC} data, this parameter can be ignored.} @@ -46,6 +58,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index c86019d0a..f5118a117 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -19,6 +19,9 @@ tm_outliers( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{outlier_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies variable(s) to be analyzed for outliers.} @@ -46,6 +49,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 740cd0a08..1f8cdcce3 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -20,6 +20,9 @@ tm_p_spiderplot( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} @@ -46,6 +49,9 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 0404d54ec..85f7598fc 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -21,6 +21,9 @@ tm_p_swimlane( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} \item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index f33b9a993..eabdeea88 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -19,6 +19,9 @@ tm_p_waterfall( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index f506b10b7..7b0c159ab 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -12,12 +12,24 @@ tm_rmarkdown( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{text}{(\code{character}) arbitrary Rmd code} \item{params}{A list of named parameters that override custom params specified within the YAML front-matter (e.g. specifying a dataset to read or a date range to confine output to). Pass \code{"ask"} to start an application that helps guide parameter configuration.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index 54ef70ac0..5f2b07110 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -19,6 +19,9 @@ tm_t_crosstable( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Object with all available choices with pre-selected option for variable X - row values. In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if table elements should be @@ -54,6 +57,9 @@ The argument is merged with options variable \code{teal.basic_table_args} and de For more details see the vignette: \code{vignette("custom-basic-table-arguments", package = "teal.widgets")}} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd index 0db9451c3..6257d9d2f 100644 --- a/man/tm_t_reactables.Rd +++ b/man/tm_t_reactables.Rd @@ -14,6 +14,21 @@ tm_t_reactables( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 408d6b5ed..9f439c157 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -16,9 +16,21 @@ tm_variable_browser( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} vector of datasets to show, please use the \code{datanames} argument.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{parent_dataname}{(\code{character(1)}) string specifying a parent dataset. If it exists in \code{datanames} then an extra checkbox will be shown to allow users to not show variables in other datasets which exist in this \code{dataname}. @@ -37,6 +49,9 @@ with settings for the module plot. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. From 52a492b2c8591437e2d200de381755f9fa6faefd Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 13:59:17 +0200 Subject: [PATCH 138/158] validate_input --- R/tm_a_regression.R | 59 ++++++++++++++++++++------------------ R/tm_g_association.R | 44 +++++++++++------------------ R/tm_g_bivariate.R | 66 ++++++++----------------------------------- R/zzz.R | 3 ++ man/validate_input.Rd | 7 ++++- 5 files changed, 67 insertions(+), 112 deletions(-) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 07cd6d8cd..469ed3258 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -431,18 +431,24 @@ srv_a_regression.picks <- function(id, data = data ) - - rule_selectors <- function(value) { - condition <- setequal(selectors$response()$variables$selected, selectors$regressor()$variables$selected) - if (condition) "Response and Regressor must be different." - } - iv_selector <- shinyvalidate::InputValidator$new() - iv_selector$add_rule("response", rule_selectors) - iv_selector$add_rule("regressor", rule_selectors) - anl_merged_q <- reactive({ obj <- data() - teal::validate_inputs(iv_selector) + validate_input( + inputId = "response-variables-selected", + condition = !is.null(selectors$response()$variables$selected), + message = "A regressor variable needs to be selected." + ) + validate_input( + inputId = "regressor-variables-selected", + condition = !is.null(selectors$regressor()$variables$selected), + message = "A response variables need to be selected." + ) + validate_input( + inputId = c("ref-variables-selected", "vars-variables-selected"), + condition = !any(selectors$regressor()$variables$selected %in% selectors$response()$variables$selected), + message = "Response and Regressor must be different." + ) + teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Linear Regression Plot"), @@ -534,12 +540,14 @@ srv_a_regression.picks <- function(id, }) - iv_label <- shinyvalidate::InputValidator$new() - iv_label$condition(~ isTRUE(input$show_outlier)) - iv_label$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) - iv_label$enable() + label_col <- reactive({ - teal::validate_inputs(iv_label) + validate_input( + inputId = c("show_outlier", "label_var"), + condition = isTRUE(input$show_outlier) && length(input$label_var), + message = "Please provide an `Outlier label` variable" + ) + substitute( expr = dplyr::if_else( data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), @@ -591,18 +599,17 @@ srv_a_regression.picks <- function(id, ) }) - - output_0_rule <- function(value) { - if (isTRUE(input$plot_type == "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1) { - "This plot can only have one regressor." - } - } - iv_output_0 <- shinyvalidate::InputValidator$new() - iv_output_0$add_rule("plot_type", output_0_rule) - iv_output_0$enable() output_plot_0 <- reactive({ fit <- fit_r()[["fit"]] anl <- anl_merged_q()[["anl"]] + validate_input( + inputId = c("plot_type", "regressor-variables-selected"), + condition = !( + identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 + ), + message = "This plot works only with single Regressor variable" + ) + validate(need(ncol(fit$model) == 2, "This plot can only have one regressor.")) if (!is.factor(anl[[regression_var()$regressor]])) { @@ -984,8 +991,6 @@ srv_a_regression.picks <- function(id, }) output_q <- reactive({ - # teal::validate_inputs(iv_r()) - switch(input$plot_type, "Response vs Regressor" = req(output_plot_0()), "Residuals vs Fitted" = req(output_plot_1()), @@ -1024,8 +1029,6 @@ srv_a_regression.picks <- function(id, decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) output$text <- renderText({ - # req(iv_r()$is_valid()) - # req(iv_out$is_valid()) paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") }) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 4b49140bf..ea61acc65 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -195,8 +195,7 @@ tm_g_association.picks <- function(label = "Association", teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = TRUE - ), - values() + ) ), show_association = TRUE, plot_height = c(600, 400, 5000), @@ -338,34 +337,23 @@ srv_g_association.picks <- function(id, selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule( - "ref-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_required("A reference variable needs to be selected."), - ~ if (any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected)) { - "Associated variables and reference variable cannot overlap" - } - ) - ) - iv$add_rule( - "vars-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_required("An associated variable needs to be selected."), - ~ if (any(selectors$vars()$variables$selected %in% selectors$ref()$variables$selected)) { - "Associated variables and reference variable cannot overlap" - } - ) - ) - iv$enable() - }) - - - anl_merged_q <- reactive({ - teal::validate_inputs(iv_r()) obj <- req(data()) + validate_input( + inputId = "ref-variables-selected", + condition = !is.null(selectors$ref()$variables$selected), + message = "A reference variable needs to be selected." + ) + validate_input( + inputId = "vars-variables-selected", + condition = !is.null(selectors$vars()$variables$selected), + message = "A associated variables need to be selected." + ) + validate_input( + inputId = c("ref-variables-selected", "vars-variables-selected"), + condition = !any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected), + message = "Associated variables and reference variable cannot overlap" + ) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Association Plot"), diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 12d494598..895efc7d4 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -270,13 +270,6 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", transformators = list(), decorators = list()) { message("Initializing tm_g_bivariate") - x <- des_to_picks(x) - y <- des_to_picks(y) - row_facet <- des_to_picks(row_facet) - col_facet <- des_to_picks(col_facet) - color <- des_to_picks(color) - fill <- des_to_picks(fill) - size <- des_to_picks(size) # Start of assertions checkmate::assert_class(x, "picks") @@ -524,57 +517,20 @@ srv_g_bivariate.picks <- function(id, data = data ) - iv <- shinyvalidate::InputValidator$new() - iv$add_rule( - "x-variables-selected", - shinyvalidate::compose_rules( - ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { - "Please select at least one of x-variable or y-variable" - } - ) - ) - iv$add_rule( - "y-variables-selected", - shinyvalidate::compose_rules( - ~ if (!length(selectors$x()$variables$selected) && !length(selectors$y()$variables$selected)) { - "Please select at least one of x-variable or y-variable" - } - ) - ) - iv$add_rule( - "row_facet-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if ( - length(selectors$row_facet()$variables$selected) && - identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) - ) { - "Row and column facetting variables must be different." - } + anl_merged_q <- reactive({ + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), + message = "Please select at least one of x-variable or y-variable" ) - ) - iv$add_rule( - "col_facet-variables-selected", - shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if ( + + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = length(selectors$row_facet()$variables$selected) && length(selectors$col_facet()$variables$selected) && - identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected) - ) { - "Row and column facetting variables must be different." - } + !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), + message = "Row and column facetting variables must be different." ) - ) - - iv$enable() - - anl_merged_q <- reactive({ - teal::validate_inputs(iv) - # todo: validation mechanism is wrong as $add_rule(inputId, rule) triggers on inputId and rule - # it is problematic when using input->to->reactiveVal as reactiveVal is observed in teal - # and shinyvalidate triggers on inputId. It creates a mismatch between module-reactivity - # and how shinyvalidate detects/throws validation errors - # Quickest solution is to have a shinyvalidate and validate(need()) with the same condition. obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Bivariate Plot"), diff --git a/R/zzz.R b/R/zzz.R index fcc99baf1..f1d610505 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -9,3 +9,6 @@ ggplot_themes <- c("gray", "bw", "linedraw", "light", "dark", "minimal", "classi #' @importFrom lifecycle deprecated #' @importFrom rlang := interactive <- NULL + + +validate_input <- getFromNamespace("validate_input", "teal") diff --git a/man/validate_input.Rd b/man/validate_input.Rd index e9c21581e..dcdd204f6 100644 --- a/man/validate_input.Rd +++ b/man/validate_input.Rd @@ -4,7 +4,12 @@ \alias{validate_input} \title{Validates the variable browser inputs} \usage{ -validate_input(input, plot_var, data) +validate_input( + inputId, + condition = function(x) TRUE, + message = "", + session = shiny::getDefaultReactiveDomain() +) } \arguments{ \item{input}{(\code{session$input}) the \code{shiny} session input} From ccf0d8dddfef687b98e98cc34077471bc16a2e81 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 15:11:15 +0200 Subject: [PATCH 139/158] fix validation when >1 x vars selected and plot Response vs Regressor --- R/tm_a_regression.R | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 469ed3258..a7902c581 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -602,15 +602,6 @@ srv_a_regression.picks <- function(id, output_plot_0 <- reactive({ fit <- fit_r()[["fit"]] anl <- anl_merged_q()[["anl"]] - validate_input( - inputId = c("plot_type", "regressor-variables-selected"), - condition = !( - identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 - ), - message = "This plot works only with single Regressor variable" - ) - - validate(need(ncol(fit$model) == 2, "This plot can only have one regressor.")) if (!is.factor(anl[[regression_var()$regressor]])) { shinyjs::show("size") @@ -991,6 +982,15 @@ srv_a_regression.picks <- function(id, }) output_q <- reactive({ + req(input$plot_type) + validate_input( + inputId = c("plot_type", "regressor-variables-selected"), + condition = !( + identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 + ), + message = "This plot works only with single Regressor variable" + ) + switch(input$plot_type, "Response vs Regressor" = req(output_plot_0()), "Residuals vs Fitted" = req(output_plot_1()), From 6ec2fb78b653bcae759ed7ad7d0af8860bbf0ba6 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 24 Sep 2025 15:45:11 +0200 Subject: [PATCH 140/158] update --- R/tm_a_regression.R | 3 ++- R/tm_g_association.R | 2 +- R/tm_g_bivariate.R | 23 +++++++++++++---------- R/tm_g_distribution.R | 6 +++++- 4 files changed, 21 insertions(+), 13 deletions(-) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index a7902c581..c2427c2d0 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -168,7 +168,8 @@ tm_a_regression <- function(label = "Regression Analysis", ), response = picks( datasets(), - variables(choices = tidyselect::where(is.numeric)) + variables(choices = tidyselect::where(is.numeric)), + values(selected = tidyselect::everything(), multiple = TRUE) ), plot_height = c(600, 200, 2000), plot_width = NULL, diff --git a/R/tm_g_association.R b/R/tm_g_association.R index ea61acc65..0faedd667 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -152,7 +152,7 @@ tm_g_association <- function(label = "Association", teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1 ), - values() + values(selected = tidyselect::everything(), multiple = TRUE) ), vars = picks( datasets(), diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 895efc7d4..b2d3f9ec7 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -239,7 +239,8 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1 - ) + ), + values(selected = tidyselect::everything(), multiple = TRUE) ), y = picks( datasets(), @@ -247,7 +248,8 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2 - ) + ), + values(selected = tidyselect::everything(), multiple = TRUE) ), row_facet = NULL, col_facet = NULL, @@ -523,14 +525,15 @@ srv_g_bivariate.picks <- function(id, condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), message = "Please select at least one of x-variable or y-variable" ) - - validate_input( - inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), - condition = length(selectors$row_facet()$variables$selected) && - length(selectors$col_facet()$variables$selected) && - !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), - message = "Row and column facetting variables must be different." - ) + if (!is.null(col_facet) && !is.null(row_facet)) { + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = length(selectors$row_facet()$variables$selected) && + length(selectors$col_facet()$variables$selected) && + !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), + message = "Row and column facetting variables must be different." + ) + } obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Bivariate Plot"), diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index d22ae5e15..e57ffec26 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -156,7 +156,11 @@ tm_g_distribution <- function(label = "Distribution Module", #' @export tm_g_distribution.picks <- function(label = "Distribution Module", - dist_var = picks(datasets(), variables(where(is.numeric))), + dist_var = picks( + datasets(), + variables(where(is.numeric)), + values(selected = tidyselect::everything(), multiple = TRUE) + ), strata_var = NULL, group_var = NULL, freq = FALSE, From 2049b9809d576c11a2738ce13c643c8ca3617d50 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 1 Oct 2025 14:31:58 +0200 Subject: [PATCH 141/158] tm_distribution ready --- NAMESPACE | 6 + R/tm_a_regression.R | 15 +- R/tm_g_association.R | 6 +- R/tm_g_distribution.R | 1465 ++++++++++++++-------------- R/tm_g_response.R | 414 ++++---- R/tm_g_response_old.R | 449 +++++++++ R/tm_g_scatterplot.R | 555 +++++------ R/tm_g_scatterplot_old.R | 840 ++++++++++++++++ R/tm_g_scatterplotmatrix.R | 158 +-- R/tm_g_scatterplotmatrix_old.R | 402 ++++++++ man/get_scatterplotmatrix_stats.Rd | 39 +- man/tm_a_regression.Rd | 3 +- man/tm_g_association.Rd | 3 +- man/tm_g_response.Rd | 6 +- 14 files changed, 3039 insertions(+), 1322 deletions(-) create mode 100644 R/tm_g_response_old.R create mode 100644 R/tm_g_scatterplot_old.R create mode 100644 R/tm_g_scatterplotmatrix_old.R diff --git a/NAMESPACE b/NAMESPACE index e7827ca83..91ffc338e 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,12 @@ S3method(tm_g_bivariate,default) S3method(tm_g_bivariate,picks) S3method(tm_g_distribution,default) S3method(tm_g_distribution,picks) +S3method(tm_g_response,default) +S3method(tm_g_response,picks) +S3method(tm_g_scatterplot,default) +S3method(tm_g_scatterplot,picks) +S3method(tm_g_scatterplotmatrix,default) +S3method(tm_g_scatterplotmatrix,picks) export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index c2427c2d0..cd35710e4 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -222,7 +222,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", checkmate::assert_class(response, "picks") if (isTRUE(attr(response$variables, "multiple"))) { - warning("response accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } @@ -436,8 +436,15 @@ srv_a_regression.picks <- function(id, obj <- data() validate_input( inputId = "response-variables-selected", - condition = !is.null(selectors$response()$variables$selected), - message = "A regressor variable needs to be selected." + condition = length(selectors$response()$variables$selected) == 1, + message = "Single regressor variable must be selected." + ) + validate_input( + inputId = "response-variables-selected", + condition = is.numeric( + data[[selectors$response()$datasets$selected]][selectors$response()$variables$selected] + ), + message = "A regressor variable needs to be numeric." ) validate_input( inputId = "regressor-variables-selected", @@ -473,8 +480,6 @@ srv_a_regression.picks <- function(id, anl <- anl_merged_q()[["anl"]] teal::validate_has_data(anl, 10) - validate(need(is.numeric(anl[regression_var()$response][[1]]), "Response variable should be numeric.")) - teal::validate_has_data( anl[, c(regression_var()$response, regression_var()$regressor)], 10, complete = TRUE, allow_inf = FALSE diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 0faedd667..72b6509c7 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -159,7 +159,7 @@ tm_g_association <- function(label = "Association", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2, + selected = 2, # todo: make sure that is doesn't fail in teal.transform multiple = TRUE ), values() @@ -342,12 +342,12 @@ srv_g_association.picks <- function(id, validate_input( inputId = "ref-variables-selected", condition = !is.null(selectors$ref()$variables$selected), - message = "A reference variable needs to be selected." + message = "A reference variable must be selected." ) validate_input( inputId = "vars-variables-selected", condition = !is.null(selectors$vars()$variables$selected), - message = "A associated variables need to be selected." + message = "A associated variables must be selected." ) validate_input( inputId = c("ref-variables-selected", "vars-variables-selected"), diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index e57ffec26..418b2de30 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -159,7 +159,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", dist_var = picks( datasets(), variables(where(is.numeric)), - values(selected = tidyselect::everything(), multiple = TRUE) + values(selected = tidyselect::everything()) ), strata_var = NULL, group_var = NULL, @@ -175,7 +175,6 @@ tm_g_distribution.picks <- function(label = "Distribution Module", decorators = list()) { message("Initializing tm_g_distribution") - # Start of assertions checkmate::assert_string(label) @@ -237,6 +236,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", ans } + # UI function for the distribution module ui_g_distribution.picks <- function(id, strata_var, @@ -249,27 +249,29 @@ ui_g_distribution.picks <- function(id, post_output, decorators) { ns <- NS(id) + + hist_elem <- .ui_hist( + ns("histogram_plot"), + bins = bins, + freq = freq, + decorators = select_decorators(decorators, "histogram_plot") + ) + qq_elem <- .ui_qq(ns("qq_plot"), decorators = select_decorators(decorators, "qq_plot")) + summary_table_elem <- .ui_summary_table(ns("summary_table"), select_decorators(decorators, "Statistics Table")) + test_table_elem <- .ui_test_table(ns("test_table"), + is_stratified = !is.null(strata_var), + decorators = select_decorators(decorators, "Test Table") + ) + teal.widgets::standard_layout( output = teal.widgets::white_small_well( tabsetPanel( id = ns("tabs"), - tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))), - tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot"))) + tabPanel("Histogram", hist_elem$output), + tabPanel("QQplot", qq_elem$output) ), - tags$h3("Statistics Table"), - DT::dataTableOutput(ns("summary_table")), - tags$h3("Tests"), - conditionalPanel( - sprintf("input['%s'].length === 0", ns("dist_tests")), - div( - id = ns("please_select_a_test"), - "Please select a test" - ) - ), - conditionalPanel( - sprintf("input['%s'].length > 0", ns("dist_tests")), - DT::dataTableOutput(ns("t_stats")) - ) + bslib::card(summary_table_elem$output), + bslib::card(test_table_elem$output) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), @@ -297,86 +299,39 @@ ui_g_distribution.picks <- function(id, bslib::accordion( conditionalPanel( condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), - bslib::accordion_panel( - "Histogram", - teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), - shinyWidgets::prettyRadioButtons( - ns("main_type"), - label = "Plot Type:", - choices = c("Density", "Frequency"), - selected = if (!freq) "Density" else "Frequency", - bigger = FALSE, - inline = TRUE - ), - checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), - ui_decorate_teal_data( - ns("d_density"), - decorators = select_decorators(decorators, "histogram_plot") - ) - ) + bslib::accordion_panel(title = "Histogram", hist_elem$encodings, collapsed = FALSE) ), conditionalPanel( condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), - bslib::accordion_panel( - "QQ Plot", - checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), - ui_decorate_teal_data( - ns("d_qq"), - decorators = select_decorators(decorators, "qq_plot") - ), - collapsed = FALSE - ) + bslib::accordion_panel(title = "QQ Plot", qq_elem$encodings, collapsed = FALSE) ), - conditionalPanel( - condition = paste0("input['", ns("main_type"), "'] == 'Density'"), - bslib::accordion_panel( - "Theoretical Distribution", - teal.widgets::optionalSelectInput( - ns("t_dist"), - tags$div( - tagList( - "Distribution:", - bslib::tooltip( - icon("circle-info"), - tags$span( - "Default parameters are optimized with MASS::fitdistr function." - ) - ) + bslib::accordion_panel( # todo: hide ONLY when frequency is selected for histogram + "Theoretical Distribution", + teal.widgets::optionalSelectInput( + ns("t_dist"), + tags$div( + tagList( + "Distribution:", + bslib::tooltip( + icon("circle-info"), + tags$span("Default parameters are optimized with MASS::fitdistr function.") ) - ), - choices = c("normal", "lognormal", "gamma", "unif"), - selected = NULL, - multiple = FALSE + ) ), + choices = c("normal", "lognormal", "gamma", "unif"), + selected = NULL, + multiple = FALSE + ), + conditionalPanel( + condition = paste0("input['", ns("t_dist"), "'] != null && input['", ns("t_dist"), "'] != ''"), numericInput(ns("dist_param1"), label = "param1", value = NULL), numericInput(ns("dist_param2"), label = "param2", value = NULL), - tags$span(actionButton(ns("params_reset"), "Default params")), - collapsed = FALSE - ) - ), - bslib::accordion_panel( - title = "Tests", - teal.widgets::optionalSelectInput( - ns("dist_tests"), - "Tests:", - choices = c( - "Shapiro-Wilk", - if (!is.null(strata_var)) "t-test (two-samples, not paired)", - if (!is.null(strata_var)) "one-way ANOVA", - if (!is.null(strata_var)) "Fligner-Killeen", - if (!is.null(strata_var)) "F-test", - "Kolmogorov-Smirnov (one-sample)", - "Anderson-Darling (one-sample)", - "Cramer-von Mises (one-sample)", - if (!is.null(strata_var)) "Kolmogorov-Smirnov (two-samples)" - ), - selected = NULL - ) - ), - bslib::accordion_panel( - title = "Statistics Table", - sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2) + tags$span(actionButton(ns("params_reset"), "Default params")) + ), + collapsed = FALSE ), + bslib::accordion_panel(title = "Tests", test_table_elem$encodings), + bslib::accordion_panel(title = "Statistics Table", summary_table_elem$encodings), bslib::accordion_panel( title = "Plot settings", selectInput( @@ -415,97 +370,15 @@ srv_g_distribution.picks <- function(id, setBookmarkExclude("params_reset") ns <- session$ns - rule_req <- function(value) { - if (isTRUE(input$dist_tests %in% c( - "Fligner-Killeen", - "t-test (two-samples, not paired)", - "F-test", - "Kolmogorov-Smirnov (two-samples)", - "one-way ANOVA" - ))) { - if (!shinyvalidate::input_provided(value)) { - "Please select stratify variable." - } - } - } - rule_dupl <- function(...) { - if (identical(input$dist_tests, "Fligner-Killeen")) { - strata <- selector_list()$strata_i()$select - group <- selector_list()$group_i()$select - if (isTRUE(strata == group)) { - "Please select different variables for strata and group." - } - } - } selectors <- teal.transform::module_input_srv( spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), data = data ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - # teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") - # dist_i = shinyvalidate::sv_required("Please select a variable") - # strata_i = shinyvalidate::compose_rules( - # rule_req, - # rule_dupl - # ), - # group_i = rule_dupl - }) - - iv_r_dist <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators( - iv, selector_list, - validator_names = c("strata_i", "group_i") - ) - }) - rule_dist_1 <- function(value) { - if (!is.null(input$t_dist)) { - switch(input$t_dist, - "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", - "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", - "gamma" = { - if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" - }, - "unif" = NULL - ) - } - } - rule_dist_2 <- function(value) { - if (!is.null(input$t_dist)) { - switch(input$t_dist, - "normal" = { - if (!shinyvalidate::input_provided(value)) { - "sd is required" - } else if (value < 0) { - "sd must be non-negative" - } - }, - "lognormal" = { - if (!shinyvalidate::input_provided(value)) { - "sdlog is required" - } else if (value < 0) { - "sdlog must be non-negative" - } - }, - "gamma" = { - if (!shinyvalidate::input_provided(value)) { - "rate is required" - } else if (value <= 0) { - "rate must be positive" - } - }, - "unif" = NULL - ) - } - } - rule_dist <- function(value) { if (isTRUE(input$tabs == "QQplot") || - isTRUE(input$dist_tests %in% c( + isTRUE(input$dist_test %in% c( "Kolmogorov-Smirnov (one-sample)", "Anderson-Darling (one-sample)", "Cramer-von Mises (one-sample)" @@ -516,17 +389,62 @@ srv_g_distribution.picks <- function(id, } } - iv_dist <- shinyvalidate::InputValidator$new() - iv_dist$add_rule("t_dist", rule_dist) - iv_dist$add_rule("dist_param1", rule_dist_1) - iv_dist$add_rule("dist_param2", rule_dist_2) - iv_dist$enable() - anl_merged_q <- reactive({ - req(data()) - qenv <- data() - teal.code::eval_code(qenv, 'library("ggplot2");library("dplyr")') %>% - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") + validate_input( + inputId = "dist_var-variables-selected", + condition = length(selectors$dist_var()$variables$selected) == 1, + message = "Distribution variable must be selected." + ) + + obj <- req(data()) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Distribution Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + obj <- teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + obj <- teal.transform::qenv_merge_selectors(obj, selectors = selectors, output_name = "anl") + + anl <- obj[["anl"]] + + validate_input( + inputId = "dist_var-variables-selected", + condition = is.numeric(anl[[merge_vars()$dist_var]]), + message = "Distribution variable must be numeric." + ) + + if (length(merge_vars()$group_var) > 0) { + validate_input( + "group_var-variables-selected", + condition = inherits(anl[[merge_vars()$group_var]], c("integer", "factor", "character")), + message = "Group by variable must be `factor`, `character`, or `integer`" + ) + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), + group_var = merge_vars()$group_var + ) + } + + if (length(merge_vars()$strata_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = inherits(anl[[merge_vars()$strata_var]], c("integer", "factor", "character")), + message = "Stratify by variable must be `factor`, `character`, or `integer`" + ) + + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), + strata_var = merge_vars()$strata_var + ) + } + + teal::validate_has_data(anl, 1, complete = TRUE) + + obj }) merge_vars <- reactive( @@ -551,53 +469,35 @@ srv_g_distribution.picks <- function(id, }) observeEvent( - eventExpr = list( - input$t_dist, - input$params_reset, - selectors$dist_var()$variables$selected - ), + eventExpr = { + input$t_dist + input$params_reset + merge_vars()$dist_var + }, handlerExpr = { - params <- - if (length(input$t_dist) != 0) { - get_dist_params <- function(x, dist) { - if (dist == "unif") { - return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) - } - tryCatch( - MASS::fitdistr(x, densfun = dist)$estimate, - error = function(e) c(param1 = NA_real_, param2 = NA_real_) - ) - } - - anl <- anl_merged_q()[["anl"]] - round(get_dist_params(as.numeric(stats::na.omit(anl[[merge_vars()$dist_var]])), input$t_dist), 2) - } else { - c("param1" = NA_real_, "param2" = NA_real_) - } - - params_vals <- unname(params) - map_distr_nams <- list( - normal = c("mean", "sd"), - lognormal = c("meanlog", "sdlog"), - gamma = c("shape", "rate"), - unif = c("min", "max") - ) - - if (!is.null(input$t_dist) && input$t_dist %in% names(map_distr_nams)) { - params_names <- map_distr_nams[[input$t_dist]] + params <- if (length(input$t_dist)) { + req(anl_merged_q()) + anl <- anl_merged_q()[["anl"]] + round( + .calc_dist_params( + x = as.numeric(stats::na.omit(anl[[merge_vars()$dist_var]])), + dist = input$t_dist + ), + 2 + ) } else { - params_names <- names(params) + c("param1" = NA_real_, "param2" = NA_real_) } updateNumericInput( inputId = "dist_param1", - label = params_names[1], - value = restoreInput(ns("dist_param1"), params_vals[1]) + label = names(params)[1], + value = restoreInput(ns("dist_param1"), params[[1]]) ) updateNumericInput( inputId = "dist_param2", - label = params_names[2], - value = restoreInput(ns("dist_param1"), params_vals[2]) + label = names(params)[2], + value = restoreInput(ns("dist_param1"), params[[2]]) ) }, ignoreInit = TRUE @@ -607,225 +507,284 @@ srv_g_distribution.picks <- function(id, updateActionButton(inputId = "params_reset", label = "Reset params") }) - # common qenv - common_q <- reactive({ - req(anl_merged_q()) - # Create a private stack for this function only. - qenv <- anl_merged_q() - teal.reporter::teal_card(qenv) <- - c( - teal.reporter::teal_card("# Distribution Plot"), - teal.reporter::teal_card(qenv), - teal.reporter::teal_card("## Module's code") + validate_dist <- reactive({ + # Validate dist_param1 + if (!is.null(input$t_dist) && input$t_dist == "normal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "mean is required" ) - - anl <- qenv[["anl"]] - - roundn <- input$roundn - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - # isolated as dist_param1/dist_param2 already triggered the reactivity - t_dist <- isolate(input$t_dist) - - if (length(merge_vars()$group_var) > 0) { - validate( - need( - inherits(anl[[merge_vars()$group_var]], c("integer", "factor", "character")), - "Group by variable must be `factor`, `character`, or `integer`" - ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sd is required" ) - qenv <- within(qenv, library("forcats")) - qenv <- within( - qenv, - expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), - group_var = merge_vars()$group_var + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sd must be non-negative" ) } - - if (length(merge_vars()$strata_var) > 0) { - validate( - need( - inherits(anl[[merge_vars()$strata_var]], c("integer", "factor", "character")), - "Stratify by variable must be `factor`, `character`, or `integer`" - ) + if (!is.null(input$t_dist) && input$t_dist == "lognormal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "meanlog is required" ) - - qenv <- within(qenv, library("forcats")) - qenv <- within( - qenv, - expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), - strata_var = merge_vars()$strata_var + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sdlog is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sdlog must be non-negative" + ) + } + if (!is.null(input$t_dist) && input$t_dist == "gamma") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "shape is required" + ) + validate_input( + "dist_param1", + condition = is.null(input$dist_param1) || is.na(input$dist_param1) || input$dist_param1 > 0, + message = "shape must be positive" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "rate is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 > 0, + message = "rate must be positive" ) } + }) - validate(need(is.numeric(anl[[merge_vars()$dist_var]]), "Please select a numeric variable.")) - teal::validate_has_data(anl, 1, complete = TRUE) + # outputs ---- + hist_output <- .srv_hist( + "histogram_plot", + data = reactive({ + validate_dist() + anl_merged_q() + }), + merge_vars = merge_vars, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Histogram"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "histogram_plot") + ) - if (length(t_dist) != 0) { - map_distr_nams <- list( - normal = c("mean", "sd"), - lognormal = c("meanlog", "sdlog"), - gamma = c("shape", "rate"), - unif = c("min", "max") + qq_output <- .srv_qq( + "qq_plot", + data = reactive({ + validate_input( + "t_dist", + condition = !is.null(input$t_dist), + message = "QQ Plot requires Theoretical Distribution to be selected" ) - params_names_raw <- map_distr_nams[[t_dist]] + validate_dist() + anl_merged_q() + }), + merge_vars = merge_vars, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["QQplot"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "qq_plot") + ) - qenv <- within( - qenv, - expr = { - params <- as.list(c(dist_param1, dist_param2)) - names(params) <- params_names_raw - }, - dist_param1 = dist_param1, - dist_param2 = dist_param2, - params_names_raw = params_names_raw + summary_table_output <- .srv_summary_table( + "summary_table", + data = anl_merged_q, + merge_vars = merge_vars, + decorators = select_decorators(decorators, "Statistics Table") + ) + + test_q <- reactive({ + obj <- anl_merged_q() + anl <- obj[["anl"]] + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + dist_test <- input$`test_table-dist_test` + + if (identical(dist_test, "Fligner-Killeen")) { + validate_input( + "strata_var-variables-selected", + condition = !isTRUE(s_var == g_var), + message = "Please select different variables for strata and group." ) } - if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { - within( - qenv, - expr = { - summary_table_data <- anl %>% - dplyr::summarise( - min = round(min(d_var_name, na.rm = TRUE), roundn), - median = round(stats::median(d_var_name, na.rm = TRUE), roundn), - mean = round(mean(d_var_name, na.rm = TRUE), roundn), - max = round(max(d_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - d_var_name = as.name(merge_vars()$dist_var), - roundn = roundn - ) - } else { - within( - qenv, - expr = { - summary_table_data <- anl %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% - dplyr::summarise( - min = round(min(d_var_name, na.rm = TRUE), roundn), - median = round(stats::median(d_var_name, na.rm = TRUE), roundn), - mean = round(mean(d_var_name, na.rm = TRUE), roundn), - max = round(max(d_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - d_var_name = as.name(merge_vars()$dist_var), - strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), - roundn = roundn - ) + if (!is.null(dist_test) && dist_test %in% c( + "Fligner-Killeen", + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)", + "one-way ANOVA" + )) { + if (length(g_var) == 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = length(unique(anl[[s_var]])) == 2, + message = "Please select stratify variable with 2 levels." + ) + } else if (length(g_var) > 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = all(stats::na.omit(as.vector( + tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 + ))), + message = "Please select stratify variable with 2 levels, per each group." + ) + } } + validate_dist() + obj }) + test_output <- .srv_test_table( + "test_table", + data = test_q, + merge_vars = merge_vars, + t_dist = reactive(input$t_dist), + decorators = select_decorators(decorators, "Test Table") + ) - # distplot qenv ---- - dist_q <- eventReactive( - eventExpr = { - common_q() - input$scales_type - input$main_type - input$bins - input$add_dens - is.null(input$ggtheme) - }, - valueExpr = { - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var - d_var_name <- as.name(d_var) - s_var_name <- if (!is.null(s_var)) as.name(s_var) - g_var_name <- if (!is.null(g_var)) as.name(g_var) + # decorated_output_q <- reactive({ + # req(input$tabs, hist_output(), qq_output(), summary_table_output(), output_test_q()) + # test_q_out <- output_test_q() + + # # return everything except switch + # out_q <- switch(input$tabs, + # Histogram = hist_output(), + # QQplot = qq_output() + # ) + # out_q + # }) - t_dist <- input$t_dist - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 + # Render R code. + # source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + # teal.widgets::verbatim_popup_srv( + # id = "rcode", + # verbatim_content = source_code_r, + # title = "R Code for distribution" + # ) + NULL + }) +} - scales_type <- input$scales_type +.ui_hist <- function(id, bins, freq, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), + shinyWidgets::prettyRadioButtons( + ns("statistic"), + label = "Plot Type:", + choices = c("Density", "Frequency"), + selected = if (!freq) "Density" else "Frequency", + bigger = FALSE, + inline = TRUE + ), + checkboxInput(ns("add_density"), label = "Overlay Density", value = TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_hist <- function(id, + data, + merge_vars, + ggtheme, + scales_type, + t_dist, + dist_param1, + dist_param2, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + list( + data(), + input$bins, + input$statistic, + input$add_density, + dist_param1(), # don't observe t_dist as dist_param1 is changed by t_dist + dist_param2(), # don't observe t_dist as dist_param2 is changed by t_dist + scales_type() + ), + { + obj <- req(data()) + bins <- req(input$bins) + statistic <- if (req(input$statistic) == "Density") "density" else "count" + logger::log_debug(".srv_hist@1 Recalculating Histogram") + add_density <- input$add_density + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var ndensity <- 512 - main_type_var <- input$main_type - bins_var <- input$bins - add_dens_var <- input$add_dens - ggtheme <- input$ggtheme - # teal::validate_inputs(iv_dist) + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Histogram Plot") - qenv <- common_q() + plot_call <- substitute( + expr = ggplot2::ggplot(anl, mapping = ggplot2::aes(d_var_name)) + + ggplot2::geom_histogram( + ggplot2::aes(y = ggplot2::after_stat(stat)), + position = "identity", bins = bins, alpha = 0.3 + ), + env = list(stat = as.name(statistic), bins = bins, d_var_name = as.name(d_var)) + ) - m_type <- if (main_type_var == "Density") "density" else "count" + if (length(s_var)) { + plot_call[[2]]$mapping$col <- as.name(s_var) + plot_call[[2]]$mapping$fill <- as.name(s_var) + } - plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(anl, ggplot2::aes(d_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 - ), - env = list( - m_type = as.name(m_type), bins_var = bins_var, d_var_name = d_var_name - ) - ) - } else if (length(s_var) != 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(anl, ggplot2::aes(d_var_name, col = s_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), - bins = bins_var, alpha = 0.3 - ), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - d_var_name = d_var_name, - s_var = as.name(s_var), - s_var_name = s_var_name - ) - ) - } else if (length(s_var) == 0 && length(g_var) != 0) { - req(scales_type) - substitute( - expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes(d_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 - ) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - d_var_name = d_var_name, - g_var = g_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) - ) - ) - } else { - req(scales_type) - substitute( - expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes(d_var_name, col = s_var_name)) + - ggplot2::geom_histogram( - position = "identity", - ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 - ) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - d_var_name = d_var_name, - g_var = g_var, - s_var = as.name(s_var), - g_var_name = g_var_name, - s_var_name = s_var_name, - scales_raw = tolower(scales_type) + if (length(g_var)) { + req(scales_type()) + plot_call <- call( + "+", + plot_call, + substitute( + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales), + list(g_var_name = as.name(g_var), scales = tolower(scales_type())) ) ) } - if (add_dens_var) { + if (add_density) { plot_call <- substitute( expr = plot_call + ggplot2::stat_density( - ggplot2::aes(y = ggplot2::after_stat(const * m_type2)), + ggplot2::aes(y = ggplot2::after_stat(const * stat)), geom = "line", position = "identity", alpha = 0.5, @@ -834,83 +793,61 @@ srv_g_distribution.picks <- function(id, ), env = list( plot_call = plot_call, - const = if (main_type_var == "Density") { + const = if (statistic == "density") { 1 } else { - diff(range(qenv[["anl"]][[dist_var]], na.rm = TRUE)) / bins_var + diff(range(obj[["anl"]][[d_var]], na.rm = TRUE)) / bins }, - m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"), + stat = as.name(statistic), ndensity = ndensity ) ) } - if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - df_params <- as.data.frame(append(params, list(name = t_dist))), - env = list(t_dist = t_dist) - ) - ) - datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) - label <- quote(tb) + if (length(s_var) == 0 && length(g_var) == 0 && statistic == "density" && length(t_dist()) != 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes + param_list <- .dist_param_list(t_dist(), dist_param1(), dist_param2()) + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") plot_call <- substitute( - expr = plot_call + ggpp::geom_table_npc( - data = data, - ggplot2::aes(npcx = x, npcy = y, label = label), - hjust = 0, vjust = 1, size = 4 - ), - env = list(plot_call = plot_call, data = datas, label = label) - ) - } - - if ( - length(s_var) == 0 && - length(g_var) == 0 && - main_type_var == "Density" && - length(t_dist) != 0 && - main_type_var == "Density" - ) { - map_dist <- stats::setNames( - c("dnorm", "dlnorm", "dgamma", "dunif"), - c("normal", "lognormal", "gamma", "unif") - ) - plot_call <- substitute( - expr = plot_call + stat_function( - data = data.frame(x = range(anl[[dist_var]]), color = mapped_dist), - ggplot2::aes(x, color = color), - fun = mapped_dist_name, - n = ndensity, - size = 2, - args = params - ) + - ggplot2::scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"), + expr = plot_call + + ggpp::geom_table_npc( + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 + ) + + stat_function( + data = data.frame(x = range(anl[[d_var]]), color = density_dist), + ggplot2::aes(x, color = color), + fun = density_dist_name, + n = ndensity, + size = 2, + args = param_list + ) + + ggplot2::scale_color_manual(values = stats::setNames("blue", density_dist), aesthetics = "color"), env = list( plot_call = plot_call, - dist_var = dist_var, + d_var = d_var, + density_dist = unname(map_dist[t_dist()]), + density_dist_name = as.name(unname(map_dist[t_dist()])), ndensity = ndensity, - mapped_dist = unname(map_dist[t_dist]), - mapped_dist_name = as.name(unname(map_dist[t_dist])) + nested_df = as.call( + c( + as.name("data.frame"), + param_list, + list(distribution = t_dist()) + ) + ), + param_list = param_list ) ) } - all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["Histogram"]], - user_default = ggplot2_args$default - ) + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( - all_ggplot2_args, - ggtheme = ggtheme - ) - - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Histogram Plot") teal.code::eval_code( - qenv, + obj, substitute( expr = histogram_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) @@ -919,132 +856,141 @@ srv_g_distribution.picks <- function(id, } ) - # qqplot qenv ---- - qq_q <- eventReactive( - eventExpr = { - common_q() - input$scales_type + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(histogram_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["histogram_plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_qq <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_qq <- function(id, + data, + merge_vars, + t_dist, + dist_param1, + dist_param2, + scales_type, + ggtheme, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + { + data() + t_dist() + dist_param1() + dist_param2() input$qq_line - is.null(input$ggtheme) - input$tabs + ggtheme() }, - valueExpr = { - browser() - + { + req(data(), merge_vars(), ggtheme(), t_dist()) + logger::log_debug(".srv_qq@1 Recalculating QQ Plot...") + obj <- data() d_var <- merge_vars()$dist_var s_var <- merge_vars()$strata_var g_var <- merge_vars()$group_var - d_var_name <- as.name(s_var) - s_var_name <- if (!is.null(s_var)) as.name(s_var) - g_var_name <- if (!is.null(g_var)) as.name(g_var) - - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - scales_type <- input$scales_type - ggtheme <- input$ggtheme + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## QQ Plot") - # teal::validate_inputs(iv_r_dist(), iv_dist) - t_dist <- req(input$t_dist) # Not validated when tab is not selected - qenv <- common_q() - - plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(anl, ggplot2::aes_string(sample = d_var)), - env = list(d_var = d_var) - ) - } else if (length(s_var) != 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(anl, ggplot2::aes_string(sample = d_var, color = s_var)), - env = list(d_var = d_var, s_var = s_var) - ) - } else if (length(s_var) == 0 && length(g_var) != 0) { - substitute( - expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes_string(sample = d_var)) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - d_var = d_var, - g_var = g_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) - ) + plot_call <- substitute( + expr = ggplot2::ggplot(dataname, mapping = ggplot2::aes(sample = d_var_name)), + env = list( + dataname = if (length(g_var)) { + bquote(anl[anl[[.(g_var)]] != "NA", ]) + } else { + quote(anl) + }, + d_var_name = as.name(d_var) ) - } else { - substitute( - expr = ggplot2::ggplot(anl[anl[[g_var]] != "NA", ], ggplot2::aes_string(sample = d_var, color = s_var)) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - d_var = d_var, - g_var = g_var, - s_var = s_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) + ) + if (length(s_var)) plot_call$mapping$color <- as.name(s_var) + if (length(g_var)) { + plot_call <- substitute( + plot_call + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + list( + plot_call = plot_call, + g_var_name = as.name(g_var), + scales_raw = tolower(scales_type()) ) ) } - map_dist <- stats::setNames( - c("qnorm", "qlnorm", "qgamma", "qunif"), - c("normal", "lognormal", "gamma", "unif") - ) + map_quantile_fun <- c(normal = "qnorm", lognormal = "qlnorm", gamma = "qgamma", unif = "qunif") plot_call <- substitute( - expr = plot_call + - ggplot2::stat_qq(distribution = mapped_dist, dparams = params), - env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) + expr = plot_call + ggplot2::stat_qq(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) + ) ) - if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - df_params <- as.data.frame(append(params, list(name = t_dist))), - env = list(t_dist = t_dist) + if (isTRUE(input$qq_line)) { + plot_call <- substitute( + expr = plot_call + ggplot2::stat_qq_line(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) ) ) - datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) - label <- quote(tb) + } + if (length(s_var) == 0 && length(g_var) == 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes plot_call <- substitute( expr = plot_call + ggpp::geom_table_npc( - data = data, - ggplot2::aes(npcx = x, npcy = y, label = label), - hjust = 0, - vjust = 1, - size = 4 + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 ), env = list( plot_call = plot_call, - data = datas, - label = label + nested_df = as.call( + c( + as.name("data.frame"), + .dist_param_list(t_dist(), dist_param1(), dist_param2()), + list(distribution = t_dist()) + ) + ) ) ) } - if (isTRUE(input$qq_line)) { - plot_call <- substitute( - expr = plot_call + - ggplot2::stat_qq_line(distribution = mapped_dist, dparams = params), - env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) - ) - } - - all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["QQplot"]], - user_default = ggplot2_args$default, - module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) - ) - - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( - all_ggplot2_args, - ggtheme = ggtheme - ) - - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## QQ Plot") + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) teal.code::eval_code( - qenv, + obj, substitute( expr = qq_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) @@ -1053,72 +999,190 @@ srv_g_distribution.picks <- function(id, } ) - # test qenv ---- - test_q <- eventReactive( + decorated_output_q <- srv_decorate_teal_data( + "decorators", + decorators = decorators, + data = output_q, + expr = quote(qq_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["qq_plot"]]) + + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + # set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_summary_table <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tags$div( + tags$h3("Statistics Table"), + DT::dataTableOutput(ns("summary_table")) + ) + ) +} + +.srv_summary_table <- function(id, data, merge_vars, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- reactive({ + obj <- req(data()) + roundn <- input$roundn + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Statistics table") + + obj <- if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + roundn = roundn + ) + } else { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), + roundn = roundn + ) + } + + within(obj, summary_table <- rtables::df_to_tt(summary_table_data)) + # if (iv_r()$is_valid()) { + + # } else { + # within( + # q_common, + # summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) + # ) + # } + }) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(summary_table) + ) + + output_r <- reactive({ + obj <- req(decorated_output_q()) + + # todo: why summary_table_data is returned while summary_table is printed in a code? + DT::datatable( + obj[["summary_table_data"]], + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) + }) + + output$summary_table <- DT::renderDataTable(output_r()) + + decorated_output_q + }) +} + +.ui_test_table <- function(id, is_stratified, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + shinyWidgets::pickerInput( + ns("dist_test"), + "Tests:", + choices = c( + "Shapiro-Wilk", + if (is_stratified) "Kolmogorov-Smirnov (two-samples)", + if (is_stratified) "one-way ANOVA", + if (is_stratified) "Fligner-Killeen", + if (is_stratified) "F-test", + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)", + if (is_stratified) "t-test (two-samples, not paired)" + ), + selected = NULL, + options = list( + `allow-clear` = TRUE, + "none-selected-text" = "- Nothing selected -" + ) + ), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tagList( + tags$h3("Tests"), + DT::dataTableOutput(ns("table")) + ) + ) +} + +.srv_test_table <- function(id, data, merge_vars, t_dist, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( ignoreNULL = FALSE, eventExpr = { - common_q() - input$dist_param1 - input$dist_param2 - input$dist_tests + data() + input$dist_test }, valueExpr = { - # Create a private stack for this function only. - anl <- common_q()[["anl"]] - + obj <- data() + anl <- obj[["anl"]] d_var <- merge_vars()$dist_var s_var <- merge_vars()$strata_var g_var <- merge_vars()$group_var - d_var_name <- as.name(s_var) + d_var_name <- as.name(d_var) s_var_name <- if (!is.null(s_var)) as.name(s_var) g_var_name <- if (!is.null(g_var)) as.name(g_var) - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - dist_tests <- input$dist_tests - t_dist <- input$t_dist - - req(dist_tests) - - # teal::validate_inputs(iv_dist) + dist_test <- input$dist_test + validate(need(length(dist_test) > 0, "Please select a test")) if (length(s_var) > 0 || length(g_var) > 0) { counts <- anl %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% dplyr::summarise(n = dplyr::n()) - validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) } - - if (dist_tests %in% c( - "t-test (two-samples, not paired)", - "F-test", - "Kolmogorov-Smirnov (two-samples)" - )) { - if (length(g_var) == 0 && length(s_var) > 0) { - validate(need( - length(unique(anl[[s_var]])) == 2, - "Please select stratify variable with 2 levels." - )) - } - if (length(g_var) > 0 && length(s_var) > 0) { - validate(need( - all(stats::na.omit(as.vector( - tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 - ))), - "Please select stratify variable with 2 levels, per each group." - )) - } - } - - map_dist <- stats::setNames( - c("pnorm", "plnorm", "pgamma", "punif"), - c("normal", "lognormal", "gamma", "unif") - ) + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") sks_args <- list( test = quote(stats::ks.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), groups = c(g_var, s_var) ) ssw_args <- list( @@ -1133,12 +1197,12 @@ srv_g_distribution.picks <- function(id, ) sad_args <- list( test = quote(goftest::ad.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), groups = c(g_var, s_var) ) scvm_args <- list( test = quote(goftest::cvm.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist])), params)), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), groups = c(g_var, s_var) ) manov_args <- list( @@ -1162,7 +1226,7 @@ srv_g_distribution.picks <- function(id, groups = c(g_var) ) - tests_base <- switch(dist_tests, + tests_base <- switch(dist_test, "Kolmogorov-Smirnov (one-sample)" = sks_args, "Shapiro-Wilk" = ssw_args, "Fligner-Killeen" = mfil_args, @@ -1175,7 +1239,7 @@ srv_g_distribution.picks <- function(id, ) env <- list( - t_test = t_dist, + t_test = t_dist(), d_var = d_var, g_var = g_var, s_var = s_var, @@ -1187,12 +1251,13 @@ srv_g_distribution.picks <- function(id, s_var_name = s_var_name ) - qenv <- common_q() - if (length(s_var) == 0 && length(g_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("generics")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Distribution Tests table") + + obj <- if (length(s_var) == 0 && length(g_var) == 0) { + obj <- teal.code::eval_code(obj, 'library("generics")') # nolint quotes + teal.code::eval_code( + obj, substitute( expr = { test_table_data <- anl %>% @@ -1204,9 +1269,10 @@ srv_g_distribution.picks <- function(id, ) ) } else { - qenv <- teal.code::eval_code(qenv, 'library("tidyr")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, + # todo: why there is a `library` call when `tidyr::unnest` is prefixed, same for `generics` + obj <- teal.code::eval_code(obj, 'library("tidyr")') # nolint quotes + teal.code::eval_code( + obj, substitute( expr = { test_table_data <- anl %>% @@ -1220,149 +1286,50 @@ srv_g_distribution.picks <- function(id, ) ) } - } - ) - - # outputs ---- - - # Summary table listing has to be created separately to allow for qenv join - q_common <- common_q() - teal.reporter::teal_card(q_common) <- c( - teal.reporter::teal_card(q_common), - "## Statistics table" - ) - output_summary_q <- reactive({ - if (iv_r()$is_valid()) { - within(q_common, { - summary_table <- rtables::df_to_tt(summary_table_data) - }) - } else { - within( - q_common, - summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) - ) - } - }) - output_test_q <- reactive({ - # wrapped in if since could lead into validate error - we do want to continue - test_q_out <- try(test_q(), silent = TRUE) - q_common <- common_q() - teal.reporter::teal_card(q_common) <- c( - teal.reporter::teal_card(q_common), - "## Distribution Tests table" - ) - if (inherits(test_q_out, c("try-error", "error"))) { - within( - q_common, - test_table <- rtables::rtable(header = rtables::rheader("No data available in table"), rtables::rrow()) - ) - } else { - within(c(q_common, test_q_out), { + within(obj, { test_table <- rtables::df_to_tt(test_table_data) }) } - }) - - decorated_output_dist_q <- srv_decorate_teal_data( - "d_density", - data = dist_q, - decorators = select_decorators(decorators, "histogram_plot"), - expr = quote(histogram_plot) ) - decorated_output_qq_q <- srv_decorate_teal_data( - "d_qq", - data = qq_q, - decorators = select_decorators(decorators, "qq_plot"), - expr = quote(qq_plot) - ) - - decorated_output_summary_q <- srv_decorate_teal_data( - "d_summary", - data = output_summary_q, - decorators = select_decorators(decorators, "summary_table"), - expr = quote(summary_table) - ) - - decorated_output_test_q <- srv_decorate_teal_data( - "d_test", - data = output_test_q, - decorators = select_decorators(decorators, "test_table"), + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, expr = quote(test_table) ) - dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]]) - qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]]) - - summary_r <- reactive({ - q <- req(output_summary_q()) - - DT::datatable( - q[["summary_table_data"]], - options = list( - autoWidth = TRUE, - columnDefs = list(list(width = "200px", targets = "_all")) - ), - rownames = FALSE - ) - }) - - output$summary_table <- DT::renderDataTable(summary_r()) - - tests_r <- reactive({ - q <- req(output_test_q()) - DT::datatable(q[["test_table_data"]]) + output_r <- reactive({ + obj <- req(decorated_output_q()) + DT::datatable(obj[["test_table_data"]]) }) - pws1 <- teal.widgets::plot_with_settings_srv( - id = "hist_plot", - plot_r = dist_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) + output$table <- DT::renderDataTable(output_r()) - pws2 <- teal.widgets::plot_with_settings_srv( - id = "qq_plot", - plot_r = qq_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) - - decorated_output_dist_dims_q <- set_chunk_dims(pws1, decorated_output_dist_q) - - decorated_output_qq_dims_q <- set_chunk_dims(pws2, decorated_output_qq_q) - - decorated_output_q <- reactive({ - tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement - test_q_out <- output_test_q() - - out_q <- switch(tab, - Histogram = decorated_output_dist_dims_q(), - QQplot = decorated_output_qq_dims_q() - ) - withCallingHandlers( - c(out_q, output_summary_q(), test_q_out), - warning = function(w) { - if (grepl("Restoring original content and adding only", conditionMessage(w))) { - invokeRestart("muffleWarning") - } - } - ) - }) + decorated_output_q + }) +} - output$t_stats <- DT::renderDataTable(tests_r()) +.calc_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) +} - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) +.dist_param_list <- function(dist, param1, param2) { + dist_param_names <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "R Code for distribution" - ) - decorated_output_q - }) + params <- list(param1, param2) + names(params) <- dist_param_names[[dist]] + params } diff --git a/R/tm_g_response.R b/R/tm_g_response.R index 7f22bacb5..00d98375c 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -160,8 +160,19 @@ #' @export #' tm_g_response <- function(label = "Response Plot", - response, - x, + response = picks( + datasets(), + variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10)), + values() + ), + x = picks( + datasets(), + variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2 + ), + values() + ), row_facet = NULL, col_facet = NULL, coord_flip = FALSE, @@ -176,31 +187,46 @@ tm_g_response <- function(label = "Response Plot", post_output = NULL, transformators = list(), decorators = list()) { - message("Initializing tm_g_response") + UseMethod("tm_g_response", response) +} - # Normalize the parameters - if (inherits(response, "data_extract_spec")) response <- list(response) - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) +#' @export +tm_g_response.picks <- function(label = "Response Plot", + response, + x, + row_facet = NULL, + col_facet = NULL, + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_response") # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(response, types = "data_extract_spec") - if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) { - stop("'response' should not allow empty values") + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE } - assert_single_selection(response) - checkmate::assert_list(x, types = "data_extract_spec") - if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) { - stop("'x' should not allow empty values") + checkmate::assert_class(x, "picks") + if (isTRUE(attr(x$variables, "multiple"))) { + warning("`x` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(x$variables, "multiple") <- FALSE } - assert_single_selection(x) - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) checkmate::assert_flag(coord_flip) checkmate::assert_flag(count_labels) checkmate::assert_flag(rotate_xaxis_labels) @@ -223,98 +249,85 @@ tm_g_response <- function(label = "Response Plot", assert_decorators(decorators, "plot") # End of assertions - # Make UI args - args <- as.list(environment()) - - data_extract_list <- list( - response = response, - x = x, - row_facet = row_facet, - col_facet = col_facet - ) + args <- as.list(environment()) ans <- module( label = label, - server = srv_g_response, - ui = ui_g_response, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + ui = ui_g_response.picks, + server = srv_g_response.picks, + ui_args = args[names(args) %in% names(formals(ui_g_response.picks))], + server_args = args[names(args) %in% names(formals(srv_g_response.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(response, x, row_facet, col_facet)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the response module -ui_g_response <- function(id, ...) { +ui_g_response.picks <- function(id, + response, + x, + row_facet, + col_facet, + freq, + count_labels, + rotate_xaxis_labels, + coord_flip, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) - teal.widgets::standard_layout( output = teal.widgets::white_small_well( teal.widgets::plot_with_settings_ui(id = ns("myplot")) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]), - teal.transform::data_extract_ui( - id = ns("response"), - label = "Response variable", - data_extract_spec = args$response, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Response variable"), + teal.transform::module_input_ui(id = ns("response"), spec = response) ), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x) ), - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(row_facet)) { + teal::teal_nav_item( + label = tags$strong("Row facetting"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) ) }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(col_facet)) { + teal::teal_nav_item( + label = tags$strong("Column facetting"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) ) }, shinyWidgets::radioGroupButtons( inputId = ns("freq"), label = NULL, choices = c("frequency", "density"), - selected = ifelse(args$freq, "frequency", "density"), + selected = ifelse(freq, "frequency", "density"), justified = TRUE ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels), - checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + checkboxInput(ns("count_labels"), "Add count labels", value = count_labels), + checkboxInput(ns("coord_flip"), "Swap axes", value = coord_flip), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -323,116 +336,102 @@ ui_g_response <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the response module -srv_g_response <- function(id, - data, - response, - x, - row_facet, - col_facet, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_response.picks <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) - - rule_diff <- function(other) { - function(value) { - if (other %in% names(selector_list())) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - } + selectors <- teal.transform::module_input_srv( + spec = list( + response = response, + x = x, + row_facet = row_facet, + col_facet = col_facet + ), + data = data + ) - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - response = shinyvalidate::sv_required("Please define a column for the response variable"), - x = shinyvalidate::sv_required("Please define a column for X variable"), - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", - rule_diff("row_facet") - ) + anl_merged_q <- reactive({ + obj <- req(data()) + validate_input( + inputId = "response-variables-selected", + condition = !is.null(selectors$response()$variables$selected), + message = "A `response` variable needs to be selected." + ) + validate_input( + inputId = "x-variables-selected", + condition = !is.null(selectors$x()$variables$selected), + message = "A `x` variable needs to be selected." + ) + validate_input( + inputId = c("response-variables-selected", "x-variables-selected"), + condition = !any(selectors$response()$variables$selected %in% selectors$x()$variables$selected), + message = "Response and X variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." ) - ) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme")) - teal.transform::compose_and_enable_validators(iv, selector_list) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Response Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + obj |> + teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - qenv <- reactive( - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes - ) + output_q <- reactive({ + validate_input( + inputId = "ggtheme", + condition = length(input$ggtheme) > 0, + message = "Row and Col Facetting variables must be different." + ) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) + qenv <- anl_merged_q() + anl <- qenv[["anl"]] + response_var <- teal.transform::map_merged(selectors)$response$variables + x_var <- teal.transform::map_merged(selectors)$x$variables - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) + validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) + validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) - output_q <- reactive({ - teal::validate_inputs(iv_r()) - - qenv <- merged$anl_q_r() - teal.reporter::teal_card(qenv) <- - c( - teal.reporter::teal_card("# Response Plot"), - teal.reporter::teal_card(qenv), - teal.reporter::teal_card("## Module's code") - ) - ANL <- qenv[["ANL"]] - resp_var <- as.vector(merged$anl_input_r()$columns_source$response) - x <- as.vector(merged$anl_input_r()$columns_source$x) - - validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) - validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) - teal::validate_has_data(ANL, 10) - teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) - - row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$row_facet) - } - col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$col_facet) - } + row_facet_var <- map_merged(selectors)$row_facet$variables + col_facet_var <- map_merged(selectors)$col_facet$variables freq <- input$freq == "frequency" swap_axes <- input$coord_flip @@ -442,54 +441,43 @@ srv_g_response <- function(id, arg_position <- if (freq) "stack" else "fill" - rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) - colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) - resp_cl <- as.name(resp_var) - x_cl <- as.name(x) - if (swap_axes) { - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), - env = list(x = x, x_cl = x_cl) - ) + expr = anl[[x_var]] <- with(anl, forcats::fct_rev(x_cl)), + x_var = x_var, + x_cl = as.name(x_var) ) } - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), - env = list(resp_var = resp_var) - ) - ) %>% - # rowf and colf will be a NULL if not set by a user - teal.code::eval_code( - substitute( - expr = ANL2 <- ANL %>% - dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% - dplyr::summarise(ns = dplyr::n()) %>% - dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% - dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), - env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = ANL3 <- ANL %>% - dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% - dplyr::summarise(ns = dplyr::n()), - env = list(x_cl = x_cl, rowf = rowf, colf = colf) - ) - ) + expr = { + anl[[response_var]] <- factor(anl[[response_var]]) + + anl2 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, response_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)) + + anl3 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) + }, + response_var = response_var, + response_cl = as.name(response_var), + x_cl = as.name(x_var), + row_facet_cl = if (length(row_facet)) as.name(row_facet_var), + col_facet_cl = if (length(col_facet)) as.name(col_facet_var) + ) plot_call <- substitute( - expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) + - ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position), + expr = ggplot2::ggplot(anl2, ggplot2::aes(x = x_cl, y = ns)) + + ggplot2::geom_bar(ggplot2::aes(fill = response_cl), stat = "identity", position = arg_position), env = list( - x_cl = x_cl, - resp_cl = resp_cl, + x_cl = as.name(x_var), + response_cl = as.name(response_var), arg_position = arg_position ) ) @@ -505,23 +493,23 @@ srv_g_response <- function(id, plot_call <- substitute( expr = plot_call + ggplot2::geom_text( - data = ANL2, - ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl), + data = anl2, + ggplot2::aes(label = ns, x = x_cl, y = ns, group = response_cl), col = "white", vjust = "middle", hjust = "middle", position = position_anl2_value ) + ggplot2::geom_text( - data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), + data = anl3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), hjust = hjust_value, vjust = vjust_value, position = position_anl3_value ), env = list( plot_call = plot_call, - x_cl = x_cl, - resp_cl = resp_cl, + x_cl = as.name(x_var), + response_cl = as.name(response_var), hjust_value = if (swap_axes) "left" else "middle", vjust_value = if (swap_axes) "middle" else -1, position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. @@ -535,7 +523,7 @@ srv_g_response <- function(id, plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) } - facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) + facet_cl <- facet_ggplot_call(row_facet_var, col_facet_var) if (!is.null(facet_cl)) { plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) @@ -543,9 +531,9 @@ srv_g_response <- function(id, dev_ggplot2_args <- teal.widgets::ggplot2_args( labs = list( - x = varname_w_label(x, ANL), - y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), - fill = varname_w_label(resp_var, ANL) + x = varname_w_label(x_var, anl), + y = varname_w_label(response_var, anl, prefix = "Proportion of "), + fill = varname_w_label(response_var, anl) ), theme = list(legend.position = "bottom") ) diff --git a/R/tm_g_response_old.R b/R/tm_g_response_old.R new file mode 100644 index 000000000..ae92f0b39 --- /dev/null +++ b/R/tm_g_response_old.R @@ -0,0 +1,449 @@ +#' @export +tm_g_response.default <- function(label = "Response Plot", + response, + x, + row_facet = NULL, + col_facet = NULL, + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_response") + + # Normalize the parameters + if (inherits(response, "data_extract_spec")) response <- list(response) + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_list(response, types = "data_extract_spec") + if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) { + stop("'response' should not allow empty values") + } + assert_single_selection(response) + + checkmate::assert_list(x, types = "data_extract_spec") + if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) { + stop("'x' should not allow empty values") + } + assert_single_selection(x) + + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_flag(coord_flip) + checkmate::assert_flag(count_labels) + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(freq) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list( + response = response, + x = x, + row_facet = row_facet, + col_facet = col_facet + ) + + ans <- module( + label = label, + server = srv_g_response.default, + ui = ui_g_response.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the response module +ui_g_response.default <- function(id, ...) { + ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]), + teal.transform::data_extract_ui( + id = ns("response"), + label = "Response variable", + data_extract_spec = args$response, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value + ), + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value + ) + }, + shinyWidgets::radioGroupButtons( + inputId = ns("freq"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(args$freq, "frequency", "density"), + justified = TRUE + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels), + checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the response module +srv_g_response.default <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) + + rule_diff <- function(other) { + function(value) { + if (other %in% names(selector_list())) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + response = shinyvalidate::sv_required("Please define a column for the response variable"), + x = shinyvalidate::sv_required("Please define a column for X variable"), + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", + rule_diff("row_facet") + ) + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme")) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + + qenv <- reactive( + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + ) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + output_q <- reactive({ + teal::validate_inputs(iv_r()) + + qenv <- merged$anl_q_r() + teal.reporter::teal_card(qenv) <- + c( + teal.reporter::teal_card("# Response Plot"), + teal.reporter::teal_card(qenv), + teal.reporter::teal_card("## Module's code") + ) + ANL <- qenv[["ANL"]] + resp_var <- as.vector(merged$anl_input_r()$columns_source$response) + x <- as.vector(merged$anl_input_r()$columns_source$x) + + validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) + validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) + teal::validate_has_data(ANL, 10) + teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) + + row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$row_facet) + } + col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$col_facet) + } + + freq <- input$freq == "frequency" + swap_axes <- input$coord_flip + counts <- input$count_labels + rotate_xaxis_labels <- input$rotate_xaxis_labels + ggtheme <- input$ggtheme + + arg_position <- if (freq) "stack" else "fill" + + rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) + colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) + resp_cl <- as.name(resp_var) + x_cl <- as.name(x) + + if (swap_axes) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), + env = list(x = x, x_cl = x_cl) + ) + ) + } + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), + env = list(resp_var = resp_var) + ) + ) %>% + # rowf and colf will be a NULL if not set by a user + teal.code::eval_code( + substitute( + expr = ANL2 <- ANL %>% + dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% + dplyr::summarise(ns = dplyr::n()) %>% + dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% + dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), + env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = ANL3 <- ANL %>% + dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% + dplyr::summarise(ns = dplyr::n()), + env = list(x_cl = x_cl, rowf = rowf, colf = colf) + ) + ) + + plot_call <- substitute( + expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) + + ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position), + env = list( + x_cl = x_cl, + resp_cl = resp_cl, + arg_position = arg_position + ) + ) + + if (!freq) { + plot_call <- substitute( + plot_call + ggplot2::expand_limits(y = c(0, 1.1)), + env = list(plot_call = plot_call) + ) + } + + if (counts) { + plot_call <- substitute( + expr = plot_call + + ggplot2::geom_text( + data = ANL2, + ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl), + col = "white", + vjust = "middle", + hjust = "middle", + position = position_anl2_value + ) + + ggplot2::geom_text( + data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), + hjust = hjust_value, + vjust = vjust_value, + position = position_anl3_value + ), + env = list( + plot_call = plot_call, + x_cl = x_cl, + resp_cl = resp_cl, + hjust_value = if (swap_axes) "left" else "middle", + vjust_value = if (swap_axes) "middle" else -1, + position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. + anl3_y = if (!freq) 1.1 else as.name("ns"), + position_anl3_value = if (!freq) "fill" else "stack" + ) + ) + } + + if (swap_axes) { + plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) + } + + facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) + + if (!is.null(facet_cl)) { + plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) + } + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list( + x = varname_w_label(x, ANL), + y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), + fill = varname_w_label(resp_var, ANL) + ), + theme = list(legend.position = "bottom") + ) + + if (rotate_xaxis_labels) { + dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + plot_call <- substitute(expr = { + plot <- plot_call + labs + ggthemes + themes + }, env = list( + plot_call = plot_call, + labs = parsed_ggplot2_args$labs, + themes = parsed_ggplot2_args$theme, + ggthemes = parsed_ggplot2_args$ggtheme + )) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") + teal.code::eval_code(qenv, plot_call) + }) + + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Show R Code for Response" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index fcd159497..3226f76cd 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -258,29 +258,51 @@ tm_g_scatterplot <- function(label = "Scatterplot", ggplot2_args = teal.widgets::ggplot2_args(), transformators = list(), decorators = list()) { - message("Initializing tm_g_scatterplot") + UseMethod("tm_g_scatterplot", x) +} - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) - if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) - if (is.double(max_deg)) max_deg <- as.integer(max_deg) +#' @export +tm_g_scatterplot.picks <- function(label = "Scatterplot", + x, + y, + color_by = NULL, + size_by = NULL, + row_facet = NULL, + col_facet = NULL, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_g_scatterplot") # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(x, types = "data_extract_spec") - checkmate::assert_list(y, types = "data_extract_spec") - checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) - - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(row_facet) + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + checkmate::assert_class(color_by, "picks", null.ok = TRUE) + checkmate::assert_class(size_by, "picks", null.ok = TRUE) + + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(row_facet$variables, "multiple"))) { + warning("`row_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(row_facet$variables, "multiple") <- FALSE + } - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(col_facet) + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(col_facet$variables, "multiple"))) { + warning("`col_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(col_facet$variables, "multiple") <- FALSE + } checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -322,140 +344,121 @@ tm_g_scatterplot <- function(label = "Scatterplot", # Make UI args args <- as.list(environment()) - - data_extract_list <- list( - x = x, - y = y, - color_by = color_by, - size_by = size_by, - row_facet = row_facet, - col_facet = col_facet - ) - ans <- module( label = label, - server = srv_g_scatterplot, - ui = ui_g_scatterplot, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - table_dec = table_dec, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + server = srv_g_scatterplot.picks, + ui = ui_g_scatterplot.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplot.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplot.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(x, y, color_by, size_by, row_facet, col_facet)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot module -ui_g_scatterplot <- function(id, ...) { - args <- list(...) +ui_g_scatterplot.picks <- function(id, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + alpha, + shape, + color, + size, + rotate_xaxis_labels, + max_deg, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - is_single_dataset_value <- teal.transform::is_single_dataset( - args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet - ) - tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( - teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), - teal::ui_brush_filter(ns("brush_filter")) + teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value - ), - checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_x"), "'] == true"), - radioButtons( - ns("log_x_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x), + checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_x"), "'] == true"), + radioButtons( + ns("log_x_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) ) ), - teal.transform::data_extract_ui( - id = ns("y"), - label = "Y variable", - data_extract_spec = args$y, - is_single_dataset = is_single_dataset_value - ), - checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_y"), "'] == true"), - radioButtons( - ns("log_y_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + teal::teal_nav_item( + label = tags$strong("Y variable"), + teal.transform::module_input_ui(id = ns("y"), spec = y), + checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_y"), "'] == true"), + radioButtons( + ns("log_y_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) ) ), - if (!is.null(args$color_by)) { - teal.transform::data_extract_ui( - id = ns("color_by"), - label = "Color by variable", - data_extract_spec = args$color_by, - is_single_dataset = is_single_dataset_value + if (!is.null(color_by)) { + teal::teal_nav_item( + label = tags$strong("Color by:"), + teal.transform::module_input_ui(id = ns("color_by"), spec = color_by) ) }, - if (!is.null(args$size_by)) { - teal.transform::data_extract_ui( - id = ns("size_by"), - label = "Size by variable", - data_extract_spec = args$size_by, - is_single_dataset = is_single_dataset_value + if (!is.null(size_by)) { + teal::teal_nav_item( + label = tags$strong("Size by:"), + teal.transform::module_input_ui(id = ns("size_by"), spec = size_by) ) }, - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(row_facet)) { + teal::teal_nav_item( + label = tags$strong("Row facetting"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) ) }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(col_facet)) { + teal::teal_nav_item( + label = tags$strong("Column facetting"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) ) }, - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), teal.widgets::optionalSelectInput( inputId = ns("shape"), label = "Points shape:", - choices = args$shape, - selected = args$shape[1], + choices = shape, + selected = shape[1], multiple = FALSE ), colourpicker::colourInput(ns("color"), "Points color:", "black"), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE, step = .1), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), checkboxInput(ns("add_density"), "Add marginal density", value = FALSE), checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE), shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")), - teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)), + teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(max_deg)), shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)), teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE), shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)), @@ -479,14 +482,14 @@ ui_g_scatterplot <- function(id, ...) { ns("label_size"), "Stats font size", min = 3, max = 10, value = 5, ticks = FALSE, step = .1 ), - if (!is.null(args$row_facet) || !is.null(args$col_facet)) { + if (!is.null(row_facet) || !is.null(col_facet)) { checkboxInput(ns("free_scales"), "Free scales", value = FALSE) }, selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -495,38 +498,42 @@ ui_g_scatterplot <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) ) } # Server function for the scatterplot module -srv_g_scatterplot <- function(id, - data, - x, - y, - color_by, - size_by, - row_facet, - col_facet, - plot_height, - plot_width, - table_dec, - ggplot2_args, - decorators) { +srv_g_scatterplot.picks <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - data_extract <- list( - x = x, - y = y, - color_by = color_by, - size_by = size_by, - row_facet = row_facet, - col_facet = col_facet + + selectors <- teal.transform::module_input_srv( + spec = list( + x = x, + y = y, + color_by = color_by, + size_by = size_by, + row_facet = row_facet, + col_facet = col_facet + ), + data = data ) rule_diff <- function(other) { @@ -540,73 +547,81 @@ srv_g_scatterplot <- function(id, } } - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - x = ~ if (length(.) != 1) "Please select exactly one x var.", - y = ~ if (length(.) != 1) "Please select exactly one y var.", - color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", - size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("row_facet") - ) - ) + validates <- list( + x = ~ if (length(.) != 1) "Please select exactly one x var.", + y = ~ if (length(.) != 1) "Please select exactly one y var.", + color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", + size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("row_facet") + ), + add_density = ~ if ( + isTRUE(.) && + ( + length(selector_list()$row_facet()$select) > 0L || + length(selector_list()$col_facet()$select) > 0L + ) + ) { + "Cannot add marginal density when Row or Column facetting has been selected" + } ) - iv_r <- reactive({ - iv_facet <- shinyvalidate::InputValidator$new() - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - iv_facet <- shinyvalidate::InputValidator$new() - iv_facet$add_rule("add_density", ~ if ( - isTRUE(.) && - ( - length(selector_list()$row_facet()$select) > 0L || - length(selector_list()$col_facet()$select) > 0L - ) - ) { - "Cannot add marginal density when Row or Column facetting has been selected" - }) - iv_facet$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data, - merge_function = "dplyr::inner_join" - ) - qenv <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- c( - teal.reporter::teal_card("# Scatter Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes - }) anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) > 0, + message = "A `x` variable needs to be selected." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) > 0, + message = "A `y` variable needs to be selected." + ) + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = !any(selectors$x()$variables$selected %in% selectors$y()$variables$selected), + message = "X and Y variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || !is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." + ) + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Scatter Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + obj |> + teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) trend_line_is_applicable <- reactive({ - ANL <- merged$anl_q_r()[["ANL"]] - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) + anl <- anl_merged_q()[["anl"]] + x_var <- teal.transform::map_merged(selectors)$x$variables + y_var <- teal.transform::map_merged(selectors)$y$variables + length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) }) add_trend_line <- reactive({ @@ -616,9 +631,9 @@ srv_g_scatterplot <- function(id, if (!is.null(color_by)) { observeEvent( - eventExpr = merged$anl_input_r()$columns_source$color_by, + eventExpr = selectors$color_by(), handlerExpr = { - color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) + color_by_var <- teal.transform::map_merged(selectors)$color_by$variables if (length(color_by_var) > 0) { shinyjs::hide("color") } else { @@ -630,21 +645,21 @@ srv_g_scatterplot <- function(id, output$num_na_removed <- renderUI({ if (add_trend_line()) { - ANL <- merged$anl_q_r()[["ANL"]] - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) { + anl <- anl_merged_q()[["anl"]] + x_var <- teal.transform::map_merged(selectors)$x$variables + y_var <- teal.transform::map_merged(selectors)$y$variables + if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) } } }) observeEvent( - eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")], + eventExpr = list(selectors$row_facet(), selectors$col_facet()), handlerExpr = { if ( - length(merged$anl_input_r()$columns_source$col_facet) == 0 && - length(merged$anl_input_r()$columns_source$row_facet) == 0 + length(teal.transform::map_merged(selectors)$row_facet$variables) == 0 && + length(teal.transform::map_merged(selectors)$col_facet$variables) == 0 ) { shinyjs::hide("free_scales") } else { @@ -654,24 +669,14 @@ srv_g_scatterplot <- function(id, ) output_q <- reactive({ - teal::validate_inputs(iv_r(), iv_facet) - - ANL <- merged$anl_q_r()[["ANL"]] - - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) - size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) - row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$row_facet) - } - col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$col_facet) - } + req(anl_merged_q()) + anl <- anl_merged_q()[["anl"]] + x_var <- teal.transform::map_merged(selectors)$x$variables + y_var <- teal.transform::map_merged(selectors)$y$variables + color_by_var <- teal.transform::map_merged(selectors)$color_by$variables + size_by_var <- teal.transform::map_merged(selectors)$size_by$variables + row_facet_var <- teal.transform::map_merged(selectors)$row_facet$variables + col_facet_var <- teal.transform::map_merged(selectors)$col_facet$variables alpha <- input$alpha size <- input$size rotate_xaxis_labels <- input$rotate_xaxis_labels @@ -686,80 +691,84 @@ srv_g_scatterplot <- function(id, log_x <- input$log_x log_y <- input$log_y - validate(need( - length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")), - "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - )) - validate(need( - length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")), - "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - )) + validate_input( + inputId = "row_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[row_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[col_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) if (add_density && length(color_by_var) > 0) { - validate(need( - !is.numeric(ANL[[color_by_var]]), - "Marginal plots cannot be produced when the points are colored by numeric variables. - \n Uncheck the 'Add marginal density' checkbox to display the plot." - )) - validate(need( - !( - inherits(ANL[[color_by_var]], "Date") || - inherits(ANL[[color_by_var]], "POSIXct") || - inherits(ANL[[color_by_var]], "POSIXlt") + validate_input( + inputId = "col_facet-variables-selected", + condition = !is.numeric(anl[[color_by_var]]), + message = paste0( + "Marginal plots cannot be produced when the points are colored by numeric variables.", + "\nUncheck the 'Add marginal density' checkbox to display the plot." + ) + ) + validate_input( + "color_by-variables-selected", + condition = !( + inherits(anl[[color_by_var]], "Date") || + inherits(anl[[color_by_var]], "POSIXct") || + inherits(anl[[color_by_var]], "POSIXlt") ), - "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. - \n Uncheck the 'Add marginal density' checkbox to display the plot." - )) + message = paste0( + "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.", + "\n Uncheck the 'Add marginal density' checkbox to display the plot." + ) + ) } - teal::validate_has_data(ANL[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) if (log_x) { - validate( - need( - is.numeric(ANL[[x_var]]) && all( - ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) - ), - "X variable can only be log transformed if variable is numeric and all values are positive." - ) + validate_input( + "x-variables-selected", + condition = is.numeric(anl[[x_var]]) && all(anl[[x_var]] > 0 | is.na(anl[[x_var]])), + nessage = "X variable can only be log transformed if variable is numeric and all values are positive." ) } if (log_y) { - validate( - need( - is.numeric(ANL[[y_var]]) && all( - ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) - ), - "Y variable can only be log transformed if variable is numeric and all values are positive." - ) + validate_input( + "y-variables-selected", + condition = is.numeric(anl[[y_var]]) && all(anl[[y_var]] > 0 | is.na(anl[[y_var]])), + message = "Y variable can only be log transformed if variable is numeric and all values are positive." ) } facet_cl <- facet_ggplot_call( - row_facet_name, - col_facet_name, + row_facet_var, + col_facet_var, free_x_scales = isTRUE(input$free_scales), free_y_scales = isTRUE(input$free_scales) ) point_sizes <- if (length(size_by_var) > 0) { - validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) + validate(need(is.numeric(anl[[size_by_var]]), "Variable to size by must be numeric")) substitute( - expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), + expr = size * anl[[size_by_var]] / max(anl[[size_by_var]], na.rm = TRUE), env = list(size = size, size_by_var = size_by_var) ) } else { size } - plot_q <- merged$anl_q_r() + plot_q <- anl_merged_q() if (log_x) { log_x_fn <- input$log_x_base plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), + expr = anl[, log_x_var] <- log_x_fn(anl[, x_var]), env = list( x_var = x_var, log_x_fn = as.name(log_x_fn), @@ -774,7 +783,7 @@ srv_g_scatterplot <- function(id, plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), + expr = anl[, log_y_var] <- log_y_fn(anl[, y_var]), env = list( y_var = y_var, log_y_fn = as.name(log_y_fn), @@ -786,19 +795,19 @@ srv_g_scatterplot <- function(id, pre_pro_anl <- if (input$show_count) { paste0( - "ANL %>% dplyr::group_by(", + "anl %>% dplyr::group_by(", paste( c( - if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var, - row_facet_name, - col_facet_name + if (length(color_by_var) > 0 && inherits(anl[[color_by_var]], c("factor", "character"))) color_by_var, + row_facet_var, + col_facet_var ), collapse = ", " ), ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" ) } else { - "ANL" + "anl" } plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) @@ -903,11 +912,11 @@ srv_g_scatterplot <- function(id, shinyjs::show("ci") shinyjs::show("show_form") shinyjs::show("show_r2") - if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) { + if (nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)])) > 0) { plot_q <- teal.code::eval_code( plot_q, substitute( - expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), + expr = anl <- dplyr::filter(anl, !is.na(x_var) & !is.na(y_var)), env = list(x_var = as.name(x_var), y_var = as.name(y_var)) ) ) @@ -952,13 +961,13 @@ srv_g_scatterplot <- function(id, y_label <- varname_w_label( y_var, - ANL, + anl, prefix = if (log_y) paste(log_y_fn, "(") else NULL, suffix = if (log_y) ")" else NULL ) x_label <- varname_w_label( x_var, - ANL, + anl, prefix = if (log_x) paste(log_x_fn, "(") else NULL, suffix = if (log_x) ")" else NULL ) @@ -1044,7 +1053,7 @@ srv_g_scatterplot <- function(id, validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) } - merged_data <- isolate(output_q()[["ANL"]]) + merged_data <- isolate(output_q()[["anl"]]) brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) numeric_cols <- names(brushed_df)[ diff --git a/R/tm_g_scatterplot_old.R b/R/tm_g_scatterplot_old.R new file mode 100644 index 000000000..64d4269e0 --- /dev/null +++ b/R/tm_g_scatterplot_old.R @@ -0,0 +1,840 @@ +#' @export +tm_g_scatterplot.default <- function(label = "Scatterplot", + x, + y, + color_by = NULL, + size_by = NULL, + row_facet = NULL, + col_facet = NULL, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_g_scatterplot") + + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) + if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + if (is.double(max_deg)) max_deg <- as.integer(max_deg) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(x, types = "data_extract_spec") + checkmate::assert_list(y, types = "data_extract_spec") + checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) + + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(row_facet) + + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(col_facet) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + if (length(alpha) == 1) { + checkmate::assert_numeric(alpha, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(alpha, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(alpha[1], lower = alpha[2], upper = alpha[3], .var.name = "alpha") + } + + checkmate::assert_character(shape) + + if (length(size) == 1) { + checkmate::assert_numeric(size, any.missing = FALSE, finite = TRUE) + } else { + checkmate::assert_numeric(size, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(size[1], lower = size[2], upper = size[3], .var.name = "size") + } + + checkmate::assert_int(max_deg, lower = 1L) + checkmate::assert_flag(rotate_xaxis_labels) + ggtheme <- match.arg(ggtheme) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + checkmate::assert_scalar(table_dec) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + assert_decorators(decorators, "plot") + + # End of assertions + + # Make UI args + args <- as.list(environment()) + + data_extract_list <- list( + x = x, + y = y, + color_by = color_by, + size_by = size_by, + row_facet = row_facet, + col_facet = col_facet + ) + + ans <- module( + label = label, + server = srv_g_scatterplot.default, + ui = ui_g_scatterplot.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + table_dec = table_dec, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(data_extract_list) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the scatterplot module +ui_g_scatterplot.default <- function(id, ...) { + args <- list(...) + ns <- NS(id) + is_single_dataset_value <- teal.transform::is_single_dataset( + args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet + ) + + tagList( + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), + teal::ui_brush_filter(ns("brush_filter")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]), + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value + ), + checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_x"), "'] == true"), + radioButtons( + ns("log_x_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) + ), + teal.transform::data_extract_ui( + id = ns("y"), + label = "Y variable", + data_extract_spec = args$y, + is_single_dataset = is_single_dataset_value + ), + checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_y"), "'] == true"), + radioButtons( + ns("log_y_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) + ), + if (!is.null(args$color_by)) { + teal.transform::data_extract_ui( + id = ns("color_by"), + label = "Color by variable", + data_extract_spec = args$color_by, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$size_by)) { + teal.transform::data_extract_ui( + id = ns("size_by"), + label = "Size by variable", + data_extract_spec = args$size_by, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value + ) + }, + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSelectInput( + inputId = ns("shape"), + label = "Points shape:", + choices = args$shape, + selected = args$shape[1], + multiple = FALSE + ), + colourpicker::colourInput(ns("color"), "Points color:", "black"), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + checkboxInput(ns("add_density"), "Add marginal density", value = FALSE), + checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), + checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE), + shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")), + teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)), + shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)), + teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE), + shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)), + shinyjs::hidden(checkboxInput(ns("show_r2"), "Show adj-R Squared", value = TRUE)), + uiOutput(ns("num_na_removed")), + tags$div( + id = ns("label_pos"), + tags$div(tags$strong("Stats position")), + tags$div(style = "display: inline-block; width: 70%;", helpText("Left")), + tags$div( + style = "display: inline-block; width: 70%;", + teal.widgets::optionalSliderInput( + ns("pos"), + label = NULL, + min = 0, max = 1, value = .99, ticks = FALSE, step = .01 + ) + ), + tags$div(style = "display: inline-block; width: 10%;", helpText("Right")) + ), + teal.widgets::optionalSliderInput( + ns("label_size"), "Stats font size", + min = 3, max = 10, value = 5, ticks = FALSE, step = .1 + ), + if (!is.null(args$row_facet) || !is.null(args$col_facet)) { + checkboxInput(ns("free_scales"), "Free scales", value = FALSE) + }, + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) + ) +} + +# Server function for the scatterplot module +srv_g_scatterplot.default <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + data_extract <- list( + x = x, + y = y, + color_by = color_by, + size_by = size_by, + row_facet = row_facet, + col_facet = col_facet + ) + + rule_diff <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + x = ~ if (length(.) != 1) "Please select exactly one x var.", + y = ~ if (length(.) != 1) "Please select exactly one y var.", + color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", + size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("row_facet") + ) + ) + ) + + iv_r <- reactive({ + iv_facet <- shinyvalidate::InputValidator$new() + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + iv_facet <- shinyvalidate::InputValidator$new() + iv_facet$add_rule("add_density", ~ if ( + isTRUE(.) && + ( + length(selector_list()$row_facet()$select) > 0L || + length(selector_list()$col_facet()$select) > 0L + ) + ) { + "Cannot add marginal density when Row or Column facetting has been selected" + }) + iv_facet$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data, + merge_function = "dplyr::inner_join" + ) + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Scatter Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + }) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + trend_line_is_applicable <- reactive({ + ANL <- merged$anl_q_r()[["ANL"]] + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) + }) + + add_trend_line <- reactive({ + smoothing_degree <- as.integer(input$smoothing_degree) + trend_line_is_applicable() && length(smoothing_degree) > 0 + }) + + if (!is.null(color_by)) { + observeEvent( + eventExpr = merged$anl_input_r()$columns_source$color_by, + handlerExpr = { + color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) + if (length(color_by_var) > 0) { + shinyjs::hide("color") + } else { + shinyjs::show("color") + } + } + ) + } + + output$num_na_removed <- renderUI({ + if (add_trend_line()) { + ANL <- merged$anl_q_r()[["ANL"]] + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) { + tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) + } + } + }) + + observeEvent( + eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")], + handlerExpr = { + if ( + length(merged$anl_input_r()$columns_source$col_facet) == 0 && + length(merged$anl_input_r()$columns_source$row_facet) == 0 + ) { + shinyjs::hide("free_scales") + } else { + shinyjs::show("free_scales") + } + } + ) + + output_q <- reactive({ + teal::validate_inputs(iv_r(), iv_facet) + + ANL <- merged$anl_q_r()[["ANL"]] + + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) + size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) + row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$row_facet) + } + col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$col_facet) + } + alpha <- input$alpha + size <- input$size + rotate_xaxis_labels <- input$rotate_xaxis_labels + add_density <- input$add_density + ggtheme <- input$ggtheme + rug_plot <- input$rug_plot + color <- input$color + shape <- `if`(is.null(input$shape) || identical(input$shape, ""), "circle", input$shape) + smoothing_degree <- as.integer(input$smoothing_degree) + ci <- input$ci + + log_x <- input$log_x + log_y <- input$log_y + + validate(need( + length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")), + "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + )) + validate(need( + length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")), + "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + )) + + if (add_density && length(color_by_var) > 0) { + validate(need( + !is.numeric(ANL[[color_by_var]]), + "Marginal plots cannot be produced when the points are colored by numeric variables. + \n Uncheck the 'Add marginal density' checkbox to display the plot." + )) + validate(need( + !( + inherits(ANL[[color_by_var]], "Date") || + inherits(ANL[[color_by_var]], "POSIXct") || + inherits(ANL[[color_by_var]], "POSIXlt") + ), + "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. + \n Uncheck the 'Add marginal density' checkbox to display the plot." + )) + } + + teal::validate_has_data(ANL[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) + + if (log_x) { + validate( + need( + is.numeric(ANL[[x_var]]) && all( + ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) + ), + "X variable can only be log transformed if variable is numeric and all values are positive." + ) + ) + } + if (log_y) { + validate( + need( + is.numeric(ANL[[y_var]]) && all( + ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) + ), + "Y variable can only be log transformed if variable is numeric and all values are positive." + ) + ) + } + + facet_cl <- facet_ggplot_call( + row_facet_name, + col_facet_name, + free_x_scales = isTRUE(input$free_scales), + free_y_scales = isTRUE(input$free_scales) + ) + + point_sizes <- if (length(size_by_var) > 0) { + validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) + substitute( + expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), + env = list(size = size, size_by_var = size_by_var) + ) + } else { + size + } + + plot_q <- merged$anl_q_r() + + if (log_x) { + log_x_fn <- input$log_x_base + plot_q <- teal.code::eval_code( + object = plot_q, + code = substitute( + expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), + env = list( + x_var = x_var, + log_x_fn = as.name(log_x_fn), + log_x_var = paste0(log_x_fn, "_", x_var) + ) + ) + ) + } + + if (log_y) { + log_y_fn <- input$log_y_base + plot_q <- teal.code::eval_code( + object = plot_q, + code = substitute( + expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), + env = list( + y_var = y_var, + log_y_fn = as.name(log_y_fn), + log_y_var = paste0(log_y_fn, "_", y_var) + ) + ) + ) + } + + pre_pro_anl <- if (input$show_count) { + paste0( + "ANL %>% dplyr::group_by(", + paste( + c( + if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var, + row_facet_name, + col_facet_name + ), + collapse = ", " + ), + ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" + ) + } else { + "ANL" + } + + plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) + + plot_call <- if (length(color_by_var) == 0) { + substitute( + expr = plot_call + + ggplot2::aes(x = x_name, y = y_name) + + ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value, color = color_value), + env = list( + plot_call = plot_call, + x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), + y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), + alpha_value = alpha, + point_sizes = point_sizes, + shape_value = shape, + color_value = color + ) + ) + } else { + substitute( + expr = plot_call + + ggplot2::aes(x = x_name, y = y_name, color = color_by_var_name) + + ggplot2::geom_point(alpha = alpha_value, size = point_sizes, shape = shape_value), + env = list( + plot_call = plot_call, + x_name = if (log_x) as.name(paste0(log_x_fn, "_", x_var)) else as.name(x_var), + y_name = if (log_y) as.name(paste0(log_y_fn, "_", y_var)) else as.name(y_var), + color_by_var_name = as.name(color_by_var), + alpha_value = alpha, + point_sizes = point_sizes, + shape_value = shape + ) + ) + } + + if (rug_plot) plot_call <- substitute(expr = plot_call + geom_rug(), env = list(plot_call = plot_call)) + + plot_label_generator <- function(rhs_formula = quote(y ~ 1), + show_form = input$show_form, + show_r2 = input$show_r2, + show_count = input$show_count, + pos = input$pos, + label_size = input$label_size) { + stopifnot(sum(show_form, show_r2, show_count) >= 1) + aes_label <- paste0( + "aes(", + if (show_count) "n = n, ", + "label = ", + if (sum(show_form, show_r2, show_count) > 1) "paste(", + paste( + c( + if (show_form) "stat(eq.label)", + if (show_r2) "stat(adj.rr.label)", + if (show_count) "paste('N ~`=`~', n)" + ), + collapse = ", " + ), + if (sum(show_form, show_r2, show_count) > 1) ", sep = '*\", \"*'))" else ")" + ) + label_geom <- substitute( + expr = ggpmisc::stat_poly_eq( + mapping = aes_label, + formula = rhs_formula, + parse = TRUE, + label.x = pos, + size = label_size + ), + env = list( + rhs_formula = rhs_formula, + pos = pos, + aes_label = str2lang(aes_label), + label_size = label_size + ) + ) + substitute( + expr = plot_call + label_geom, + env = list( + plot_call = plot_call, + label_geom = label_geom + ) + ) + } + + if (trend_line_is_applicable()) { + shinyjs::hide("line_msg") + shinyjs::show("smoothing_degree") + if (!add_trend_line()) { + shinyjs::hide("ci") + shinyjs::hide("color_sub") + shinyjs::hide("show_form") + shinyjs::hide("show_r2") + if (input$show_count) { + plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + } else { + shinyjs::show("ci") + shinyjs::show("show_form") + shinyjs::show("show_r2") + if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) { + plot_q <- teal.code::eval_code( + plot_q, + substitute( + expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), + env = list(x_var = as.name(x_var), y_var = as.name(y_var)) + ) + ) + } + rhs_formula <- substitute( + expr = y ~ poly(x, smoothing_degree, raw = TRUE), + env = list(smoothing_degree = smoothing_degree) + ) + if (input$show_form || input$show_r2 || input$show_count) { + plot_call <- plot_label_generator(rhs_formula = rhs_formula) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + plot_call <- substitute( + expr = plot_call + ggplot2::geom_smooth(formula = rhs_formula, se = TRUE, level = ci, method = "lm"), + env = list(plot_call = plot_call, rhs_formula = rhs_formula, ci = ci) + ) + } + } else { + shinyjs::hide("smoothing_degree") + shinyjs::hide("ci") + shinyjs::hide("color_sub") + shinyjs::hide("show_form") + shinyjs::hide("show_r2") + if (input$show_count) { + plot_call <- plot_label_generator(show_form = FALSE, show_r2 = FALSE) + shinyjs::show("label_pos") + shinyjs::show("label_size") + } else { + shinyjs::hide("label_pos") + shinyjs::hide("label_size") + } + shinyjs::show("line_msg") + } + + if (!is.null(facet_cl)) { + plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) + } + + y_label <- varname_w_label( + y_var, + ANL, + prefix = if (log_y) paste(log_y_fn, "(") else NULL, + suffix = if (log_y) ")" else NULL + ) + x_label <- varname_w_label( + x_var, + ANL, + prefix = if (log_x) paste(log_x_fn, "(") else NULL, + suffix = if (log_x) ")" else NULL + ) + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list(y = y_label, x = x_label), + theme = list(legend.position = "bottom") + ) + + if (rotate_xaxis_labels) { + dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(all_ggplot2_args, ggtheme = ggtheme) + + + if (add_density) { + plot_call <- substitute( + expr = ggExtra::ggMarginal( + plot_call + labs + ggthemes + themes, + type = "density", + groupColour = group_colour + ), + env = list( + plot_call = plot_call, + group_colour = if (length(color_by_var) > 0) TRUE else FALSE, + labs = parsed_ggplot2_args$labs, + ggthemes = parsed_ggplot2_args$ggtheme, + themes = parsed_ggplot2_args$theme + ) + ) + } else { + plot_call <- substitute( + expr = plot_call + + labs + + ggthemes + + themes, + env = list( + plot_call = plot_call, + labs = parsed_ggplot2_args$labs, + ggthemes = parsed_ggplot2_args$ggtheme, + themes = parsed_ggplot2_args$theme + ) + ) + } + + plot_call <- substitute(expr = plot <- plot_call, env = list(plot_call = plot_call)) + + teal.reporter::teal_card(plot_q) <- c(teal.reporter::teal_card(plot_q), "## Plot") + teal.code::eval_code(plot_q, plot_call) + }) + + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "scatter_plot", + plot_r = plot_r, + height = plot_height, + width = plot_width, + brushing = TRUE, + click = TRUE + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) + + output$data_table <- DT::renderDataTable({ + plot_brush <- pws$brush() + + if (!is.null(plot_brush)) { + validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) + } + + merged_data <- isolate(output_q()[["ANL"]]) + + brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) + numeric_cols <- names(brushed_df)[ + vapply(brushed_df, function(x) is.numeric(x) && !is.integer(x), FUN.VALUE = logical(1)) + ] + + if (length(numeric_cols) > 0) { + DT::formatRound( + DT::datatable(brushed_df, + rownames = FALSE, + options = list(scrollX = TRUE, pageLength = input$data_table_rows) + ), + numeric_cols, + table_dec + ) + } else { + DT::datatable(brushed_df, rownames = FALSE, options = list(scrollX = TRUE, pageLength = input$data_table_rows)) + } + }) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "R Code for scatterplot" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 25187f35f..45e4bd909 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -197,14 +197,33 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", post_output = NULL, transformators = list(), decorators = list()) { + # `object` just determines a method, but original `variables` is passed + UseMethod("tm_g_scatterplotmatrix", object = variables[[1]]) +} + +#' @export +tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", + variables = list( + picks( + datasets(), + variables(selected = 1:5, multiple = TRUE) + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplotmatrix") - # Normalize the parameters - if (inherits(variables, "data_extract_spec")) variables <- list(variables) + if (is.null(names(variables))) { + names(variables) <- sprintf("pick_%s", seq_along(variables)) + } # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(variables, types = "data_extract_spec") + checkmate::assert_list(variables, types = "picks", names = "named") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -220,31 +239,30 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", assert_decorators(decorators, "plot") # End of assertions - # Make UI args args <- as.list(environment()) - ans <- module( label = label, - server = srv_g_scatterplotmatrix, - ui = ui_g_scatterplotmatrix, - ui_args = args, - server_args = list( - variables = variables, - plot_height = plot_height, - plot_width = plot_width, - decorators = decorators - ), + ui = ui_g_scatterplotmatrix.picks, + server = srv_g_scatterplotmatrix.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplotmatrix.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplotmatrix.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(variables) + datanames = { + datanames <- datanames(variables) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot matrix module -ui_g_scatterplotmatrix <- function(id, ...) { - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) +ui_g_scatterplotmatrix.picks <- function(id, + variables, + pre_output, + post_output, + decorators) { + checkmate::assert_list(variables, "picks", names = "named") ns <- NS(id) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -254,15 +272,15 @@ ui_g_scatterplotmatrix <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args$variables), - teal.transform::data_extract_ui( - id = ns("variables"), - label = "Variables", - data_extract_spec = args$variables, - is_single_dataset = is_single_dataset_value + tagList( + lapply(names(variables), function(id) { + teal::teal_nav_item( + teal.transform::module_input_ui(id = ns(id), spec = variables[[id]]) + ) + }) ), tags$hr(), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -291,66 +309,60 @@ ui_g_scatterplotmatrix <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the scatterplot matrix module -srv_g_scatterplotmatrix <- function(id, - data, - variables, - plot_height, - plot_width, - decorators) { +srv_g_scatterplotmatrix.picks <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(variables = variables), - datasets = data, - select_validation_rule = list( - variables = ~ if (length(.) <= 1) "Please select at least 2 columns." - ) + selectors <- teal.transform::module_input_srv( + spec = variables, + data = data ) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) + anl_merged_q <- reactive({ + obj <- req(data()) + + input_ids <- sprintf("%s-variables-selected", names(variables)) + selected_variables <- unname(unlist(lapply(selectors, function(selector) selector()$variables$selected))) + validate_input( + inputId = input_ids, # validate all inputs where variable can be selected + condition = length(selected_variables) > 1, + message = "Please select at least 2 columns" + ) - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list - ) - anl_merged_q <- reactive({ - req(anl_merged_input()) - obj <- data() teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Scatter Plot Matrix"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - qenv <- teal.code::eval_code(obj, 'library("dplyr");library("lattice")') # nolint quotes - teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr)) + obj |> + teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint + teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q + merge_vars <- reactive( + unname(unlist(lapply(map_merged(selectors), `[[`, "variables"))) ) + # plot output_q <- reactive({ - teal::validate_inputs(iv_r()) - - qenv <- merged$anl_q_r() - ANL <- qenv[["ANL"]] - - cols_names <- merged$anl_input_r()$columns_source$variables + qenv <- req(anl_merged_q()) + anl <- qenv[["anl"]] + cols_names <- merge_vars() alpha <- input$alpha cex <- input$cex add_cor <- input$cor @@ -363,19 +375,19 @@ srv_g_scatterplotmatrix <- function(id, "na.fail" } - teal::validate_has_data(ANL, 10) - teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) # get labels and proper variable names - varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) + varnames <- varname_w_label(cols_names, anl, wrap_width = 20) # check character columns. If any, then those are converted to factors - check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { qenv <- teal.code::eval_code( qenv, substitute( - expr = ANL <- ANL[, cols_names] %>% + expr = anl <- anl[, cols_names] %>% dplyr::mutate_if(is.character, as.factor) %>% droplevels(), env = list(cols_names = cols_names) @@ -385,7 +397,7 @@ srv_g_scatterplotmatrix <- function(id, qenv <- teal.code::eval_code( qenv, substitute( - expr = ANL <- ANL[, cols_names] %>% + expr = anl <- anl[, cols_names] %>% droplevels(), env = list(cols_names = cols_names) ) @@ -406,7 +418,7 @@ srv_g_scatterplotmatrix <- function(id, substitute( expr = { plot <- lattice::splom( - ANL, + anl, varnames = varnames_value, panel = function(x, y, ...) { lattice::panel.splom(x = x, y = y, ...) @@ -448,7 +460,7 @@ srv_g_scatterplotmatrix <- function(id, substitute( expr = { plot <- lattice::splom( - ANL, + anl, varnames = varnames_value, pch = 16, alpha = alpha_value, @@ -483,11 +495,9 @@ srv_g_scatterplotmatrix <- function(id, # show a message if conversion to factors took place output$message <- renderText({ - req(iv_r()$is_valid()) - req(selector_list()$variables()) - ANL <- merged$anl_q_r()[["ANL"]] - cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) - check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + cols_names <- req(merge_vars()) + anl <- anl_merged_q()[["anl"]] + check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { is_single <- sum(check_char) == 1 paste( diff --git a/R/tm_g_scatterplotmatrix_old.R b/R/tm_g_scatterplotmatrix_old.R new file mode 100644 index 000000000..e7822318e --- /dev/null +++ b/R/tm_g_scatterplotmatrix_old.R @@ -0,0 +1,402 @@ +#' @export +tm_g_scatterplotmatrix.default <- function(label = "Scatterplot Matrix", + variables, + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_scatterplotmatrix") + + # Normalize the parameters + if (inherits(variables, "data_extract_spec")) variables <- list(variables) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(variables, types = "data_extract_spec") + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_g_scatterplotmatrix.default, + ui = ui_g_scatterplotmatrix.default, + ui_args = args, + server_args = list( + variables = variables, + plot_height = plot_height, + plot_width = plot_width, + decorators = decorators + ), + transformators = transformators, + datanames = teal.transform::get_extract_datanames(variables) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the scatterplot matrix module +ui_g_scatterplotmatrix.default <- function(id, ...) { + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("message")), + tags$br(), + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args$variables), + teal.transform::data_extract_ui( + id = ns("variables"), + label = "Variables", + data_extract_spec = args$variables, + is_single_dataset = is_single_dataset_value + ), + tags$hr(), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + sliderInput( + ns("alpha"), "Opacity:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("cex"), "Points size:", + min = 0.2, max = 3, + step = .05, value = .65, ticks = FALSE + ), + checkboxInput(ns("cor"), "Add Correlation", value = FALSE), + radioButtons( + ns("cor_method"), "Select Correlation Method", + choiceNames = c("Pearson", "Kendall", "Spearman"), + choiceValues = c("pearson", "kendall", "spearman"), + inline = TRUE + ), + checkboxInput(ns("cor_na_omit"), "Omit Missing Values", value = TRUE) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = args$pre_output, + post_output = args$post_output + ) +} + +# Server function for the scatterplot matrix module +srv_g_scatterplotmatrix.default <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(variables = variables), + datasets = data, + select_validation_rule = list( + variables = ~ if (length(.) <= 1) "Please select at least 2 columns." + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list + ) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + obj <- data() + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Scatter Plot Matrix"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + qenv <- teal.code::eval_code(obj, 'library("dplyr");library("lattice")') # nolint quotes + teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + # plot + output_q <- reactive({ + teal::validate_inputs(iv_r()) + + qenv <- merged$anl_q_r() + ANL <- qenv[["ANL"]] + + cols_names <- merged$anl_input_r()$columns_source$variables + alpha <- input$alpha + cex <- input$cex + add_cor <- input$cor + cor_method <- input$cor_method + cor_na_omit <- input$cor_na_omit + + cor_na_action <- if (isTruthy(cor_na_omit)) { + "na.omit" + } else { + "na.fail" + } + + teal::validate_has_data(ANL, 10) + teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) + + # get labels and proper variable names + varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) + + # check character columns. If any, then those are converted to factors + check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + if (any(check_char)) { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL <- ANL[, cols_names] %>% + dplyr::mutate_if(is.character, as.factor) %>% + droplevels(), + env = list(cols_names = cols_names) + ) + ) + } else { + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL <- ANL[, cols_names] %>% + droplevels(), + env = list(cols_names = cols_names) + ) + ) + } + + + # create plot + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") + + if (add_cor) { + shinyjs::show("cor_method") + shinyjs::show("cor_use") + shinyjs::show("cor_na_omit") + + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + plot <- lattice::splom( + ANL, + varnames = varnames_value, + panel = function(x, y, ...) { + lattice::panel.splom(x = x, y = y, ...) + cpl <- lattice::current.panel.limits() + lattice::panel.text( + mean(cpl$xlim), + mean(cpl$ylim), + get_scatterplotmatrix_stats( + x, + y, + .f = stats::cor.test, + .f_args = list(method = cor_method, na.action = cor_na_action) + ), + alpha = 0.6, + fontsize = 18, + fontface = "bold" + ) + }, + pch = 16, + alpha = alpha_value, + cex = cex_value + ) + }, + env = list( + varnames_value = varnames, + cor_method = cor_method, + cor_na_action = cor_na_action, + alpha_value = alpha, + cex_value = cex + ) + ) + ) + } else { + shinyjs::hide("cor_method") + shinyjs::hide("cor_use") + shinyjs::hide("cor_na_omit") + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + plot <- lattice::splom( + ANL, + varnames = varnames_value, + pch = 16, + alpha = alpha_value, + cex = cex_value + ) + }, + env = list(varnames_value = varnames, alpha_value = alpha, cex_value = cex) + ) + ) + } + qenv + }) + + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) + + # show a message if conversion to factors took place + output$message <- renderText({ + req(iv_r()$is_valid()) + req(selector_list()$variables()) + ANL <- merged$anl_q_r()[["ANL"]] + cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) + check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + if (any(check_char)) { + is_single <- sum(check_char) == 1 + paste( + "Character", + ifelse(is_single, "variable", "variables"), + paste0("(", paste(cols_names[check_char], collapse = ", "), ")"), + ifelse(is_single, "was", "were"), + "converted to", + ifelse(is_single, "factor.", "factors.") + ) + } else { + "" + } + }) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Show R Code for Scatterplotmatrix" + ) + decorated_output_dims_q + }) +} + +#' Get stats for x-y pairs in scatterplot matrix +#' +#' Uses [stats::cor.test()] per default for all numerical input variables and converts results +#' to character vector. +#' Could be extended if different stats for different variable types are needed. +#' Meant to be called from [lattice::panel.text()]. +#' +#' Presently we need to use a formula input for `stats::cor.test` because +#' `na.fail` only gets evaluated when a formula is passed (see below). +#' ``` +#' x = c(1,3,5,7,NA) +#' y = c(3,6,7,8,1) +#' stats::cor.test(x, y, na.action = "na.fail") +#' stats::cor.test(~ x + y, na.action = "na.fail") +#' ``` +#' +#' @param x,y (`numeric`) vectors of data values. `x` and `y` must have the same length. +#' @param .f (`function`) function that accepts x and y as formula input `~ x + y`. +#' Default `stats::cor.test`. +#' @param .f_args (`list`) of arguments to be passed to `.f`. +#' @param round_stat (`integer(1)`) optional, number of decimal places to use when rounding the estimate. +#' @param round_pval (`integer(1)`) optional, number of decimal places to use when rounding the p-value. +#' +#' @return Character with stats. For [stats::cor.test()] correlation coefficient and p-value. +#' +#' @examples +#' set.seed(1) +#' x <- runif(25, 0, 1) +#' y <- runif(25, 0, 1) +#' x[c(3, 10, 18)] <- NA +#' +#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) +#' get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( +#' method = "pearson", +#' na.action = na.fail +#' )) +#' +#' @export +#' +get_scatterplotmatrix_stats <- function(x, y, + .f = stats::cor.test, + .f_args = list(), + round_stat = 2, + round_pval = 4) { + if (is.numeric(x) && is.numeric(y)) { + stat <- tryCatch(do.call(.f, c(list(~ x + y), .f_args)), error = function(e) NA) + + if (anyNA(stat)) { + return("NA") + } else if (all(c("estimate", "p.value") %in% names(stat))) { + return(paste( + c( + paste0(names(stat$estimate), ":", round(stat$estimate, round_stat)), + paste0("P:", round(stat$p.value, round_pval)) + ), + collapse = "\n" + )) + } else { + stop("function not supported") + } + } else { + if ("method" %in% names(.f_args)) { + if (.f_args$method == "pearson") { + return("cor:-") + } + if (.f_args$method == "kendall") { + return("tau:-") + } + if (.f_args$method == "spearman") { + return("rho:-") + } + } + return("-") + } +} diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index 176b24cb1..ba6f41952 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -1,9 +1,19 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_scatterplotmatrix.R +% Please edit documentation in R/tm_g_scatterplotmatrix.R, +% R/tm_g_scatterplotmatrix_old.R \name{get_scatterplotmatrix_stats} \alias{get_scatterplotmatrix_stats} \title{Get stats for x-y pairs in scatterplot matrix} \usage{ +get_scatterplotmatrix_stats( + x, + y, + .f = stats::cor.test, + .f_args = list(), + round_stat = 2, + round_pval = 4 +) + get_scatterplotmatrix_stats( x, y, @@ -26,9 +36,16 @@ Default \code{stats::cor.test}.} \item{round_pval}{(\code{integer(1)}) optional, number of decimal places to use when rounding the p-value.} } \value{ +Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. + Character with stats. For \code{\link[stats:cor.test]{stats::cor.test()}} correlation coefficient and p-value. } \description{ +Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results +to character vector. +Could be extended if different stats for different variable types are needed. +Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. + Uses \code{\link[stats:cor.test]{stats::cor.test()}} per default for all numerical input variables and converts results to character vector. Could be extended if different stats for different variable types are needed. @@ -38,6 +55,15 @@ Meant to be called from \code{\link[lattice:llines]{lattice::panel.text()}}. Presently we need to use a formula input for \code{stats::cor.test} because \code{na.fail} only gets evaluated when a formula is passed (see below). +\if{html}{\out{
}}\preformatted{x = c(1,3,5,7,NA) +y = c(3,6,7,8,1) +stats::cor.test(x, y, na.action = "na.fail") +stats::cor.test(~ x + y, na.action = "na.fail") +}\if{html}{\out{
}} + +Presently we need to use a formula input for \code{stats::cor.test} because +\code{na.fail} only gets evaluated when a formula is passed (see below). + \if{html}{\out{
}}\preformatted{x = c(1,3,5,7,NA) y = c(3,6,7,8,1) stats::cor.test(x, y, na.action = "na.fail") @@ -56,4 +82,15 @@ get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( na.action = na.fail )) +set.seed(1) +x <- runif(25, 0, 1) +y <- runif(25, 0, 1) +x[c(3, 10, 18)] <- NA + +get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list(method = "pearson")) +get_scatterplotmatrix_stats(x, y, .f = stats::cor.test, .f_args = list( + method = "pearson", + na.action = na.fail +)) + } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 094febdb4..a3afc9bfc 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -8,7 +8,8 @@ tm_a_regression( label = "Regression Analysis", regressor = picks(datasets(), variables(choices = tidyselect::where(is.numeric), selected = -1, multiple = TRUE)), - response = picks(datasets(), variables(choices = tidyselect::where(is.numeric))), + response = picks(datasets(), variables(choices = tidyselect::where(is.numeric)), + values(selected = tidyselect::everything(), multiple = TRUE)), plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index db4af75df..40501bcd3 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -7,7 +7,8 @@ tm_g_association( label = "Association", ref = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1), values()), + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1), + values(selected = tidyselect::everything(), multiple = TRUE)), vars = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = TRUE), values()), diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 44ce0a985..d3d09a5ec 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -6,8 +6,10 @@ \usage{ tm_g_response( label = "Response Plot", - response, - x, + response = picks(datasets(), variables(choices = teal.transform::is_categorical(min.len + = 2, max.len = 10)), values()), + x = picks(datasets(), variables(choices = teal.transform::is_categorical(min.len = 2, + max.len = 10), selected = 2), values()), row_facet = NULL, col_facet = NULL, coord_flip = FALSE, From eb65be4dcd47bf5c20ab3fadade304fd88daf8f9 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 7 Oct 2025 13:48:17 +0200 Subject: [PATCH 142/158] tmg is using picks --- NAMESPACE | 1 + R/tm_a_pca.R | 277 ++++++++--------- R/tm_a_regression.R | 413 ++++++++++---------------- R/tm_data_table.R | 24 -- R/tm_g_association.R | 150 ++++------ R/tm_g_bivariate.R | 209 ++++++------- R/tm_g_distribution.R | 131 ++++---- R/tm_g_distribution_old.R | 138 --------- R/tm_g_response.R | 96 +++--- R/tm_g_scatterplot.R | 307 +++++++------------ R/tm_g_scatterplot_old.R | 5 +- R/tm_g_scatterplotmatrix.R | 96 +++--- R/tm_outliers.R | 38 +-- R/tm_t_crosstable.R | 345 ++++++++++----------- R/tm_t_crosstable_old.R | 331 +++++++++++++++++++++ R/tm_variable_browser.R | 39 +-- man/srv_decorate_teal_data.Rd | 5 - man/tm_a_pca.Rd | 47 +-- man/tm_a_regression.Rd | 84 ++---- man/tm_data_table.Rd | 15 - man/tm_file_viewer.Rd | 3 - man/tm_front_page.Rd | 15 - man/tm_g_association.Rd | 77 ++--- man/tm_g_bivariate.Rd | 141 +++------ man/tm_g_distribution.Rd | 62 ++-- man/tm_g_distribution.default.Rd | 196 ------------ man/tm_g_response.Rd | 86 +++--- man/tm_g_scatterplot.Rd | 200 +++++-------- man/tm_g_scatterplotmatrix.Rd | 92 +++--- man/tm_missing_data.Rd | 15 - man/tm_outliers.Rd | 52 ++-- man/tm_p_spiderplot.Rd | 6 - man/tm_p_swimlane.Rd | 3 - man/tm_p_waterfall.Rd | 3 - man/tm_rmarkdown.Rd | 12 - man/tm_t_crosstable.Rd | 62 ++-- man/tm_t_reactables.Rd | 15 - man/tm_variable_browser.Rd | 15 - man/validate_input.Rd | 27 -- tests/testthat/helper-testing-depth.R | 2 +- 40 files changed, 1553 insertions(+), 2282 deletions(-) create mode 100644 R/tm_t_crosstable_old.R delete mode 100644 man/tm_g_distribution.default.Rd delete mode 100644 man/validate_input.Rd diff --git a/NAMESPACE b/NAMESPACE index 91ffc338e..852b3de84 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -48,6 +48,7 @@ export(tm_p_swimlane) export(tm_p_waterfall) export(tm_rmarkdown) export(tm_t_crosstable) +export(tm_t_crosstable.default) export(tm_t_reactables) export(tm_variable_browser) import(ggmosaic) diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index c76a93f8c..d490c183f 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -7,8 +7,7 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param dat (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' specifying columns used to compute PCA. +#' @param dat (`picks`) specifying columns used to compute PCA. #' @param font_size (`numeric`) optional, specifies font size. #' It controls the font size for plot titles, axis labels, and legends. #' - If vector of `length == 1` then the font sizes will have a fixed size. @@ -67,16 +66,13 @@ #' modules = modules( #' tm_a_pca( #' "PCA", -#' dat = data_extract_spec( -#' dataname = "USArrests", -#' select = select_spec( -#' choices = variable_choices( -#' data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape") -#' ), +#' dat = picks( +#' datasets("USArrests"), +#' variables( +#' choices = c("Murder", "Assault", "UrbanPop", "Rape"), #' selected = c("Murder", "Assault"), #' multiple = TRUE -#' ), -#' filter = NULL +#' ) #' ) #' ) #' ) @@ -103,17 +99,13 @@ #' data = data, #' modules = modules( #' tm_a_pca( -#' "PCA", -#' dat = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' choices = variable_choices( -#' data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY") -#' ), +#' dat = picks( +#' datasets("ADSL"), +#' variables( +#' choices = c("BMRKR1", "AGE", "EOSDY"), #' selected = c("BMRKR1", "AGE"), #' multiple = TRUE -#' ), -#' filter = NULL +#' ) #' ) #' ) #' ) @@ -125,10 +117,7 @@ #' @export #' tm_a_pca <- function(label = "Principal Component Analysis", - dat = picks( - datasets(), - variables(choices = tidyselect::where(is.numeric), selected = 1:5, multiple = TRUE) - ), + dat, plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -253,7 +242,21 @@ ui_a_pca.picks <- function(id, tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( - uiOutput(ns("all_plots")) + tags$div( + tags$div( + align = "center", + tags$h4("Principal components importance"), + tableOutput(ns("tbl_importance")), + tags$hr() + ), + tags$div( + align = "center", + tags$h4("Eigenvectors"), + tableOutput(ns("tbl_eigenvector")), + tags$hr() + ), + teal.widgets::plot_with_settings_ui(id = ns("pca_plot")) + ) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), @@ -325,12 +328,7 @@ ui_a_pca.picks <- function(id, conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), list( - shinyWidgets::pickerInput( - inputId = ns("response"), - label = "Color by", - choices = NULL, - selected = NULL - ), + shinyWidgets::pickerInput(inputId = ns("response"), label = "Color by", choices = NULL), teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE) ) @@ -374,132 +372,97 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args selectors <- teal.transform::module_input_srv(spec = list(dat = dat), data = data) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule( - "dat", - ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", - ) - iv$add_rule( - "response", - ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", + qenv <- reactive({ + validate_input( + "dat-variables-selected", + length(selectors$dat()$variables$selected) > 1, + "Please select more than 1 variable to perform PCA." ) - }) - iv_extra <- shinyvalidate::InputValidator$new() - iv_extra$add_rule("x_axis", function(value) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (!shinyvalidate::input_provided(value)) { - "Need X axis" - } - } - }) - iv_extra$add_rule("y_axis", function(value) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (!shinyvalidate::input_provided(value)) { - "Need Y axis" - } - } - }) - rule_dupl <- function(...) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (isTRUE(input$x_axis == input$y_axis)) { - "Please choose different X and Y axes." - } - } - } - iv_extra$add_rule("x_axis", rule_dupl) - iv_extra$add_rule("y_axis", rule_dupl) - iv_extra$add_rule("variables", function(value) { - if (identical(input$plot_type, "Circle plot")) { - if (!shinyvalidate::input_provided(value)) { - "Need Original Coordinates" - } - } - }) - iv_extra$add_rule("pc", function(value) { - if (identical(input$plot_type, "Eigenvector plot")) { - if (!shinyvalidate::input_provided(value)) { - "Need PC" - } - } - }) - iv_extra$enable() - - anl_merged_q <- reactive({ - obj <- data() + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Principal Component Analysis"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj %>% - teal.code::eval_code('library("ggplot2");library("dplyr");library("tidyr")') %>% # nolint: quotes - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') }) - selected_variables <- reactive(map_merged(selectors)$dat$variables) - observeEvent(selected_variables(), { - shinyWidgets::updatePickerInput( - inputId = "response", - choices = selected_variables(), - selected = input$response + merged <- merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + anl_merged_q <- merged$data + selected_vars <- reactive(merged$merge_vars()$dat) + + validate_data <- reactive({ + obj <- req(anl_merged_q()) + anl <- obj[["anl"]] + validate_input( + "dat-variables-selected", + condition = sum(stats::complete.cases(anl[selected_vars()])) > 10, + message = "Number of complete cases is less than 10" + ) + validate_input( + "na_action", + condition = input$na_action != "none" | !anyNA(anl[selected_vars()]), + message = paste( + "There are NAs in the dataset. Please deal with them in preprocessing", + "or select \"Drop\" in the NA actions." + ) ) - }) - - validation <- reactive({ - req(anl_merged_q()) - # inputs - keep_cols <- map_merged(selectors)$dat$variables - na_action <- input$na_action standardization <- input$standardization - center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - anl <- anl_merged_q()[["anl"]] - teal::validate_has_data(anl, 10) - validate(need( - na_action != "none" | !anyNA(anl[keep_cols]), - paste( - "There are NAs in the dataset. Please deal with them in preprocessing", - "or select \"Drop\" in the NA actions inside the encodings panel (left)." - ) - )) if (scale) { - not_single <- vapply(anl[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) - - msg <- paste0( - "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", - "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + not_single <- vapply( + anl[selected_vars()], + function(column) length(unique(column)) != 1, + FUN.VALUE = logical(1) + ) + validate_input( + "standarization", + condition = all(not_single), + message = paste0( + "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", + "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + ) ) - validate(need(all(not_single), msg)) } }) + validate_xy_axis <- reactive({ + validate_input( + "x_axis", + condition = input$x_axis != input$y_axis, + message = "Please choose different X and Y axes." + ) + }) + + observeEvent(selected_vars(), { + shinyWidgets::updatePickerInput( + inputId = "response", + choices = selected_vars(), + selected = input$response + ) + }) + computation <- reactive({ - validation() + validate_data() # inputs - keep_cols <- map_merged(selectors)$dat$variables + anl_cols <- selected_vars() na_action <- input$na_action standardization <- input$standardization center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" anl <- anl_merged_q()[["anl"]] - qenv <- within( - anl_merged_q(), - keep_columns <- keep_cols, - keep_cols = keep_cols - ) + qenv <- within(anl_merged_q(), anl_cols <- cols, cols = unname(anl_cols)) if (na_action == "drop") { - qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(keep_columns))) + qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(anl_cols))) } qenv <- within( qenv, - pca <- summary(stats::prcomp(anl[keep_columns], center = center, scale. = scale, retx = TRUE)), + pca <- summary(stats::prcomp(anl[anl_cols], center = center, scale. = scale, retx = TRUE)), center = center, scale = scale ) @@ -524,18 +487,17 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args qenv <- computation() ns <- session$ns - pca <- qenv[["pca"]] chcs_pcs <- colnames(pca$rotation) - chcs_vars <- qenv[["keep_columns"]] + chcs_vars <- qenv$anl_cols tagList( conditionalPanel( condition = sprintf("input['%1$s'] == 'Biplot' || input['%1$s'] == 'Circle plot'", ns("plot_type")), list( - teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), - teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), - teal.widgets::optionalSelectInput( + shinyWidgets::pickerInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), + shinyWidgets::pickerInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), + shinyWidgets::pickerInput( ns("variables"), "Original coordinates", choices = chcs_vars, selected = chcs_vars, multiple = TRUE @@ -548,7 +510,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ), conditionalPanel( condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"), - teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) + shinyWidgets::pickerInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) ) ) }) @@ -629,6 +591,12 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args plot_circle <- function(base_q) { logger::log_debug("srv_a_pca recalculate plot_circle") + validate_xy_axis() + validate_input( + "variables", + condition = length(input$variables) > 0, + message = "Please select Original Coordinates for this visualization." + ) x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -702,9 +670,16 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args plot_biplot <- function(base_q) { logger::log_debug("srv_a_pca recalculate plot_biplot") + validate_xy_axis() + validate_input( + "response", + condition = length(input$response) == 1, + message = "Please select Response variable to see this visualization." + ) qenv <- base_q anl <- qenv[["anl"]] - dat_cols <- map_merged(selectors)$dat$variables + anl_cols <- selected_vars() + resp_col <- input$response x_axis <- input$x_axis y_axis <- input$y_axis @@ -749,7 +724,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args expr = { rot_vars <- rot_vars %>% tibble::column_to_rownames("label") %>% - sweep(1, apply(anl[keep_columns], 2, mean, na.rm = TRUE)) %>% + sweep(1, apply(anl[anl_cols], 2, mean, na.rm = TRUE)) %>% tibble::rownames_to_column("label") %>% dplyr::mutate( xstart = mean(pca$x[, x_axis], na.rm = TRUE), @@ -784,8 +759,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ) dev_labs <- list() } else { - rp_keys <- setdiff(colnames(anl), dat_cols) - response <- anl[[resp_col]] aes_biplot <- substitute( @@ -919,6 +892,11 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args plot_eigenvector <- function(base_q) { logger::log_debug("srv_a_pca recalculate plot_eigenvector") + validate_input( + "pc", + condition = length(input$pc) > 0, + "Please select a Principal Component for this visualization" + ) req(input$pc) pc <- input$pc ggtheme <- input$ggtheme @@ -1007,8 +985,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args function(fun) { reactive({ req(computation()) - teal::validate_inputs(iv_r()) - teal::validate_inputs(iv_extra, header = "Plot settings are required") fun(computation()) }) } @@ -1067,16 +1043,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args digits = 3 ) - output$tbl_importance_ui <- renderUI({ - req("importance" %in% input$tables_display) - tags$div( - align = "center", - tags$h4("Principal components importance"), - tableOutput(session$ns("tbl_importance")), - tags$hr() - ) - }) - output$tbl_eigenvector <- renderTable( expr = { req("eigenvector" %in% input$tables_display, req(computation())) @@ -1090,22 +1056,8 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args output$tbl_eigenvector_ui <- renderUI({ req("eigenvector" %in% input$tables_display) - tags$div( - align = "center", - tags$h4("Eigenvectors"), - tableOutput(session$ns("tbl_eigenvector")), - tags$hr() - ) }) - output$all_plots <- renderUI({ - validation() - tags$div( - uiOutput(session$ns("tbl_importance_ui")), - uiOutput(session$ns("tbl_eigenvector_ui")), - teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot")) - ) - }) # Render R code. source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) @@ -1118,3 +1070,8 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args decorated_output_dims_q }) } + + +ui_elbow <- function(id) { + ns <- NS(id) +} diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index cd35710e4..086b11ffa 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -10,11 +10,15 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param regressor (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Regressor variables from an incoming dataset with filtering and selecting. -#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Response variables from an incoming dataset with filtering and selecting. -#' @param default_outlier_label (`character`) optional, default column selected to label outliers. +#' @param regressor (`picks`) Specification for regressor variables selection. +#' Created using [teal.transform::picks()], which allows selecting variables +#' to use as regressors in the regression model. `variables(multiple = TRUE)` allowed. +#' @param response (`picks`) Specification for response variable selection. +#' Created using [teal.transform::picks()], which allows selecting a single numeric variable +#' to use as the response in the regression model. `variables(multiple = TRUE)` not allowed. +#' @param outlier (`picks`) Optional specification for outlier label variable selection. +#' Created using [teal.transform::picks()], which allows selecting a factor or character variable +#' to label outlier points on the plots. #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor". #' 1. Response vs Regressor #' 2. Residuals vs Fitted @@ -87,25 +91,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = "uptake", -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = TRUE -#' ) +#' response = picks( +#' datasets("CO2"), +#' variables(choices = "uptake", selected = "uptake") #' ), -#' regressor = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["CO2"]], c("conc", "Treatment")), -#' selected = "conc", -#' multiple = TRUE, -#' fixed = FALSE -#' ) +#' regressor = picks( +#' datasets("CO2"), +#' variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) #' ) #' ) #' ) @@ -132,25 +124,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = "BMRKR1", -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = TRUE -#' ) +#' response = picks( +#' datasets("ADSL"), +#' variables(choices = "BMRKR1", selected = "BMRKR1") #' ), -#' regressor = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")), -#' selected = "AGE", -#' multiple = TRUE, -#' fixed = FALSE -#' ) +#' regressor = picks( +#' datasets("ADSL"), +#' variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) #' ) #' ) #' ) @@ -162,15 +142,8 @@ #' @export #' tm_a_regression <- function(label = "Regression Analysis", - regressor = picks( - datasets(), - variables(choices = tidyselect::where(is.numeric), selected = -1, multiple = TRUE) - ), - response = picks( - datasets(), - variables(choices = tidyselect::where(is.numeric)), - values(selected = tidyselect::everything(), multiple = TRUE) - ), + regressor, + response, plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -195,12 +168,19 @@ tm_a_regression.picks <- function(label = "Regression Analysis", choices = tidyselect::where(is.numeric), selected = tidyselect::last_col(), multiple = TRUE - ) + ), + values() ), response = picks( datasets(), - variables(choices = tidyselect::where(is.numeric)) + variables(choices = tidyselect::where(is.numeric)), + values() ), + outlier = picks( + regressor$datasets, + variables(choices = where(~ is.factor(.) || is.character(.))), + values() + ), # default should be picks(datasets(), variables(primary_keys()) plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -210,7 +190,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", pre_output = NULL, post_output = NULL, default_plot_type = 1, - default_outlier_label = "USUBJID", + default_outlier_label, label_segment_threshold = c(0.5, 0, 10), transformators = list(), decorators = list()) { @@ -225,6 +205,11 @@ tm_a_regression.picks <- function(label = "Regression Analysis", warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } + checkmate::assert_class(outlier, "picks", null.ok = TRUE) + if (isTRUE(attr(outlier$variables, "multiple"))) { + warning("`outlier` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(outlier$variables, "multiple") <- FALSE + } checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -265,7 +250,9 @@ tm_a_regression.picks <- function(label = "Regression Analysis", checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) - checkmate::assert_string(default_outlier_label) + if (!missing(default_outlier_label)) { + warning("`default_outlier_label` is not supported when using picks. Please use `outlier` argument.") + } checkmate::assert_list(decorators, "teal_transform_module") if (length(label_segment_threshold) == 1) { @@ -305,6 +292,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", ui_a_regression.picks <- function(id, response, regressor, + outlier, plot_choices, default_plot_type, alpha, @@ -336,12 +324,12 @@ ui_a_regression.picks <- function(id, choices = plot_choices, selected = plot_choices[default_plot_type] ), - checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE), + checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = FALSE), conditionalPanel( condition = "input['show_outlier']", ns = ns, teal.widgets::optionalSliderInput( - ns("outlier"), + ns("outlier_cutoff"), tags$div( tagList( "Outlier definition:", @@ -357,11 +345,7 @@ ui_a_regression.picks <- function(id, ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.widgets::optionalSelectInput( - ns("label_var"), - multiple = FALSE, - label = "Outlier label" - ) + teal.transform::module_input_ui(id = ns("outlier"), spec = outlier) ), ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( @@ -416,10 +400,10 @@ srv_a_regression.picks <- function(id, data, response, regressor, + outlier, plot_height, plot_width, ggplot2_args, - default_outlier_label, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") @@ -428,148 +412,96 @@ srv_a_regression.picks <- function(id, ns <- session$ns selectors <- teal.transform::module_input_srv( - spec = list(response = response, regressor = regressor), + spec = list(response = response, regressor = regressor, outlier = outlier), data = data ) - anl_merged_q <- reactive({ - obj <- data() - validate_input( - inputId = "response-variables-selected", - condition = length(selectors$response()$variables$selected) == 1, - message = "Single regressor variable must be selected." - ) + validated_q <- reactive({ + req(data()) validate_input( inputId = "response-variables-selected", condition = is.numeric( - data[[selectors$response()$datasets$selected]][selectors$response()$variables$selected] + data()[[selectors$response()$datasets$selected]][[selectors$response()$variables$selected]] ), - message = "A regressor variable needs to be numeric." + message = "A response variable needs to be numeric." ) validate_input( inputId = "regressor-variables-selected", - condition = !is.null(selectors$regressor()$variables$selected), - message = "A response variables need to be selected." + condition = length(selectors$regressor()$variables$selected) > 0, + message = "A regressor variables need to be selected." ) validate_input( - inputId = c("ref-variables-selected", "vars-variables-selected"), + inputId = c("regressor-variables-selected", "response-variables-selected"), condition = !any(selectors$regressor()$variables$selected %in% selectors$response()$variables$selected), message = "Response and Regressor must be different." ) + validate_input( + inputId = c("show_outlier", "outlier-variables-selected"), + condition = !(isTRUE(input$show_outlier) && length(selectors$outlier()$variables$selected) == 0), + message = "Please provide an `Outlier label` variable" + ) - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Linear Regression Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') %>% # nolint: quotes - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") - }) - - regression_var <- reactive({ - list( - response = map_merged(selectors)$response$variables, - regressor = map_merged(selectors)$regressor$variables + obj <- data() + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Linear Regression Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + # sets qenv object and populates it with data merge call and fit expression fit_r <- reactive({ - req(anl_merged_q()) - anl <- anl_merged_q()[["anl"]] + obj <- req(merged$data()) + anl <- obj[["anl"]] teal::validate_has_data(anl, 10) teal::validate_has_data( - anl[, c(regression_var()$response, regression_var()$regressor)], 10, + anl[, c(merged$merge_vars()$response, merged$merge_vars()$regressor)], 10, complete = TRUE, allow_inf = FALSE ) form <- stats::as.formula( paste( - regression_var()$response, + merged$merge_vars()$response, paste( - regression_var()$regressor, + merged$merge_vars()$regressor, collapse = " + " ), sep = " ~ " ) ) - if (input$show_outlier) { - opts <- teal.transform::variable_choices(anl) - selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) { - isolate(input$label_var) - } else { - if (length(opts[as.character(opts) == default_outlier_label]) == 0) { - opts[[1]] - } else { - opts[as.character(opts) == default_outlier_label] - } + anl_fit <- within(obj, form = form, { + fit <- stats::lm(form, data = anl) + for (regressor in names(fit$contrasts)) { + alts <- paste0(levels(anl[[regressor]]), collapse = "|") + names(fit$coefficients) <- gsub( + paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) + ) } - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "label_var", - choices = opts, - selected = restoreInput(ns("label_var"), selected) - ) - - data <- ggplot2::fortify(stats::lm(form, data = anl)) - cooksd <- data$.cooksd[!is.nan(data$.cooksd)] - max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) - cur_outlier <- isolate(input$outlier) - updateSliderInput( - session = session, - inputId = "outlier", - min = 1, - max = max_outlier, - value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9) - ) - } - - anl_fit <- anl_merged_q() %>% - teal.code::eval_code(substitute(fit <- stats::lm(form, data = anl), env = list(form = form))) %>% - teal.code::eval_code(quote({ - for (regressor in names(fit$contrasts)) { - alts <- paste0(levels(anl[[regressor]]), collapse = "|") - names(fit$coefficients) <- gsub( - paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) - ) - } - })) %>% - teal.code::eval_code(quote({ - fit_summary <- summary(fit) - fit_summary - })) + fit_summary <- summary(fit) + fit_summary + }) teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "## Plot") anl_fit }) - - - label_col <- reactive({ - validate_input( - inputId = c("show_outlier", "label_var"), - condition = isTRUE(input$show_outlier) && length(input$label_var), - message = "Please provide an `Outlier label` variable" - ) - + outlier_label_call <- reactive({ substitute( expr = dplyr::if_else( - data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), + data$.cooksd > outlier_cutoff * mean(data$.cooksd, na.rm = TRUE), as.character(stats::na.omit(anl)[[label_var]]), "" ) %>% dplyr::if_else(is.na(.), "cooksd == NaN", .), - env = list(outliers = input$outlier, label_var = input$label_var) + env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$merge_vars()$outlier) ) }) - label_min_segment <- reactive({ - input$label_min_segment - }) - - outlier_label <- reactive({ + outlier_label_geom <- reactive({ substitute( expr = ggrepel::geom_text_repel( label = label_col, @@ -581,14 +513,14 @@ srv_a_regression.picks <- function(id, segment.alpha = 0.5, seed = 123 ), - env = list(label_col = label_col(), label_min_segment = label_min_segment()) + env = list(label_col = outlier_label_call(), label_min_segment = input$label_min_segment) ) }) output_plot_base <- reactive({ - base_fit <- fit_r() + obj <- fit_r() teal.code::eval_code( - base_fit, + obj, quote({ class(fit$residuals) <- NULL @@ -606,10 +538,11 @@ srv_a_regression.picks <- function(id, }) output_plot_0 <- reactive({ - fit <- fit_r()[["fit"]] - anl <- anl_merged_q()[["anl"]] + obj <- req(fit_r()) + fit <- obj[["fit"]] + anl <- obj[["anl"]] - if (!is.factor(anl[[regression_var()$regressor]])) { + if (!is.factor(anl[[merged$merge_vars()$regressor]])) { shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -617,8 +550,8 @@ srv_a_regression.picks <- function(id, ggplot2::geom_point(size = size, alpha = alpha) + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), env = list( - regressor = regression_var()$regressor, - response = regression_var()$response, + regressor = merged$merge_vars()$regressor, + response = merged$merge_vars()$response, size = input$size, alpha = input$alpha ) @@ -626,7 +559,7 @@ srv_a_regression.picks <- function(id, if (input$show_outlier) { plot <- substitute( expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label()) + env = list(plot = plot, outlier_label = outlier_label_geom()) ) } } else { @@ -635,10 +568,13 @@ srv_a_regression.picks <- function(id, plot <- substitute( expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + ggplot2::geom_boxplot(), - env = list(regressor = regression_var()$regressor, response = regression_var()$response) + env = list(regressor = merged$merge_vars()$regressor, response = merged$merge_vars()$response) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } } @@ -649,8 +585,8 @@ srv_a_regression.picks <- function(id, module_plot = teal.widgets::ggplot2_args( labs = list( title = "Response vs Regressor", - x = varname_w_label(regression_var()$regressor, anl), - y = varname_w_label(regression_var()$response, anl) + x = varname_w_label(merged$merge_vars()$regressor, anl), + y = varname_w_label(merged$merge_vars()$response, anl) ), theme = list() ) @@ -659,7 +595,7 @@ srv_a_regression.picks <- function(id, ) teal.code::eval_code( - fit_r(), + obj, substitute( expr = { class(fit$residuals) <- NULL @@ -674,7 +610,7 @@ srv_a_regression.picks <- function(id, }) output_plot_1 <- reactive({ - plot_base <- output_plot_base() + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -685,7 +621,10 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -703,24 +642,20 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.fitted, data$.resid) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, data$.resid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_2 <- reactive({ + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) + ggplot2::stat_qq(size = size, alpha = alpha) + @@ -732,10 +667,7 @@ srv_a_regression.picks <- function(id, expr = plot + ggplot2::stat_qq( geom = ggrepel::GeomTextRepel, - label = label_col %>% - data.frame(label = .) %>% - dplyr::filter(label != "cooksd == NaN") %>% - unlist(), + label = label_col, color = "red", hjust = 0, vjust = 0, @@ -744,7 +676,7 @@ srv_a_regression.picks <- function(id, segment.alpha = .5, seed = 123 ), - env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) + env = list(plot = plot, label_col = outlier_label_call(), label_min_segment = input$label_min_segment) ) } @@ -763,23 +695,17 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_3 <- reactive({ + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) + ggplot2::geom_point(size = size, alpha = alpha) + @@ -787,7 +713,10 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -805,24 +734,20 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_4 <- reactive({ + obj <- output_plot_base() shinyjs::hide("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) + ggplot2::geom_col(alpha = alpha), @@ -850,7 +775,7 @@ srv_a_regression.picks <- function(id, angle = 90 ) + outlier_label, - env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) + env = list(plot = plot, outlier = input$outlier_cutoff, outlier_label = outlier_label_geom()) ) } @@ -869,23 +794,17 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_5 <- reactive({ + obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) + ggplot2::geom_vline( @@ -905,7 +824,10 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -923,24 +845,20 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.hat, data$.stdresid) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.stdresid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_6 <- reactive({ + obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) + ggplot2::geom_vline(xintercept = 0, colour = NA) + @@ -955,7 +873,10 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -973,17 +894,13 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.hat, data$.cooksd) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.cooksd) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) diff --git a/R/tm_data_table.R b/R/tm_data_table.R index eceb18727..63c015d20 100644 --- a/R/tm_data_table.R +++ b/R/tm_data_table.R @@ -354,29 +354,5 @@ srv_dataset_table <- function(id, teal::validate_inputs(iv) req(data_table_data())[["table"]] }) - - observeEvent(input$data_table_rows_selected, ignoreNULL = FALSE, { - if (is.null(input$data_table_rows_selected)) { - shinyjs::hide("apply_brush_filter") - } else { - shinyjs::show("apply_brush_filter") - } - }) - - observeEvent(input$apply_brush_filter, { - if (is.null(input$data_table_rows_selected)) { - return(NULL) - } - dataset <- data()[[dataname]][input$data_table_rows_selected, ] - # todo: when added another time then it is duplicated - slice <- teal_slices(teal_slice( - dataname = "ADSL", - varname = "USUBJID", - selected = unique(dataset$USUBJID), # todo: this needs to be parametrised or based on join_keys - id = "brush_filter" - )) - shinyjs::hide("apply_brush_filter") - teal.slice::set_filter_state(filter_panel_api, slice) - }) }) } diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 72b6509c7..0b91b4784 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -10,11 +10,10 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param ref (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Reference variable, must accepts a `data_extract_spec` with `select_spec(multiple = FALSE)` -#' to ensure single selection option. -#' @param vars (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variables to be associated with the reference variable. +#' @param ref (`picks`) +#' Reference variable specification created using `picks()`. +#' @param vars (`picks`) +#' Variables to be associated with the reference variable, specified using `picks()`. #' @param show_association (`logical`) optional, whether show association of `vars` #' with reference variable. Defaults to `TRUE`. #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. @@ -68,23 +67,19 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = "Plant", -#' fixed = FALSE +#' ref = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("Plant", "Type", "Treatment"), +#' selected = "Plant" #' ) #' ), -#' vars = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), +#' vars = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("Plant", "Type", "Treatment"), #' selected = "Treatment", -#' multiple = TRUE, -#' fixed = FALSE +#' multiple = TRUE #' ) #' ) #' ) @@ -111,29 +106,19 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") -#' ), -#' selected = "RACE", -#' fixed = FALSE +#' ref = picks( +#' datasets("ADSL"), +#' variables( +#' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), +#' selected = "RACE" #' ) #' ), -#' vars = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") -#' ), +#' vars = picks( +#' datasets("ADSL"), +#' variables( +#' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "BMRKR2", -#' multiple = TRUE, -#' fixed = FALSE +#' multiple = TRUE #' ) #' ) #' ) @@ -215,6 +200,10 @@ tm_g_association.picks <- function(label = "Association", # Start of assertions checkmate::assert_string(label) checkmate::assert_class(ref, "picks") + if (isTRUE(attr(ref$variables, "multiple"))) { + warning("`ref` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(ref$variables, "multiple") <- FALSE + } checkmate::assert_class(vars, "picks") checkmate::assert_flag(show_association) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) @@ -337,7 +326,7 @@ srv_g_association.picks <- function(id, selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) - anl_merged_q <- reactive({ + validated_q <- reactive({ obj <- req(data()) validate_input( inputId = "ref-variables-selected", @@ -360,19 +349,19 @@ srv_g_association.picks <- function(id, teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj |> - teal.code::eval_code('library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') |> # nolint - teal.transform::qenv_merge_selectors(selectors = selectors) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + output_q <- reactive({ - req(anl_merged_q()) + req(merged$data()) logger::log_debug("srv_g_association@1 recalculating a plot") - merged <- anl_merged_q()[["merged"]] - ref_name <- map_merged(selectors)$ref$variables - vars_names <- map_merged(selectors)$vars$variables - teal::validate_has_data(merged, 3) - teal::validate_has_data(merged[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) + anl <- merged$data()[["anl"]] + ref_name <- merged$merge_vars()$ref + vars_names <- merged$merge_vars()$vars + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) association <- input$association show_dist <- input$show_dist @@ -382,7 +371,7 @@ srv_g_association.picks <- function(id, distribution_theme <- input$distribution_theme association_theme <- input$association_theme - is_scatterplot <- is.numeric(merged[[ref_name]]) && any(vapply(merged[vars_names], is.numeric, logical(1))) + is_scatterplot <- is.numeric(anl[[ref_name]]) && any(vapply(anl[vars_names], is.numeric, logical(1))) if (is_scatterplot) { shinyjs::show("alpha") shinyjs::show("size") @@ -396,16 +385,16 @@ srv_g_association.picks <- function(id, } # reference - ref_class <- class(merged[[ref_name]])[1] - if (is.numeric(merged[[ref_name]]) && log_transformation) { + ref_class <- class(anl[[ref_name]])[1] + if (is.numeric(anl[[ref_name]]) && log_transformation) { # works for both integers and doubles ref_cl_name <- call("log", as.name(ref_name)) - ref_cl_lbl <- varname_w_label(ref_name, merged, prefix = "Log of ") + ref_cl_lbl <- varname_w_label(ref_name, anl, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not ref_cl_name <- as.name(ref_name) - ref_cl_lbl <- varname_w_label(ref_name, merged) + ref_cl_lbl <- varname_w_label(ref_name, anl) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -414,7 +403,7 @@ srv_g_association.picks <- function(id, ) ref_call <- bivariate_plot_call( - data_name = "merged", + data_name = "anl", x = ref_cl_name, x_class = ref_class, x_label = ref_cl_lbl, @@ -431,15 +420,15 @@ srv_g_association.picks <- function(id, ref_class_cov <- ifelse(association, ref_class, "NULL") var_calls <- lapply(vars_names, function(var_i) { - if (is.numeric(merged[[var_i]]) && log_transformation) { + if (is.numeric(anl[[var_i]]) && log_transformation) { # works for both integers and doubles var_cl_name <- call("log", as.name(var_i)) - var_cl_lbl <- varname_w_label(var_i, merged, prefix = "Log of ") + var_cl_lbl <- varname_w_label(var_i, anl, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not var_cl_name <- as.name(var_i) - var_cl_lbl <- varname_w_label(var_i, merged) + var_cl_lbl <- varname_w_label(var_i, anl) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -448,11 +437,11 @@ srv_g_association.picks <- function(id, ) bivariate_plot_call( - data_name = "merged", + data_name = "anl", x = ref_cl_name, y = var_cl_name, x_class = ref_class_cov, - y_class = class(merged[[var_i]])[1], + y_class = class(anl[[var_i]])[1], x_label = ref_cl_lbl, y_label = var_cl_lbl, theme = association_theme, @@ -467,10 +456,10 @@ srv_g_association.picks <- function(id, # helper function to format variable name format_varnames <- function(x) { - if (is.numeric(merged[[x]]) && log_transformation) { - varname_w_label(x, merged, prefix = "Log of ") + if (is.numeric(anl[[x]]) && log_transformation) { + varname_w_label(x, anl, prefix = "Log of ") } else { - varname_w_label(x, merged) + varname_w_label(x, anl) } } new_title <- @@ -498,30 +487,21 @@ srv_g_association.picks <- function(id, ) ) } - obj <- anl_merged_q() + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") - teal.code::eval_code( + within( obj, - substitute( - expr = title <- new_title, - env = list(new_title = new_title) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = { - plots <- plot_calls - plot <- gridExtra::arrangeGrob(plots[[1]], plots[[2]], ncol = 1) - }, - env = list( - plot_calls = do.call( - "call", - c(list("list", ref_call), var_calls), - quote = TRUE - ) - ) - ) - ) + expr = { + title <- new_title + ref_plot <- plot1 + var_plot <- plot2 + plot <- gridExtra::arrangeGrob(ref_plot, var_plot, ncol = 1) + }, + new_title = new_title, + plot1 = ref_call, + plot2 = var_calls[[1]] + ) }) decorated_output_grob_q <- srv_decorate_teal_data( diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index b2d3f9ec7..7343681e3 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -11,33 +11,30 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable names selected to plot along the x-axis by default. -#' Can be numeric, factor or character. -#' No empty selections are allowed. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable names selected to plot along the y-axis by default. +#' @param x (`picks`) Variable specification for the x-axis. Created using [teal.transform::picks()]. +#' Can be numeric, factor or character. No empty selections are allowed. +#' @param y (`picks`) Variable specification for the y-axis. Created using [teal.transform::picks()]. #' Can be numeric, factor or character. #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`). #' Defaults to frequency (`FALSE`). -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) to use for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) to use for faceting columns. +#' @param row_facet (`picks`) optional, specification of the data variable(s) to use for faceting rows. +#' Created using [teal.transform::picks()]. +#' @param col_facet (`picks`) optional, specification of the data variable(s) to use for faceting columns. +#' Created using [teal.transform::picks()]. #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` #' are supplied. #' @param color_settings (`logical`) Whether coloring, filling and size should be applied #' and `UI` tool offered to the user. -#' @param color (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the outline color inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. -#' @param fill (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the fill color inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. -#' @param size (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, -#' specification of the data variable(s) selected for the size of `geom_point` plots inside the coloring settings. -#' It will be applied when `color_settings` is set to `TRUE`. +#' @param color (`picks`) optional, specification of the data variable(s) selected for the outline color +#' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. +#' @param fill (`picks`) optional, specification of the data variable(s) selected for the fill color +#' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. +#' @param size (`picks`) optional, specification of the data variable(s) selected for the size of +#' `geom_point` plots inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. +#' Created using [teal.transform::picks()]. #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable. #' Does not allow scaling to be changed by default (`FALSE`). #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable. @@ -87,42 +84,22 @@ #' app <- init( #' data = data, #' modules = tm_g_bivariate( -#' x = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "conc", -#' fixed = FALSE -#' ) +#' label = "Bivariate Plots", +#' x = picks( +#' datasets("CO2"), +#' variables(selected = "conc") #' ), -#' y = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = picks( +#' datasets("CO2"), +#' variables(selected = "uptake") #' ), -#' row_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "Type", -#' fixed = FALSE -#' ) +#' row_facet = picks( +#' datasets("CO2"), +#' variables(selected = "Type") #' ), -#' col_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]]), -#' selected = "Treatment", -#' fixed = FALSE -#' ) +#' col_facet = picks( +#' datasets("CO2"), +#' variables(selected = "Treatment") #' ) #' ) #' ) @@ -146,42 +123,22 @@ #' app <- init( #' data = data, #' modules = tm_g_bivariate( -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "AGE", -#' fixed = FALSE -#' ) +#' label = "Bivariate Plots", +#' x = picks( +#' datasets("ADSL"), +#' variables(selected = "AGE") #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "SEX", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = picks( +#' datasets("ADSL"), +#' variables(selected = "SEX") #' ), -#' row_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "ARM", -#' fixed = FALSE -#' ) +#' row_facet = picks( +#' datasets("ADSL"), +#' variables(selected = "ARM") #' ), -#' col_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]]), -#' selected = "COUNTRY", -#' fixed = FALSE -#' ) +#' col_facet = picks( +#' datasets("ADSL"), +#' variables(selected = "COUNTRY") #' ) #' ) #' ) @@ -519,7 +476,7 @@ srv_g_bivariate.picks <- function(id, data = data ) - anl_merged_q <- reactive({ + validated_q <- reactive({ validate_input( inputId = c("x-variables-selected", "y-variables-selected"), condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), @@ -528,36 +485,38 @@ srv_g_bivariate.picks <- function(id, if (!is.null(col_facet) && !is.null(row_facet)) { validate_input( inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), - condition = length(selectors$row_facet()$variables$selected) && - length(selectors$col_facet()$variables$selected) && + condition = is.null(selectors$row_facet()$variables$selected) || + is.null(selectors$col_facet()$variables$selected) || !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), message = "Row and column facetting variables must be different." ) } + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Bivariate Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj %>% - teal.code::eval_code('library("ggplot2");library("dplyr")') %>% - teal.transform::qenv_merge_selectors(selectors = selectors) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + output_q <- reactive(label = "make bivariateplot", { - req(anl_merged_q()) + req(merged$data()) logger::log_debug("Plotting bivariate") - merged <- anl_merged_q()[["merged"]] - teal::validate_has_data(merged, 3) + anl <- merged$data()[["anl"]] + teal::validate_has_data(anl, 3) + - x_name <- map_merged(selectors)$x$variables - y_name <- map_merged(selectors)$y$variables - row_facet_name <- map_merged(selectors)$row_facet$variables - col_facet_name <- map_merged(selectors)$col_facet$variables - color_name <- map_merged(selectors)$color$variables - fill_name <- map_merged(selectors)$fill$variables - size_name <- map_merged(selectors)$size$variables + x_name <- merged$merge_vars()$x + y_name <- merged$merge_vars()$y + row_facet_name <- merged$merge_vars()$row_facet + col_facet_name <- merged$merge_vars()$col_facet + color_name <- merged$merge_vars()$color + fill_name <- merged$merge_vars()$fill + size_name <- merged$merge_vars()$size use_density <- input$use_density == "density" free_x_scales <- input$free_x_scales @@ -566,7 +525,22 @@ srv_g_bivariate.picks <- function(id, rotate_xaxis_labels <- input$rotate_xaxis_labels swap_axes <- input$swap_axes - is_scatterplot <- all(vapply(merged[c(x_name, y_name)], is.numeric, logical(1))) && + + supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") + x_class <- class(anl[[x_name]])[1] + validate_input( + "x-variables-selected", + condition = x_class %in% supported_types, + message = paste0("Data type '", x_class, "' is not supported.") + ) + y_class <- class(anl[[y_name]])[[1]] + validate_input( + "x-variables-selected", + condition = y_class %in% supported_types, + message = paste0("Data type '", y_class, "' is not supported.") + ) + + is_scatterplot <- all(vapply(anl[c(x_name, y_name)], is.numeric, logical(1))) && length(x_name) > 0 && length(y_name) > 0 if (is_scatterplot) { @@ -592,16 +566,18 @@ srv_g_bivariate.picks <- function(id, size <- NULL } - teal::validate_has_data(merged[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + + cl <- bivariate_plot_call( - data_name = "merged", + data_name = "anl", x = x_name, y = y_name, - x_class = ifelse(length(x_name), class(merged[[x_name]]), "NULL"), - y_class = ifelse(length(y_name), class(merged[[y_name]]), "NULL"), - x_label = varname_w_label(x_name, merged), - y_label = varname_w_label(y_name, merged), + x_class = ifelse(length(x_name), class(anl[[x_name]]), "NULL"), + y_class = ifelse(length(y_name), class(anl[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, anl), + y_label = varname_w_label(y_name, anl), freq = !use_density, theme = ggtheme, rotate_xaxis_labels = rotate_xaxis_labels, @@ -646,7 +622,7 @@ srv_g_bivariate.picks <- function(id, } } - obj <- anl_merged_q() + obj <- merged$data() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) }) @@ -656,13 +632,13 @@ srv_g_bivariate.picks <- function(id, data = output_q, decorators = select_decorators(decorators, "plot"), expr = reactive({ - merged <- anl_merged_q()[["merged"]] - row_facet_name <- map_merged(selectors)$row_facet$variables - col_facet_name <- map_merged(selectors)$col_facet$variables + anl <- merged$data()[["anl"]] + row_facet_name <- merged$merge_vars()$row_facet + col_facet_name <- merged$merge_vars()$col_facet # Add labels to facets - nulled_row_facet_name <- varname_w_label(row_facet_name, merged) - nulled_col_facet_name <- varname_w_label(col_facet_name, merged) + nulled_row_facet_name <- varname_w_label(row_facet_name, anl) + nulled_col_facet_name <- varname_w_label(col_facet_name, anl) facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting @@ -723,11 +699,6 @@ bivariate_plot_call <- function(data_name, alpha = double(0), size = 2, ggplot2_args = teal.widgets::ggplot2_args()) { - supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") - validate(need(x_class %in% supported_types, paste0("Data type '", x_class, "' is not supported."))) - validate(need(y_class %in% supported_types, paste0("Data type '", y_class, "' is not supported."))) - - if (is.null(x)) { x <- x_label <- "-" } else { diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 418b2de30..e4ced5b2f 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -8,11 +8,11 @@ #' @inheritParams teal.widgets::standard_layout #' @inheritParams shared_params #' -#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param dist_var (`picks` or `list` of multiple `picks`) #' Variable(s) for which the distribution will be analyzed. -#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param strata_var (`picks` or `list` of multiple `picks`) #' Categorical variable used to split the distribution analysis. -#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param group_var (`picks` or `list` of multiple `picks`) #' Variable used for faceting plot into multiple panels. #' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). #' Defaults to density (`FALSE`). @@ -71,9 +71,10 @@ #' data = data, #' modules = list( #' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "iris", -#' select = select_spec(variable_choices("iris"), "Petal.Length") +#' dist_var = picks( +#' datasets("iris"), +#' variables(tidyselect::where(is.numeric)), +#' values(selected = "Petal.Length") #' ) #' ) #' ) @@ -96,37 +97,22 @@ #' }) #' join_keys(data) <- default_cdisc_join_keys[names(data)] #' -#' vars1 <- choices_selected( -#' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), -#' selected = NULL -#' ) -#' #' app <- init( #' data = data, #' modules = modules( #' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' dist_var = picks( +#' datasets("ADSL"), +#' variables(c("BMRKR1", "AGE")), +#' values(multiple = FALSE) #' ), -#' strata_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = vars1, -#' multiple = TRUE -#' ) +#' strata_var = picks( +#' datasets("ADSL"), +#' variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ), -#' group_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = vars1, -#' multiple = TRUE -#' ) +#' group_var = picks( +#' datasets("ADSL"), +#' variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ) #' ) #' ) @@ -376,20 +362,7 @@ srv_g_distribution.picks <- function(id, data = data ) - rule_dist <- function(value) { - if (isTRUE(input$tabs == "QQplot") || - isTRUE(input$dist_test %in% c( - "Kolmogorov-Smirnov (one-sample)", - "Anderson-Darling (one-sample)", - "Cramer-von Mises (one-sample)" - ))) { - if (!shinyvalidate::input_provided(value)) { - "Please select the theoretical distribution." - } - } - } - - anl_merged_q <- reactive({ + qenv <- reactive({ validate_input( inputId = "dist_var-variables-selected", condition = length(selectors$dist_var()$variables$selected) == 1, @@ -402,35 +375,39 @@ srv_g_distribution.picks <- function(id, teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj <- teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') - obj <- teal.transform::qenv_merge_selectors(obj, selectors = selectors, output_name = "anl") + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + validate_merged <- reactive({ + obj <- merged$data() anl <- obj[["anl"]] validate_input( inputId = "dist_var-variables-selected", - condition = is.numeric(anl[[merge_vars()$dist_var]]), + condition = is.numeric(anl[[merged$merge_vars()$dist_var]]), message = "Distribution variable must be numeric." ) - if (length(merge_vars()$group_var) > 0) { + if (length(merged$merge_vars()$group_var) > 0) { validate_input( "group_var-variables-selected", - condition = inherits(anl[[merge_vars()$group_var]], c("integer", "factor", "character")), + condition = inherits(anl[[merged$merge_vars()$group_var]], c("integer", "factor", "character")), message = "Group by variable must be `factor`, `character`, or `integer`" ) obj <- within(obj, library("forcats")) obj <- within( obj, expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), - group_var = merge_vars()$group_var + group_var = merged$merge_vars()$group_var ) } - if (length(merge_vars()$strata_var) > 0) { + if (length(merged$merge_vars()$strata_var) > 0) { validate_input( "strata_var-variables-selected", - condition = inherits(anl[[merge_vars()$strata_var]], c("integer", "factor", "character")), + condition = inherits(anl[[merged$merge_vars()$strata_var]], c("integer", "factor", "character")), message = "Stratify by variable must be `factor`, `character`, or `integer`" ) @@ -438,7 +415,7 @@ srv_g_distribution.picks <- function(id, obj <- within( obj, expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), - strata_var = merge_vars()$strata_var + strata_var = merged$merge_vars()$strata_var ) } @@ -447,16 +424,9 @@ srv_g_distribution.picks <- function(id, obj }) - merge_vars <- reactive( - list( - dist_var = map_merged(selectors)$dist_var$variables, - strata_var = map_merged(selectors)$strata_var$variables, - group_var = map_merged(selectors)$group_var$variables - ) - ) - output$scales_types_ui <- renderUI({ - if (length(merge_vars()$group_var) > 0) { + validate_merged() + if (length(merged$merge_vars()$group_var) > 0) { shinyWidgets::prettyRadioButtons( ns("scales_type"), label = "Scales:", @@ -472,15 +442,16 @@ srv_g_distribution.picks <- function(id, eventExpr = { input$t_dist input$params_reset - merge_vars()$dist_var + merged$merge_vars()$dist_var }, handlerExpr = { params <- if (length(input$t_dist)) { - req(anl_merged_q()) - anl <- anl_merged_q()[["anl"]] + validate_merged() + req(merged$data()) + anl <- merged$data()[["anl"]] round( .calc_dist_params( - x = as.numeric(stats::na.omit(anl[[merge_vars()$dist_var]])), + x = as.numeric(stats::na.omit(anl[[merged$merge_vars()$dist_var]])), dist = input$t_dist ), 2 @@ -571,10 +542,11 @@ srv_g_distribution.picks <- function(id, hist_output <- .srv_hist( "histogram_plot", data = reactive({ + validate_merged() validate_dist() - anl_merged_q() + merged$data() }), - merge_vars = merge_vars, + merge_vars = merged$merge_vars, t_dist = reactive(input$t_dist), dist_param1 = reactive(input$dist_param1), dist_param2 = reactive(input$dist_param2), @@ -593,15 +565,16 @@ srv_g_distribution.picks <- function(id, qq_output <- .srv_qq( "qq_plot", data = reactive({ + validate_merged() validate_input( "t_dist", condition = !is.null(input$t_dist), message = "QQ Plot requires Theoretical Distribution to be selected" ) validate_dist() - anl_merged_q() + merged$data() }), - merge_vars = merge_vars, + merge_vars = merged$merge_vars, t_dist = reactive(input$t_dist), dist_param1 = reactive(input$dist_param1), dist_param2 = reactive(input$dist_param2), @@ -619,16 +592,20 @@ srv_g_distribution.picks <- function(id, summary_table_output <- .srv_summary_table( "summary_table", - data = anl_merged_q, - merge_vars = merge_vars, + data = reactive({ + validate_merged() + merged$data() + }), + merge_vars = merged$merge_vars, decorators = select_decorators(decorators, "Statistics Table") ) test_q <- reactive({ - obj <- anl_merged_q() + validate_merged() + obj <- merged$data() anl <- obj[["anl"]] - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var + s_var <- merged$merge_vars()$strata_var + g_var <- merged$merge_vars()$group_var dist_test <- input$`test_table-dist_test` if (identical(dist_test, "Fligner-Killeen")) { @@ -668,7 +645,7 @@ srv_g_distribution.picks <- function(id, test_output <- .srv_test_table( "test_table", data = test_q, - merge_vars = merge_vars, + merge_vars = merged$merge_vars, t_dist = reactive(input$t_dist), decorators = select_decorators(decorators, "Test Table") ) diff --git a/R/tm_g_distribution_old.R b/R/tm_g_distribution_old.R index a7ff967dd..a8997e1ec 100644 --- a/R/tm_g_distribution_old.R +++ b/R/tm_g_distribution_old.R @@ -1,142 +1,4 @@ -#' `teal` module: Distribution analysis -#' -#' Module is designed to explore the distribution of a single variable within a given dataset. -#' It offers several tools, such as histograms, Q-Q plots, and various statistical tests to -#' visually and statistically analyze the variable's distribution. -#' -#' @inheritParams teal::module -#' @inheritParams teal.widgets::standard_layout -#' @inheritParams shared_params -#' -#' @param dist_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable(s) for which the distribution will be analyzed. -#' @param strata_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Categorical variable used to split the distribution analysis. -#' @param group_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) -#' Variable used for faceting plot into multiple panels. -#' @param freq (`logical`) optional, whether to display frequency (`TRUE`) or density (`FALSE`). -#' Defaults to density (`FALSE`). -#' @param bins (`integer(1)` or `integer(3)`) optional, specifies the number of bins for the histogram. -#' - When the length of `bins` is one: The histogram bins will have a fixed size based on the `bins` provided. -#' - When the length of `bins` is three: The histogram bins are dynamically adjusted based on vector of `value`, `min`, -#' and `max`. -#' Defaults to `c(30L, 1L, 100L)`. -#' -#' @param ggplot2_args `r roxygen_ggplot2_args_param("Histogram", "QQplot")` -#' -#' @inherit shared_params return -#' -#' @section Decorating Module: -#' -#' This module generates the following objects, which can be modified in place using decorators:: -#' - `histogram_plot` (`ggplot`) -#' - `qq_plot` (`ggplot`) -#' -#' A Decorator is applied to the specific output using a named list of `teal_transform_module` objects. -#' The name of this list corresponds to the name of the output to which the decorator is applied. -#' See code snippet below: -#' -#' ``` -#' tm_g_distribution( -#' ..., # arguments for module -#' decorators = list( -#' histogram_plot = teal_transform_module(...), # applied only to `histogram_plot` output -#' qq_plot = teal_transform_module(...) # applied only to `qq_plot` output -#' ) -#' ) -#' ``` -#' -#' For additional details and examples of decorators, refer to the vignette -#' `vignette("decorate-module-output", package = "teal.modules.general")`. -#' -#' To learn more please refer to the vignette -#' `vignette("transform-module-output", package = "teal")` or the [`teal::teal_transform_module()`] documentation. -#' -#' @inheritSection teal::example_module Reporting -#' -#' @examplesShinylive -#' library(teal.modules.general) -#' interactive <- function() TRUE -#' {{ next_example }} -# nolint start: line_length_linter. -#' @examples -# nolint end: line_length_linter. -#' # general data example -#' data <- teal_data() -#' data <- within(data, { -#' iris <- iris -#' }) -#' -#' app <- init( -#' data = data, -#' modules = list( -#' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "iris", -#' select = select_spec(variable_choices("iris"), "Petal.Length") -#' ) -#' ) -#' ) -#' ) -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @examplesShinylive -#' library(teal.modules.general) -#' interactive <- function() TRUE -#' {{ next_example }} -# nolint start: line_length_linter. -#' @examples -# nolint end: line_length_linter. -#' # CDISC data example -#' data <- teal_data() -#' data <- within(data, { -#' ADSL <- teal.data::rADSL -#' }) -#' join_keys(data) <- default_cdisc_join_keys[names(data)] -#' -#' vars1 <- choices_selected( -#' variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), -#' selected = NULL -#' ) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_g_distribution( -#' dist_var = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = FALSE -#' ) -#' ), -#' strata_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = vars1, -#' multiple = TRUE -#' ) -#' ), -#' group_var = data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( -#' vars = vars1, -#' multiple = TRUE -#' ) -#' ) -#' ) -#' ) -#' ) -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' #' @export -#' tm_g_distribution.default <- function(label = "Distribution Module", dist_var, strata_var = NULL, diff --git a/R/tm_g_response.R b/R/tm_g_response.R index 00d98375c..6d98b4714 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -9,19 +9,15 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param response (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param response (`picks`) #' Which variable to use as the response. -#' You can define one fixed column by setting `fixed = TRUE` inside the `select_spec`. -#' -#' The `data_extract_spec` must not allow multiple selection in this case. -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' The `picks` must not allow multiple variable selection in this case. +#' @param x (`picks` ) #' Specifies which variable to use on the X-axis of the response plot. -#' Allow the user to select multiple columns from the `data` allowed in teal. -#' -#' The `data_extract_spec` must not allow multiple selection in this case. -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' The `picks` must not allow multiple selection in this case. +#' @param row_facet (`picks`) #' optional specification of the data variable(s) to use for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param col_facet (`picks`) #' optional specification of the data variable(s) to use for faceting columns. #' @param coord_flip (`logical(1)`) #' Indicates whether to flip coordinates between `x` and `response`. @@ -85,25 +81,25 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["mtcars"]], c("cyl", "gear")), +#' response = picks( +#' datasets("mtcars"), +#' variables( +#' choices = c("cyl", "gear"), #' selected = "cyl", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ), -#' x = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["mtcars"]], c("vs", "am")), +#' x = picks( +#' datasets("mtcars"), +#' variables( +#' choices = c("vs", "am"), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ) #' ) #' ) @@ -130,25 +126,21 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")), -#' selected = "BMRKR2", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' response = picks( +#' datasets("ADSL"), +#' variables( +#' choices = c("BMRKR2", "COUNTRY"), +#' selected = "BMRKR2" +#' ), +#' values() #' ), -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")), -#' selected = "RACE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = picks( +#' datasets("ADSL"), +#' variables( +#' choices = c("SEX", "RACE"), +#' selected = "RACE" +#' ), +#' values() #' ) #' ) #' ) @@ -367,8 +359,7 @@ srv_g_response.picks <- function(id, data = data ) - anl_merged_q <- reactive({ - obj <- req(data()) + validated_q <- reactive({ validate_input( inputId = "response-variables-selected", condition = !is.null(selectors$response()$variables$selected), @@ -401,17 +392,18 @@ srv_g_response.picks <- function(id, message = "Row and Column Facetting variables must be different." ) + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Response Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj |> - teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + output_q <- reactive({ validate_input( @@ -420,18 +412,18 @@ srv_g_response.picks <- function(id, message = "Row and Col Facetting variables must be different." ) - qenv <- anl_merged_q() + qenv <- merged$data() anl <- qenv[["anl"]] - response_var <- teal.transform::map_merged(selectors)$response$variables - x_var <- teal.transform::map_merged(selectors)$x$variables + response_var <- merged$merge_vars()$response + x_var <- merged$merge_vars()$x validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) teal::validate_has_data(anl, 10) teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) - row_facet_var <- map_merged(selectors)$row_facet$variables - col_facet_var <- map_merged(selectors)$col_facet$variables + row_facet_var <- merged$merge_vars()$row_facet + col_facet_var <- merged$merge_vars()$col_facet freq <- input$freq == "frequency" swap_axes <- input$coord_flip @@ -468,8 +460,8 @@ srv_g_response.picks <- function(id, response_var = response_var, response_cl = as.name(response_var), x_cl = as.name(x_var), - row_facet_cl = if (length(row_facet)) as.name(row_facet_var), - col_facet_cl = if (length(col_facet)) as.name(col_facet_var) + row_facet_cl = if (length(row_facet_var)) as.name(row_facet_var), + col_facet_cl = if (length(col_facet_var)) as.name(col_facet_var) ) plot_call <- substitute( diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index 3226f76cd..d78e4e3ae 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -10,17 +10,17 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies +#' @param x (`picks` or `list` of multiple `picks`) Specifies #' variable names selected to plot along the x-axis by default. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) Specifies +#' @param y (`picks` or `list` of multiple `picks`) Specifies #' variable names selected to plot along the y-axis by default. -#' @param color_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param color_by (`picks` or `list` of multiple `picks`) optional, #' defines the color encoding. If `NULL` then no color encoding option will be displayed. -#' @param size_by (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param size_by (`picks` or `list` of multiple `picks`) optional, #' defines the point size encoding. If `NULL` then no size encoding option will be displayed. -#' @param row_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param row_facet (`picks` or `list` of multiple `picks`) optional, #' specifies the variable(s) for faceting rows. -#' @param col_facet (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param col_facet (`picks` or `list` of multiple `picks`) optional, #' specifies the variable(s) for faceting columns. #' @param shape (`character`) optional, character vector with the names of the #' shape, e.g. `c("triangle", "square", "circle")`. It defaults to `shape_names`. This is a complete list from @@ -75,68 +75,47 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "conc", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("conc", "uptake"), +#' selected = "conc" +#' ), +#' values() #' ), -#' y = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("conc", "uptake"), +#' selected = "uptake" +#' ), +#' values() #' ), -#' color_by = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["CO2"]], -#' c("Plant", "Type", "Treatment", "conc", "uptake") -#' ), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' color_by = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("Plant", "Type", "Treatment", "conc", "uptake"), +#' selected = NULL +#' ), +#' values() #' ), -#' size_by = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), -#' selected = "uptake", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' size_by = picks( +#' datasets("CO2"), +#' variables(choices = c("conc", "uptake"), selected = "uptake"), +#' values() #' ), -#' row_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' row_facet = picks( +#' datasets("CO2"), +#' variables( +#' choices = c("Plant", "Type", "Treatment"), +#' selected = NULL +#' ), +#' values() #' ), -#' col_facet = data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' col_facet = picks( +#' datasets("CO2"), +#' variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), +#' values() #' ) #' ) #' ) @@ -165,68 +144,35 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), -#' selected = "AGE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' x = picks( +#' datasets("ADSL"), +#' variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), +#' values() #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), -#' selected = "BMRKR1", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' y = picks( +#' datasets("ADSL"), +#' variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), +#' values() #' ), -#' color_by = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices( -#' data[["ADSL"]], -#' c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1") -#' ), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' color_by = picks( +#' datasets("ADSL"), +#' variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), +#' values() #' ), -#' size_by = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), -#' selected = "AGE", -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' size_by = picks( +#' datasets("ADSL"), +#' variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), +#' values() #' ), -#' row_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' row_facet = picks( +#' datasets("ADSL"), +#' variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' values() #' ), -#' col_facet = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", -#' choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), -#' selected = NULL, -#' multiple = FALSE, -#' fixed = FALSE -#' ) +#' col_facet = picks( +#' datasets("ADSL"), +#' variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' values() #' ) #' ) #' ) @@ -263,8 +209,16 @@ tm_g_scatterplot <- function(label = "Scatterplot", #' @export tm_g_scatterplot.picks <- function(label = "Scatterplot", - x, - y, + x = picks( + datasets(), + variables(tidyselect::where(is.numeric)), + values() + ), + y = picks( + datasets(), + variables(tidyselect::where(is.numeric), selected = 2), + values() + ), color_by = NULL, size_by = NULL, row_facet = NULL, @@ -382,7 +336,11 @@ ui_g_scatterplot.picks <- function(id, tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( - teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")) + teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), + tags$br(), + tags$h1(tags$strong("Selected points:"), style = "font-size: 150%;"), + teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), + DT::dataTableOutput(ns("data_table"), width = "100%") ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), @@ -525,63 +483,21 @@ srv_g_scatterplot.picks <- function(id, selectors <- teal.transform::module_input_srv( - spec = list( - x = x, - y = y, - color_by = color_by, - size_by = size_by, - row_facet = row_facet, - col_facet = col_facet - ), + spec = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), data = data ) - rule_diff <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - - validates <- list( - x = ~ if (length(.) != 1) "Please select exactly one x var.", - y = ~ if (length(.) != 1) "Please select exactly one y var.", - color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", - size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("row_facet") - ), - add_density = ~ if ( - isTRUE(.) && - ( - length(selector_list()$row_facet()$select) > 0L || - length(selector_list()$col_facet()$select) > 0L - ) - ) { - "Cannot add marginal density when Row or Column facetting has been selected" - } - ) - - anl_merged_q <- reactive({ + validated_q <- reactive({ validate_input( inputId = "x-variables-selected", - condition = length(selectors$x()$variables$selected) > 0, - message = "A `x` variable needs to be selected." + condition = length(selectors$x()$variables$selected) == 1, + message = "Please select exactly one x var." ) validate_input( inputId = "y-variables-selected", - condition = length(selectors$y()$variables$selected) > 0, - message = "A `y` variable needs to be selected." + condition = length(selectors$y()$variables$selected) == 1, + message = "Please select exactly one y var." ) validate_input( inputId = c("x-variables-selected", "y-variables-selected"), @@ -604,6 +520,13 @@ srv_g_scatterplot.picks <- function(id, !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), message = "Row and Column Facetting variables must be different." ) + validate_input( + "add_density", + condition = !(is.null(input$add_density) && + (length(selectors$row_facet()$variables$selected) || length(selectors$col_facet()$variables$selected)) + ), + message = "Cannot add marginal density when Row or Column facetting has been selected" + ) obj <- req(data()) teal.reporter::teal_card(obj) <- c( @@ -611,16 +534,15 @@ srv_g_scatterplot.picks <- function(id, teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj |> - teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") trend_line_is_applicable <- reactive({ - anl <- anl_merged_q()[["anl"]] - x_var <- teal.transform::map_merged(selectors)$x$variables - y_var <- teal.transform::map_merged(selectors)$y$variables + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) }) @@ -633,7 +555,7 @@ srv_g_scatterplot.picks <- function(id, observeEvent( eventExpr = selectors$color_by(), handlerExpr = { - color_by_var <- teal.transform::map_merged(selectors)$color_by$variables + color_by_var <- merged$merge_vars()$color_by if (length(color_by_var) > 0) { shinyjs::hide("color") } else { @@ -645,9 +567,9 @@ srv_g_scatterplot.picks <- function(id, output$num_na_removed <- renderUI({ if (add_trend_line()) { - anl <- anl_merged_q()[["anl"]] - x_var <- teal.transform::map_merged(selectors)$x$variables - y_var <- teal.transform::map_merged(selectors)$y$variables + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) } @@ -658,8 +580,8 @@ srv_g_scatterplot.picks <- function(id, eventExpr = list(selectors$row_facet(), selectors$col_facet()), handlerExpr = { if ( - length(teal.transform::map_merged(selectors)$row_facet$variables) == 0 && - length(teal.transform::map_merged(selectors)$col_facet$variables) == 0 + length(merged$merge_vars()$row_facet) == 0 && + length(merged$merge_vars()$col_facet) == 0 ) { shinyjs::hide("free_scales") } else { @@ -669,14 +591,14 @@ srv_g_scatterplot.picks <- function(id, ) output_q <- reactive({ - req(anl_merged_q()) - anl <- anl_merged_q()[["anl"]] - x_var <- teal.transform::map_merged(selectors)$x$variables - y_var <- teal.transform::map_merged(selectors)$y$variables - color_by_var <- teal.transform::map_merged(selectors)$color_by$variables - size_by_var <- teal.transform::map_merged(selectors)$size_by$variables - row_facet_var <- teal.transform::map_merged(selectors)$row_facet$variables - col_facet_var <- teal.transform::map_merged(selectors)$col_facet$variables + req(merged$data()) + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y + color_by_var <- merged$merge_vars()$color_by + size_by_var <- merged$merge_vars()$size_by + row_facet_var <- merged$merge_vars()$row_facet + col_facet_var <- merged$merge_vars()$col_facet alpha <- input$alpha size <- input$size rotate_xaxis_labels <- input$rotate_xaxis_labels @@ -704,6 +626,7 @@ srv_g_scatterplot.picks <- function(id, message = "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" ) + if (add_density && length(color_by_var) > 0) { validate_input( inputId = "col_facet-variables-selected", @@ -761,7 +684,7 @@ srv_g_scatterplot.picks <- function(id, size } - plot_q <- anl_merged_q() + plot_q <- merged$data() if (log_x) { log_x_fn <- input$log_x_base diff --git a/R/tm_g_scatterplot_old.R b/R/tm_g_scatterplot_old.R index 64d4269e0..08ffd952b 100644 --- a/R/tm_g_scatterplot_old.R +++ b/R/tm_g_scatterplot_old.R @@ -128,7 +128,10 @@ ui_g_scatterplot.default <- function(id, ...) { teal.widgets::standard_layout( output = teal.widgets::white_small_well( teal.widgets::plot_with_settings_ui(id = ns("scatter_plot")), - teal::ui_brush_filter(ns("brush_filter")) + tags$br(), + tags$h1(tags$strong("Selected points:"), style = "font-size: 150%;"), + teal.widgets::get_dt_rows(ns("data_table"), ns("data_table_rows")), + DT::dataTableOutput(ns("data_table"), width = "100%") ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 45e4bd909..deff2e0c0 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -11,9 +11,9 @@ #' @inheritParams tm_g_scatterplot #' @inheritParams shared_params #' -#' @param variables (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param variables (`picks` or `list` of `picks`) #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -#' `data_extract_spec` use `select_spec(..., ordered = TRUE)` if plot elements should be +#' `picks` use `variables(..., ordered = TRUE)` if plot elements should be #' rendered according to selection order. #' #' @inherit shared_params return @@ -94,33 +94,32 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' data_extract_spec( -#' dataname = "countries", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["countries"]]), +#' picks( +#' datasets("countries"), +#' variables( +#' choices = tidyselect::everything(), #' selected = c("area", "gdp", "debt"), #' multiple = TRUE, -#' ordered = TRUE, -#' fixed = FALSE -#' ) -#' ), -#' data_extract_spec( -#' dataname = "sales", -#' filter = filter_spec( -#' label = "Select variable:", -#' vars = "country_id", -#' choices = value_choices(data[["sales"]], "country_id"), -#' selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"), -#' multiple = TRUE +#' ordered = TRUE #' ), -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")), +#' values() +#' ), +#' picks( +#' datasets("sales"), +#' variables( +#' choices = c("quantity", "costs", "profit"), #' selected = c("quantity", "costs", "profit"), #' multiple = TRUE, -#' ordered = TRUE, -#' fixed = FALSE +#' ordered = TRUE +#' ) +#' ) +#' ), +#' transformators = list( +#' teal_transform_filter( +#' picks( +#' datasets("sales"), +#' variables("country_id"), +#' values() #' ) #' ) #' ) @@ -150,35 +149,30 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADSL"]]), +#' picks( +#' datasets("ADSL"), +#' variables( +#' choices = tidyselect::everything(), #' selected = c("AGE", "RACE", "SEX"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) -#' ), -#' data_extract_spec( -#' dataname = "ADRS", -#' filter = filter_spec( -#' label = "Select endpoints:", -#' vars = c("PARAMCD", "AVISIT"), -#' choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")), -#' selected = "INVET - END OF INDUCTION", -#' multiple = TRUE #' ), -#' select = select_spec( -#' label = "Select variables:", -#' choices = variable_choices(data[["ADRS"]]), +#' values() +#' ), +#' picks( +#' datasets("ADRS"), +#' variables( +#' choices = tidyselect::everything(), #' selected = c("AGE", "AVAL", "ADY"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ) #' ) +#' ), +#' transformators = list( +#' teal_transform_filter(picks(datasets("ADRS"), variables("PARAMCD"), values(selected = "BESRSPI"))) #' ) #' ) #' ) @@ -188,7 +182,6 @@ #' } #' #' @export -#' tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", variables, plot_height = c(600, 200, 2000), @@ -331,7 +324,7 @@ srv_g_scatterplotmatrix.picks <- function(id, data = data ) - anl_merged_q <- reactive({ + validated_q <- reactive({ obj <- req(data()) input_ids <- sprintf("%s-variables-selected", names(variables)) @@ -342,25 +335,20 @@ srv_g_scatterplotmatrix.picks <- function(id, message = "Please select at least 2 columns" ) - teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Scatter Plot Matrix"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - obj |> - teal.code::eval_code('library("ggplot2");library("dplyr");') |> # nolint - teal.transform::qenv_merge_selectors(selectors = selectors, output_name = "anl") + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - merge_vars <- reactive( - unname(unlist(lapply(map_merged(selectors), `[[`, "variables"))) - ) - + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merge_vars <- reactive(unname(unlist(merged$merge_vars()))) # plot output_q <- reactive({ - qenv <- req(anl_merged_q()) + qenv <- req(merged$data()) anl <- qenv[["anl"]] cols_names <- merge_vars() alpha <- input$alpha @@ -496,7 +484,7 @@ srv_g_scatterplotmatrix.picks <- function(id, # show a message if conversion to factors took place output$message <- renderText({ cols_names <- req(merge_vars()) - anl <- anl_merged_q()[["anl"]] + anl <- merged$data()[["anl"]] check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { is_single <- sum(check_char) == 1 diff --git a/R/tm_outliers.R b/R/tm_outliers.R index 942a4ad96..945ae5c5e 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -7,9 +7,9 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' -#' @param outlier_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param outlier_var (`picks` or `list` of multiple `picks`) #' Specifies variable(s) to be analyzed for outliers. -#' @param categorical_var (`data_extract_spec` or `list` of multiple `data_extract_spec`) optional, +#' @param categorical_var (`picks` or `list` of multiple `picks`) optional, #' specifies the categorical variable(s) to split the selected outlier variables on. #' @param ggplot2_args `r roxygen_ggplot2_args_param("Boxplot", "Density Plot", "Cumulative Distribution Plot")` #' @@ -66,21 +66,22 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' data_extract_spec( -#' dataname = "CO2", -#' select = select_spec( -#' label = "Select variable:", +#' picks( +#' datasets("CO2"), +#' variables( #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), #' selected = "uptake", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ) #' ), #' categorical_var = list( -#' data_extract_spec( -#' dataname = "CO2", -#' filter = filter_spec( +#' picks( +#' datasets("CO2"), +#' variables(), +#' values( #' vars = vars, #' choices = value_choices(data[["CO2"]], vars$selected), #' selected = value_choices(data[["CO2"]], vars$selected), @@ -118,21 +119,22 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' picks( +#' datasets("ADSL"), +#' variables( #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), #' selected = "AGE", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ) #' ), #' categorical_var = list( -#' data_extract_spec( -#' dataname = "ADSL", -#' filter = filter_spec( +#' picks( +#' datasets("ADSL"), +#' variables(), +#' values( #' vars = vars, #' choices = value_choices(data[["ADSL"]], vars$selected), #' selected = value_choices(data[["ADSL"]], vars$selected), diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 4f7d6868a..3375f68f9 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -5,14 +5,14 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param x (`picks` or `list` of `picks`) #' Object with all available choices with pre-selected option for variable X - row values. -#' In case of `data_extract_spec` use `select_spec(..., ordered = TRUE)` if table elements should be +#' In case of `picks` use `variables(..., ordered = TRUE)` if table elements should be #' rendered according to selection order. -#' @param y (`data_extract_spec` or `list` of multiple `data_extract_spec`) +#' @param y (`picks` or `list` of multiple `picks`) #' Object with all available choices with pre-selected option for variable Y - column values. #' -#' `data_extract_spec` must not allow multiple selection in this case. +#' `picks` must not allow multiple selection in this case. #' @param show_percentage (`logical(1)`) #' Indicates whether to show percentages (relevant only when `x` is a `factor`). #' Defaults to `TRUE`. @@ -82,26 +82,26 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", +#' x = picks( +#' datasets("mtcars"), +#' variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = c("cyl", "gear"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ), -#' y = data_extract_spec( -#' dataname = "mtcars", -#' select = select_spec( -#' label = "Select variable:", +#' y = picks( +#' datasets("mtcars"), +#' variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ) #' ) #' ) @@ -127,10 +127,9 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' x = picks( +#' datasets("ADSL"), +#' variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) #' return(names(data)[idx]) @@ -139,12 +138,12 @@ #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ), -#' y = data_extract_spec( -#' dataname = "ADSL", -#' select = select_spec( -#' label = "Select variable:", +#' y = picks( +#' datasets("ADSL"), +#' variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- vapply(data, is.factor, logical(1)) #' return(names(data)[idx]) @@ -152,7 +151,8 @@ #' selected = "SEX", #' multiple = FALSE, #' fixed = FALSE -#' ) +#' ), +#' values() #' ) #' ) #' ) @@ -163,6 +163,20 @@ #' #' @export #' +tm_t_crosstable <- function(label = "Cross Table", + x, + y, + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { + UseMethod("tm_t_crosstable", x) +} +#' @export tm_t_crosstable <- function(label = "Cross Table", x, y, @@ -176,16 +190,15 @@ tm_t_crosstable <- function(label = "Cross Table", decorators = list()) { message("Initializing tm_t_crosstable") - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(x, types = "data_extract_spec") + checkmate::assert_class(x, "picks") - checkmate::assert_list(y, types = "data_extract_spec") - assert_single_selection(y) + checkmate::assert_class(y, "picks") + if (isTRUE(attr(y$variables, "multiple"))) { + warning("`y` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(y$variables, "multiple") <- FALSE + } checkmate::assert_flag(show_percentage) checkmate::assert_flag(show_total) @@ -197,36 +210,27 @@ tm_t_crosstable <- function(label = "Cross Table", assert_decorators(decorators, "table") # End of assertions - # Make UI args - ui_args <- as.list(environment()) - - server_args <- list( - label = label, - x = x, - y = y, - remove_zero_columns = remove_zero_columns, - basic_table_args = basic_table_args, - decorators = decorators - ) - + args <- as.list(environment()) ans <- module( label = label, - server = srv_t_crosstable, - ui = ui_t_crosstable, - ui_args = ui_args, - server_args = server_args, + server = srv_t_crosstable.picks, + ui = ui_t_crosstable.picks, + ui_args = args[names(args) %in% names(formals(ui_t_crosstable.picks))], + server_args = args[names(args) %in% names(formals(srv_t_crosstable.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) + datanames = { + datanames <- datanames(list(x, y)) + if (length(datanames)) datanames else "all" + } ) + attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the cross-table module -ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { - args <- list(...) +ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, decorators) { ns <- NS(id) - is_single_dataset <- teal.transform::is_single_dataset(x, y) join_default_options <- c( "Full Join" = "dplyr::full_join", @@ -242,15 +246,19 @@ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_c ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(list(x, y)), - teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset), - teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset), - teal.widgets::optionalSelectInput( + teal::teal_nav_item( + label = tags$strong("Row values"), + teal.transform::module_input_ui(id = ns("x"), spec = x) + ), + teal::teal_nav_item( + label = tags$strong("Column values"), + teal.transform::module_input_ui(id = ns("y"), spec = y) + ), + shinyWidgets::pickerInput( ns("join_fun"), label = "Row to Column type of join", choices = join_default_options, - selected = join_default_options[1], - multiple = FALSE + selected = join_default_options[1] ), tags$hr(), bslib::accordion( @@ -262,7 +270,7 @@ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_c checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) ) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table")) + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") @@ -273,40 +281,43 @@ ui_t_crosstable <- function(id, x, y, show_percentage, show_total, remove_zero_c } # Server function for the cross-table module -srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { +srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(x = x, y = y), - datasets = data, - select_validation_rule = list( - x = shinyvalidate::sv_required("Please define column for row variable."), - y = shinyvalidate::sv_required("Please define column for column variable.") + selectors <- teal.transform::module_input_srv(spec = list(x = x, y = y), data = data) + + validated_q <- reactive({ + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) > 0, + message = "Please define column(s) for row variables." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) == 1, + message = "Please define column for column variable." ) - ) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("join_fun", function(value) { - if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { - if (!shinyvalidate::input_provided(value)) { - "Please select a joining function." - } - } - }) - teal.transform::compose_and_enable_validators(iv, selector_list) + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Cross Table"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes }) observeEvent( eventExpr = { - req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) - list(selector_list()$x(), selector_list()$y()) + selectors$x() + selectors$y() }, handlerExpr = { - if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { + if (identical(selectors$x()$datasets$selected, selectors$x()$datasets$selected)) { shinyjs::hide("join_fun") } else { shinyjs::show("join_fun") @@ -314,58 +325,31 @@ srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_t } ) - merge_function <- reactive({ - if (is.null(input$join_fun)) { - "dplyr::full_join" - } else { - input$join_fun - } - }) - - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list, - merge_function = merge_function - ) - qenv <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Cross Table"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes - }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q + merged <- teal.transform::merge_srv( + "merge", + data = validated_q, + selectors = selectors, + output_name = "anl", + join_fun = input$join_fun # todo: make reactive ) output_q <- reactive({ - teal::validate_inputs(iv_r()) - ANL <- merged$anl_q_r()[["ANL"]] + anl <- merged$data()[["anl"]] # As this is a summary - x_name <- as.vector(merged$anl_input_r()$columns_source$x) - y_name <- as.vector(merged$anl_input_r()$columns_source$y) + x_name <- merged$merge_vars()$x + y_name <- merged$merge_vars()$y - teal::validate_has_data(ANL, 3) - teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) validate(need( - all(vapply(ANL[x_name], is_allowed_class, logical(1))), + all(vapply(anl[x_name], is_allowed_class, logical(1))), "Selected row variable has an unsupported data type." )) validate(need( - is_allowed_class(ANL[[y_name]]), + is_allowed_class(anl[[y_name]]), "Selected column variable has an unsupported data type." )) @@ -375,90 +359,69 @@ srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_t plot_title <- paste( "Cross-Table of", - paste0(varname_w_label(x_name, ANL), collapse = ", "), + paste0(varname_w_label(x_name, anl), collapse = ", "), "(rows)", "vs.", - varname_w_label(y_name, ANL), + varname_w_label(y_name, anl), "(columns)" ) - labels_vec <- vapply( - x_name, - varname_w_label, - character(1), - ANL - ) + labels_vec <- vapply(x_name, varname_w_label, character(1), anl) - obj <- merged$anl_q_r() + obj <- merged$data() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") - obj <- teal.code::eval_code( + obj <- within( obj, - substitute( + expr = title <- plot_title, + plot_title = plot_title + ) %>% + within( expr = { - title <- plot_title + table <- basic_tables %>% + split_call %>% # styler: off + rtables::add_colcounts() %>% + tern::analyze_vars( + vars = x_name, + var_labels = labels_vec, + na.rm = FALSE, + denom = "N_col", + .stats = c("mean_sd", "median", "range", count_value) + ) }, - env = list(plot_title = plot_title) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = { - table <- basic_tables %>% - split_call %>% # styler: off - rtables::add_colcounts() %>% - tern::analyze_vars( - vars = x_name, - var_labels = labels_vec, - na.rm = FALSE, - denom = "N_col", - .stats = c("mean_sd", "median", "range", count_value) - ) - }, - env = list( - basic_tables = teal.widgets::parse_basic_table_args( - basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) + basic_tables = teal.widgets::parse_basic_table_args( + basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) + ), + split_call = if (show_total) { + substitute( + expr = rtables::split_cols_by( + y_name, + split_fun = rtables::add_overall_level(label = "Total", first = FALSE) ), - split_call = if (show_total) { - substitute( - expr = rtables::split_cols_by( - y_name, - split_fun = rtables::add_overall_level(label = "Total", first = FALSE) - ), - env = list(y_name = y_name) - ) - } else { - substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) - }, - x_name = x_name, - labels_vec = labels_vec, - count_value = ifelse(show_percentage, "count_fraction", "count") + env = list(y_name = y_name) ) - ) + } else { + substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) + }, + x_name = x_name, + labels_vec = labels_vec, + count_value = ifelse(show_percentage, "count_fraction", "count") ) %>% - teal.code::eval_code( - expression(ANL <- tern::df_explicit_na(ANL)) + within(anl <- tern::df_explicit_na(anl)) + + obj <- if (remove_zero_columns) { + within( + obj, + { + anl[[y_name]] <- droplevels(anl[[y_name]]) + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]) + }, + y_name = y_name ) - - if (remove_zero_columns) { - obj <- obj %>% - teal.code::eval_code( - substitute( - expr = { - ANL[[y_name]] <- droplevels(ANL[[y_name]]) - table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) - }, - env = list(y_name = y_name) - ) - ) } else { - obj <- obj %>% - teal.code::eval_code( - substitute( - expr = { - table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) - }, - env = list(y_name = y_name) - ) - ) + within( + obj, + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]), + y_name = y_name + ) } obj }) @@ -473,8 +436,8 @@ srv_t_crosstable <- function(id, data, label, x, y, remove_zero_columns, basic_t output$title <- renderText(req(decorated_output_q())[["title"]]) table_r <- reactive({ - req(iv_r()$is_valid()) - req(decorated_output_q())[["table"]] + obj <- req(decorated_output_q()) + tail(teal.code::get_outputs(obj), 1)[[1]] }) teal.widgets::table_with_settings_srv( diff --git a/R/tm_t_crosstable_old.R b/R/tm_t_crosstable_old.R new file mode 100644 index 000000000..94b8753f2 --- /dev/null +++ b/R/tm_t_crosstable_old.R @@ -0,0 +1,331 @@ +#' @export +tm_t_crosstable.default <- function(label = "Cross Table", + x, + y, + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_t_crosstable") + + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_list(x, types = "data_extract_spec") + + checkmate::assert_list(y, types = "data_extract_spec") + assert_single_selection(y) + + checkmate::assert_flag(show_percentage) + checkmate::assert_flag(show_total) + checkmate::assert_flag(remove_zero_columns) + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_class(basic_table_args, classes = "basic_table_args") + + assert_decorators(decorators, "table") + # End of assertions + + # Make UI args + ui_args <- as.list(environment()) + + server_args <- list( + label = label, + x = x, + y = y, + remove_zero_columns = remove_zero_columns, + basic_table_args = basic_table_args, + decorators = decorators + ) + + ans <- module( + label = label, + server = srv_t_crosstable.default, + ui = ui_t_crosstable.default, + ui_args = ui_args, + server_args = server_args, + transformators = transformators, + datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the cross-table module +ui_t_crosstable.default <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { + args <- list(...) + ns <- NS(id) + is_single_dataset <- teal.transform::is_single_dataset(x, y) + + join_default_options <- c( + "Full Join" = "dplyr::full_join", + "Inner Join" = "dplyr::inner_join", + "Left Join" = "dplyr::left_join", + "Right Join" = "dplyr::right_join" + ) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("title")), + teal.widgets::table_with_settings_ui(ns("table")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(list(x, y)), + teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset), + teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset), + teal.widgets::optionalSelectInput( + ns("join_fun"), + label = "Row to Column type of join", + choices = join_default_options, + selected = join_default_options[1], + multiple = FALSE + ), + tags$hr(), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Table settings", + checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage), + checkboxInput(ns("show_total"), "Show total column", value = show_total), + checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) + ) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table")) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the cross-table module +srv_t_crosstable.default <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(x = x, y = y), + datasets = data, + select_validation_rule = list( + x = shinyvalidate::sv_required("Please define column for row variable."), + y = shinyvalidate::sv_required("Please define column for column variable.") + ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("join_fun", function(value) { + if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { + if (!shinyvalidate::input_provided(value)) { + "Please select a joining function." + } + } + }) + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + observeEvent( + eventExpr = { + req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) + list(selector_list()$x(), selector_list()$y()) + }, + handlerExpr = { + if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { + shinyjs::hide("join_fun") + } else { + shinyjs::show("join_fun") + } + } + ) + + merge_function <- reactive({ + if (is.null(input$join_fun)) { + "dplyr::full_join" + } else { + input$join_fun + } + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, + merge_function = merge_function + ) + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Cross Table"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + output_q <- reactive({ + teal::validate_inputs(iv_r()) + ANL <- merged$anl_q_r()[["ANL"]] + + # As this is a summary + x_name <- as.vector(merged$anl_input_r()$columns_source$x) + y_name <- as.vector(merged$anl_input_r()$columns_source$y) + + teal::validate_has_data(ANL, 3) + teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) + + is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) + validate(need( + all(vapply(ANL[x_name], is_allowed_class, logical(1))), + "Selected row variable has an unsupported data type." + )) + validate(need( + is_allowed_class(ANL[[y_name]]), + "Selected column variable has an unsupported data type." + )) + + show_percentage <- input$show_percentage + show_total <- input$show_total + remove_zero_columns <- input$remove_zero_columns + + plot_title <- paste( + "Cross-Table of", + paste0(varname_w_label(x_name, ANL), collapse = ", "), + "(rows)", "vs.", + varname_w_label(y_name, ANL), + "(columns)" + ) + + labels_vec <- vapply( + x_name, + varname_w_label, + character(1), + ANL + ) + + obj <- merged$anl_q_r() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") + obj <- teal.code::eval_code( + obj, + substitute( + expr = { + title <- plot_title + }, + env = list(plot_title = plot_title) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = { + table <- basic_tables %>% + split_call %>% # styler: off + rtables::add_colcounts() %>% + tern::analyze_vars( + vars = x_name, + var_labels = labels_vec, + na.rm = FALSE, + denom = "N_col", + .stats = c("mean_sd", "median", "range", count_value) + ) + }, + env = list( + basic_tables = teal.widgets::parse_basic_table_args( + basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) + ), + split_call = if (show_total) { + substitute( + expr = rtables::split_cols_by( + y_name, + split_fun = rtables::add_overall_level(label = "Total", first = FALSE) + ), + env = list(y_name = y_name) + ) + } else { + substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) + }, + x_name = x_name, + labels_vec = labels_vec, + count_value = ifelse(show_percentage, "count_fraction", "count") + ) + ) + ) %>% + teal.code::eval_code( + expression(ANL <- tern::df_explicit_na(ANL)) + ) + + if (remove_zero_columns) { + obj <- obj %>% + teal.code::eval_code( + substitute( + expr = { + ANL[[y_name]] <- droplevels(ANL[[y_name]]) + table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) + }, + env = list(y_name = y_name) + ) + ) + } else { + obj <- obj %>% + teal.code::eval_code( + substitute( + expr = { + table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) + }, + env = list(y_name = y_name) + ) + ) + } + obj + }) + + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "table"), + expr = quote(table) + ) + + output$title <- renderText(req(decorated_output_q())[["title"]]) + + table_r <- reactive({ + req(iv_r()$is_valid()) + req(decorated_output_q())[["table"]] + }) + + teal.widgets::table_with_settings_srv( + id = "table", + table_r = table_r + ) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Show R Code for Cross-Table" + ) + decorated_output_q + }) +} diff --git a/R/tm_variable_browser.R b/R/tm_variable_browser.R index 8991319c7..181f62a06 100644 --- a/R/tm_variable_browser.R +++ b/R/tm_variable_browser.R @@ -263,7 +263,18 @@ srv_variable_browser <- function(id, establish_updating_selection(datanames, input, plot_var, columns_names) # validations - validation_checks <- validate_input(input, plot_var, data) + validation_checks <- reactive({ + dataset_name <- req(input$tabset_panel) + varname <- plot_var$variable[[dataset_name]] + + validate(need(dataset_name, "No data selected")) + validate(need(varname, "No variable selected")) + df <- data()[[dataset_name]] + teal::validate_has_data(df, 1) + teal::validate_has_variable(varname = varname, data = df, "Variable not available") + + TRUE + }) # data_for_analysis is a list with two elements: a column from a dataset and the column label plotted_data <- reactive({ @@ -776,29 +787,6 @@ is_num_var_short <- function(.unique_records_for_factor, input, data_for_analysi length(unique(data_for_analysis()$data)) < .unique_records_for_factor && !is.null(input$numeric_as_factor) } -#' Validates the variable browser inputs -#' -#' @param input (`session$input`) the `shiny` session input -#' @param plot_var (`list`) list of a data frame and an array of variable names -#' @param data (`teal_data`) the datasets passed to the module -#' -#' @returns `logical` TRUE if validations pass; a `shiny` validation error otherwise -#' @keywords internal -validate_input <- function(input, plot_var, data) { - reactive({ - dataset_name <- req(input$tabset_panel) - varname <- plot_var$variable[[dataset_name]] - - validate(need(dataset_name, "No data selected")) - validate(need(varname, "No variable selected")) - df <- data()[[dataset_name]] - teal::validate_has_data(df, 1) - teal::validate_has_variable(varname = varname, data = df, "Variable not available") - - TRUE - }) -} - get_plotted_data <- function(input, plot_var, data) { dataset_name <- input$tabset_panel varname <- plot_var$variable[[dataset_name]] @@ -889,7 +877,6 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, output[[table_ui_id]] <- DT::renderDataTable({ df <- data()[[dataset_name]] - get_vars_df <- function(input, dataset_name, parent_name, data) { data_cols <- colnames(df) if (isTRUE(input$show_parent_vars)) { @@ -935,7 +922,7 @@ render_tab_table <- function(dataset_name, parent_dataname, output, data, input, join_keys <- teal.data::join_keys(data()) if (!is.null(join_keys)) { - icons[intersect(teal.data::join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" + icons[intersect(join_keys[dataset_name, dataset_name], colnames(df))] <- "primary_key" } icons <- variable_type_icons(icons) diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd index 988dc6eec..d1dcbc08a 100644 --- a/man/srv_decorate_teal_data.Rd +++ b/man/srv_decorate_teal_data.Rd @@ -10,11 +10,6 @@ srv_decorate_teal_data(id, data, decorators, expr) ui_decorate_teal_data(id, decorators, ...) } \arguments{ -\item{id}{(\code{character(1)}) \code{shiny} module instance id.} - -\item{data}{(\code{teal_data}, \code{teal_data_module}, or \code{reactive} returning \code{teal_data}) -The data which application will depend on.} - \item{expr}{(\code{reactive}) with expression to evaluate on the output of the decoration. It must be compatible with \code{code} argument of \code{\link[teal.code:eval_code]{teal.code::eval_code()}}. Default is \code{NULL} which won't evaluate any appending code.} diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index f980a4d62..4d99a7cc8 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -6,8 +6,7 @@ \usage{ tm_a_pca( label = "Principal Component Analysis", - dat = picks(datasets(), variables(choices = tidyselect::where(is.numeric), selected = - 1:5, multiple = TRUE)), + dat, plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -23,11 +22,7 @@ tm_a_pca( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{dat}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -specifying columns used to compute PCA.} +\item{dat}{(\code{picks}) specifying columns used to compute PCA.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} @@ -74,9 +69,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -138,16 +130,13 @@ app <- init( modules = modules( tm_a_pca( "PCA", - dat = data_extract_spec( - dataname = "USArrests", - select = select_spec( - choices = variable_choices( - data = data[["USArrests"]], c("Murder", "Assault", "UrbanPop", "Rape") - ), + dat = picks( + datasets("USArrests"), + variables( + choices = c("Murder", "Assault", "UrbanPop", "Rape"), selected = c("Murder", "Assault"), multiple = TRUE - ), - filter = NULL + ) ) ) ) @@ -169,17 +158,13 @@ app <- init( data = data, modules = modules( tm_a_pca( - "PCA", - dat = data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices( - data = data[["ADSL"]], c("BMRKR1", "AGE", "EOSDY") - ), + dat = picks( + datasets("ADSL"), + variables( + choices = c("BMRKR1", "AGE", "EOSDY"), selected = c("BMRKR1", "AGE"), multiple = TRUE - ), - filter = NULL + ) ) ) ) @@ -192,13 +177,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2+ye4VIzA0SVEqDgBGuHxBmWg8DBX0mwzEM0B72RojgIg0YMJxNIsPhiPxyN0BAKRFoBDEYK0LFoUHoIiS9MZzNESNpyNSYNSwGAmMG2NGXwAurKytSwABZQSMfgyQGfMADUSiKDCUhazGMehQCDfIioY1gLBoOBfbpC25yIHOqpkhHkfhgpWq9WavDa3X6w2Ot3umCG2hRPR7BwuGkuiO0ky0ajkRhggByjgAMnmk06XZtut1aCZdOwVJn1JodDZbBUbqIihBWAN0OxlgASBplXuExg6LrzJRgOayoA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2ulQtAIAGtRNcPiDMqI4DMNmBJsMxDMvnIgfDbloWLQoPRTnC8bcCAUiJCxGCCKiALKCRj8GSAz5gAaiURQYSkdlfRyMehQCDfIioAVgLBoODY3HkqpIkQaOD8OmM5msxhSrk8vny97kmB82hRPR7BwuI0fbp4u23B3dbq0Ey6dgqcjMSw6Gy2Co3URFCCsAbodjLAAkDTKUaRjB0XXmSjAcwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY3QKMAABW8QzJsMxJKSyKy6RipGYGnSolQcAIGJJ9Ly7z0ULJizGNOJfNEcBEGmRUplV053N5fJJBFKmwIYmRWhYtCg9BE1w1tC1BwlqvqWUZeWAwBFozFYG+32qPLJACEALJYADSWAAjDTSWAhgBxVx4EPOADygV8AE0yQNLVi5LTU-V5dzyPxke6wN6-YHgyKI8mM5mYJdaPEhfYnK46Xz0xasSZaNRyIxkQA5RxjMXN+optOggYDWgmXTsFTd9SaHQ2Wy1TGicoQVhDdDsf4AEla1X3UsYOn6KyUYGW3yAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY6HI1C0AjbA7EknQqCiOCkalgRZjBRgOSwzG03RaFi0KD0REYnkkgilTYEMTIgggsAAIQAslgANJYACM7Oq7KGAHFXHhdOznAB5QK+ACa7M5NJ5DJEGjg-BlcqVqo1WqNLP11q5oqxMEutHieihDhctqxAx50ajoIGA1oJl07BU5GYlh0NlstUxonKEFYQ3Q7H+ABJWtVywzGDp+islGBlt8gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index a3afc9bfc..51df8f750 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -6,10 +6,8 @@ \usage{ tm_a_regression( label = "Regression Analysis", - regressor = picks(datasets(), variables(choices = tidyselect::where(is.numeric), - selected = -1, multiple = TRUE)), - response = picks(datasets(), variables(choices = tidyselect::where(is.numeric)), - values(selected = tidyselect::everything(), multiple = TRUE)), + regressor, + response, plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -26,14 +24,13 @@ tm_a_regression( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} +\item{regressor}{(\code{picks}) Specification for regressor variables selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting variables +to use as regressors in the regression model. \code{variables(multiple = TRUE)} allowed.} -\item{regressor}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Regressor variables from an incoming dataset with filtering and selecting.} - -\item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Response variables from an incoming dataset with filtering and selecting.} +\item{response}{(\code{picks}) Specification for response variable selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a single numeric variable +to use as the response in the regression model. \code{variables(multiple = TRUE)} not allowed.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} @@ -81,8 +78,6 @@ adding context or further instructions. Elements like \code{shiny::helpText()} a \item Cook's dist vs Leverage }} -\item{default_outlier_label}{(\code{character}) optional, default column selected to label outliers.} - \item{label_segment_threshold}{(\code{numeric(1)} or \code{numeric(3)}) Minimum distance between label and point on the plot that triggers the creation of a line segment between the two. @@ -99,13 +94,14 @@ It takes the form of \code{c(value, min, max)} and it is passed to the \code{val argument in \code{teal.widgets::optionalSliderInputValMinMax}. }} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. The decorators are applied to the respective output objects.} + +\item{outlier}{(\code{picks}) Optional specification for outlier label variable selection. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a factor or character variable +to label outlier points on the plots.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -161,25 +157,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = "uptake", - selected = "uptake", - multiple = FALSE, - fixed = TRUE - ) + response = picks( + datasets("CO2"), + variables(choices = "uptake", selected = "uptake") ), - regressor = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["CO2"]], c("conc", "Treatment")), - selected = "conc", - multiple = TRUE, - fixed = FALSE - ) + regressor = picks( + datasets("CO2"), + variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) ) ) ) @@ -201,25 +185,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = "BMRKR1", - selected = "BMRKR1", - multiple = FALSE, - fixed = TRUE - ) + response = picks( + datasets("ADSL"), + variables(choices = "BMRKR1", selected = "BMRKR1") ), - regressor = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADSL"]], c("AGE", "SEX", "RACE")), - selected = "AGE", - multiple = TRUE, - fixed = FALSE - ) + regressor = picks( + datasets("ADSL"), + variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) ) ) ) @@ -232,13 +204,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2qSS4VIzA0SVEqDgBDe7wuqWg8EO-zG4OWuN0cJEGkOlKxpHRmOxZPJuk+31+un+AGUfnTdFoWLQviJEKTISyCAUiLQCGIiWBBKhggBrOBilkXWkaOD8eWKlVqvDM8kwYSaKLw3QAMQAggAZLnOCEaqomWhhHWHBwuY0XbrkuTO3H3R6iTqHRHI1H0jFYnHk-GwS3Eobqlla0g03lo2NM8Xktk-eU8qmZgWMIX0faio353GS6Wyg4bcuVkRJBsy06pYDAFPjMAAXUHZSZhBIBHBnLAdhqQXgZH+ckDvveGc9f3HFjTGtN1HNIi9Tidq4ubo9uo2todrjrVX9uIf9+W3W6tBMunYKnI0e0cBstgVOcohFBArA2ug7CzAAJA0ZQwXCjA6F0kxKGAEyDkAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2qFoBAA1qI3u8Lqk4aQ0f8xv85BCMRctCxaF99uwCAUiEixId-oJUMFkXBwbo4SINHB+AywEyWWywN1iYTllCgY9RJ1DoiUbjIRisXAcUswPjhUTibpSYxyfRKdTaQR6RsCGriBZ2f87DUgvAyASypy4NzeX9CCQCOyYMJNFF4fYnM4RRjQ1VQ91urQTLp2CpyMxLDobLYKudREUIKwAILodizAAkDTKRbhjB0XUmSjAEwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIZk0tFSMwNGlRKg4AQyeTMZk3vzdPSFqN2SDZbo+SINEitVLLhKpTKNXVKdTaZD6QEafrdFoWLQqSJEGrOSaCCUNgQxHSwAAhACyWAA0lgAIyuk2YvUaOD8X2BkPhyNR5EXWhxRUAMUGowCzg5qdMtCicaRDhc6tl-Q1ckLsvxhNEvSRguFooNkulVfJ8tgiuVI1VeB70ZtOshMc7RtH5LNNN91u1pDtDqdYhdI7dGo9Xp9kPtjEd9BEV09tG9H1ywGAg8WYC+Xyq3bAgwA4q48EqwPmABrs78sEGLxPzkOtZzHZcy0tV8PxTKMYHTTNyycAsILqEwS2g3QczzVxt0xGtqyrIj+n6WgTF0dgVHIDttDgGxbBqDFRDKCBWEGdB2DQVAABIWiqHjeL5RgdD6ZYlDAJYviAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIahaAQtvsQeS6pk+aRRWAFqN6XIOeLMVoWLQqQj2AQShsCGI6WAAEIAWSwAGksABGdm6PkiDRwfgGk3mq0KsWYxUeur4wmiXpIwXC0Wc8WSuDS4GykbysBe0Pk1WMdX0TXa3X6yEEKODADirjwunpAWcAA0bfSsIMvAXFbaaXAHU7IfS8wWqjALrQ4vz7E5nP1lYPPSD+v1aCZdOwVORmJYdDZbDUMaIyhBWIN0Ow0KgACQtKo73d8xg6PrLJRgJZfIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index e5084fbf8..629bc71bd 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -19,9 +19,6 @@ tm_data_table( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{variables_selected}{(\verb{named list}) Character vectors of the variables (i.e. columns) which should be initially shown for each dataset. Names of list elements should correspond to the names of the datasets available in the app. @@ -31,15 +28,6 @@ dataset will initially be shown.} \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A vector of datasets which should be shown and in what order. Use \code{datanames} instead.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{dt_args}{(\verb{named list}) Additional arguments to be passed to \code{\link[DT:datatable]{DT::datatable()}} (must not include \code{data} or \code{options}).} @@ -55,9 +43,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index a1617b9db..839a410d5 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -10,9 +10,6 @@ tm_file_viewer( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{input_path}{(\code{list}) of the input paths, optional. Each element can be: Paths can be specified as absolute paths or relative to the running directory of the application. diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 36a288b5a..60556c83a 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -16,9 +16,6 @@ tm_front_page( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{header_text}{(\code{character} vector) text to be shown at the top of the module, for each element, if named the name is shown first in bold as a header followed by the value. The first element's header is displayed larger than the others.} @@ -35,18 +32,6 @@ element, if named the name is shown first in bold, followed by the value.} \item{show_metadata}{(\code{logical}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} indicating whether the metadata of the datasets be available on the module. Metadata shown automatically when \code{datanames} set.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 40501bcd3..1fb99811e 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -27,15 +27,11 @@ tm_g_association( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} +\item{ref}{(\code{picks}) +Reference variable specification created using \code{picks()}.} -\item{ref}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Reference variable, must accepts a \code{data_extract_spec} with \code{select_spec(multiple = FALSE)} -to ensure single selection option.} - -\item{vars}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variables to be associated with the reference variable.} +\item{vars}{(\code{picks}) +Variables to be associated with the reference variable, specified using \code{picks()}.} \item{show_association}{(\code{logical}) optional, whether show association of \code{vars} with reference variable. Defaults to \code{TRUE}.} @@ -62,9 +58,6 @@ List names should match the following: \code{c("default", "Bivariate1", "Bivaria For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -123,23 +116,19 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = "Plant", - fixed = FALSE + ref = picks( + datasets("CO2"), + variables( + choices = c("Plant", "Type", "Treatment"), + selected = "Plant" ) ), - vars = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), + vars = picks( + datasets("CO2"), + variables( + choices = c("Plant", "Type", "Treatment"), selected = "Treatment", - multiple = TRUE, - fixed = FALSE + multiple = TRUE ) ) ) @@ -161,29 +150,19 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["ADSL"]], - c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") - ), - selected = "RACE", - fixed = FALSE + ref = picks( + datasets("ADSL"), + variables( + choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), + selected = "RACE" ) ), - vars = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices( - data[["ADSL"]], - c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2") - ), + vars = picks( + datasets("ADSL"), + variables( + choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), selected = "BMRKR2", - multiple = TRUE, - fixed = FALSE + multiple = TRUE ) ) ) @@ -197,13 +176,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz4wlBRJhUjMDSJUSoOAEPn8+kpOZ6AkKMCjdXEumK3SiOAiDTC-WG0jS2Xy8a6yoA+gG4XqgDKBrlpF0e0YXPoIkQWqt1thRBuYmFHq9IkSgeDCxSwGA6s1YB+kN0lrAAAUAWQtbp1XZWLKc3nqoF4NmwC9tdb6SbXXB+A6M1nSH6ddaTLRQvXhYsAIKPR2uNv8t6KuRVxUeikiqBi0ISybmuUK3XK2Cq3Mawat6u1o0EvdmmXL-26232tVgZ2m90scNiX14U+KqMEEMEsNQb1wSP5INvmMMjjBNtyTFM00zKBy1KPMCzgIswDsEtGQoFsK3HZ9+UPbtLyQuBS1Qndq10GBhE0SIN22ZwJ2rDsuwbAk+wHIdq1HEd-VHLouloIUNlUSVNB0GxbHKOlREKCBWF7dB2H2AASeooXQOT9UYHROiUJElDAJEfiAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz43SoG4AawW435lRSojgpElYFGCjAcmJdOluj2jC59HJfM19NhRBuYmFBGxYAACgCyCrSiq7KxUHB7bpHdVAvA7ar1Yb6XKRBo4PxhSqbVAfVLpW8Y37pdqKSLxZKNdLZfLFcrfdH+drdfrc9Ljaakxbw7bSG7Hc7XXh3WA7J7GRQqzm05rA3Bg6GCR64F7W-ai-yYMJNJE9ATtq4O-TY-yF7pY10urQhRtVMxLDobLZynTRIUIKwAILodj7AAk9Sh6CvcsYOk6SiRSjASJ+QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEjMmloqRmBo0qJUHACBTKZjMm89JCFGAFqMBTCMVzdKI4CINEjJdLLqz2ZzxXVqFB6FKkQKAlL2aRdFoWCT6CJECKQSrdAQShsCGIkYbGMaRFcbbQ7fsLZaoVBgMABUKBV8vqLvZiOdrnAANEW6AVYQZeVx4ONgLwAeUcADkHABNWMBrAAWQLYACDkGdkGAEZS+WE1WAEylvx2OwAMWFKYFACEi1gANJYZtgfphuSh71yvVwfhasAJpPmsUqky0KKzpHtwajAKuFeUsdcideuqOxGQukMpkKtkRg-c3K8+eBvCnzHTmWQz+3pXvylqhq1Dzjq8oGka6oImab4PpS1q2vakKOs6cCughnqwVymR+gGIxdsGk5hhGZbRqWi7JlUAoZtmealoMxZ1hWVa1t2ZZMYMI6UWArYdl2XF9oOw4CkelonphdQ-pu-JgAJQ6cf+mIwBctBxHy9hOM4hGruuUm6Nuu77qJ74iboR79P0tA0uwKjkDe2hwDYtg1BiohlBArCDOg7BoKgAAkLRVD5vmSowOh9MsShgEsXxAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEjULQCFt9iDKXVMqI4KQmWAFqMFGA5DCMSzdFoWCT6AiKcLMQQShsCGIkQRgWAAs4ABp8qp8rCDLyuPC6PleADyjgAcg4AJpao3crAAWVtfICDkGdkGAEZnaq3R6AEw+vx2OwAMV5hr5ACEHVgANJYQP8wXSzHskQaOD8JE6vUG5ks-rCgUFuqixiIyF0hlMoUstkcrk8vkluuU8viyWllmy+WKyHKl0an26-U+00W60+waOn2u3Ue72R30LwZJ7VgYNhiMbmPxxMtlOp3TpuCZ7OQ6OxhPr7uUmAXWhxPSQhwuO+6IuFgtf-r9Wg0uwKjkMwlg6DYtg1BiohlBArCDOg7BoKgAAkLRVMhKHsowOh9MsShgEsXxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 51dced013..b95d33303 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -33,39 +33,33 @@ tm_g_bivariate( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} +\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. +Can be numeric, factor or character. No empty selections are allowed.} -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable names selected to plot along the x-axis by default. -Can be numeric, factor or character. -No empty selections are allowed.} - -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable names selected to plot along the y-axis by default. +\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. Can be numeric, factor or character.} -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) to use for faceting rows.} +\item{row_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting rows. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) to use for faceting columns.} +\item{col_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting columns. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{facet}{(\code{logical}) optional, specifies whether the facet encodings \code{ui} elements are toggled on and shown to the user by default. Defaults to \code{TRUE} if either \code{row_facet} or \code{column_facet} are supplied.} -\item{color}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the outline color inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{color}{(\code{picks}) optional, specification of the data variable(s) selected for the outline color +inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{fill}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the fill color inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{fill}{(\code{picks}) optional, specification of the data variable(s) selected for the fill color +inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} -\item{size}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, -specification of the data variable(s) selected for the size of \code{geom_point} plots inside the coloring settings. -It will be applied when \code{color_settings} is set to \code{TRUE}.} +\item{size}{(\code{picks}) optional, specification of the data variable(s) selected for the size of +\code{geom_point} plots inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{use_density}{(\code{logical}) optional, indicates whether to plot density (\code{TRUE}) or frequency (\code{FALSE}). Defaults to frequency (\code{FALSE}).} @@ -105,9 +99,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -165,42 +156,22 @@ data <- within(data, { app <- init( data = data, modules = tm_g_bivariate( - x = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "conc", - fixed = FALSE - ) + label = "Bivariate Plots", + x = picks( + datasets("CO2"), + variables(selected = "conc") ), - y = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + y = picks( + datasets("CO2"), + variables(selected = "uptake") ), - row_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "Type", - fixed = FALSE - ) + row_facet = picks( + datasets("CO2"), + variables(selected = "Type") ), - col_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]]), - selected = "Treatment", - fixed = FALSE - ) + col_facet = picks( + datasets("CO2"), + variables(selected = "Treatment") ) ) ) @@ -219,42 +190,22 @@ join_keys(data) <- default_cdisc_join_keys[names(data)] app <- init( data = data, modules = tm_g_bivariate( - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "AGE", - fixed = FALSE - ) + label = "Bivariate Plots", + x = picks( + datasets("ADSL"), + variables(selected = "AGE") ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "SEX", - multiple = FALSE, - fixed = FALSE - ) + y = picks( + datasets("ADSL"), + variables(selected = "SEX") ), - row_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "ARM", - fixed = FALSE - ) + row_facet = picks( + datasets("ADSL"), + variables(selected = "ARM") ), - col_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]]), - selected = "COUNTRY", - fixed = FALSE - ) + col_facet = picks( + datasets("ADSL"), + variables(selected = "COUNTRY") ) ) ) @@ -266,13 +217,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VuqGnu4lhpMwaiaKocAITxeLxS0Hg7wUYGmUP2zxBojgIg070RyNIfwBQI2IMq1Cg9CRkLAAGUkYDSLotHcCSJELCcbiCPkiLQCGJ3tTGPd6CJEszWezRMUMsBgFCYWAALpSuRw3EvNEUuD8YnECwM+G4ky0UIq94AMQAggAZEmuLWVLoguWM1jvFKfULfdQY-6A4G4sGwPQ7CWDTUKpUonbBt1Yz0K-GEvx+0nklFcnl0wMK3QCtkcnZJ2lwfkszPClJi-0DKEy22WxUJ8iquOCVBBADWcFTCpgwk0kV9umNZuc8rTOr1dd7pvNjKtjMrIMYRGyiRM6jglJ2jq+P3DHsnu3BPdLber6NRNcx26reIJRLjZOPOd5cHpeB3lQzQs5NIf+cFYhFQRL0IBtKsqDkGNb6nGdisACh4gsOEFjv2O7Wi8M4vG0i7LquHwbq6Z7YlW3oQnGkqgUeFInui+GRri0bXroUK3hR94ps+F7pgW77Zp+fJvr+xbioBZbAWhYHoghUJ2NUgTwGQsEvPBo59hOVYoVOzxdF0tAmLo7AqOQm7aI8ci2OUzyiIUECsEa6DsEsAAk9SlA5iKMDonRKLMShgLMUpAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VutRQ9HB+OwpgAEK3jHu5F0AAV2qRRD99s9KqFTrpULQCABrURPF4vFKiOAQ9ZgaY-OTQjGVLR3d7HdjYkQaOD8eE-YgWQkbSpE1m6VjwxEotEcypYnF8-GDQnEklkwEUsRUz5wWn075gQSoILIuAsmG6dlaxhEbKJEzqHHcpGo9EkwW4n4EsA6km6SX3eiU6ny8iK3Q-OysVAau0c+0vNqG42kU28i0Yq3C21BjFO6Vot0KhlgOzVQLwMiajFdNlKLq0Ey6dgqcjMSw6Gy2crPUSFCCsACC6HYSwAJPVSp3sYwdJ0lLMlGBZgBdIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rookjMmloqRmBo0qJUHACHiCQTMm89JCFGAFqM2TD8QzRHARBokXyBZdqbT6QyCdQoPR+Ui2QF+bTSLotFiZSJEFyQZLdAQShsCGIkWrGNj6CIrgbaEaPrlgMA2Ry2V8vnJubq6sLlXB+PL2QBxVx4HWSky0KK+pEAMUGowCrh5BP6DPdodYxNypKi5PUoppdNDdSZsBZuidI05IaTXqVgsh3spYsLNalMrlrLAipFqvVFrgWurnr11ttJr7lv1hrEB3CDorizArrTrdrIqjnYTAA1tavdDALrQ4mXY-HnB7PeHI37IaeE0XdCnkxe6owiAU0mcjSrISSyRT83FB8S3gf1nSHSVGx-XQoKpAsJV1aVZWof1u2VXszQ1Add2HKcbWNSFTXNSdRxnTJ53ZSsXTdF9ILrcgb3LdksAAWRwy8Iw3XQ70TXUnzqFcGW6T91DgaC-xzAC4KA1sQLLBcq1otd0IbejpJbYckI7Ji0MFIisMHJSCTwsdCInOArWnO050dSjF2XIzlI0Li2S8AB5RwADkHAATXY3Ury4niH34x8QX6fpaBMXR2BUcgAO0XE5FsGp8VEMoIFYQZ0HYNBUAAEhaKo8vyvlGB0PpliUMAli+IA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rpqFB6HBqEiFGAAEKYxjY8i6AAKPVIogpMPxdSiSNQtAIW32IIJUKgojgLOBYAWowpcnZQrqWixxIR7FFIg0cH45MlAHFXGB+kLZYLdKxubz+Xj5cLReKKVKZXL5YracqxKrSXANVrIRSAs4ABoyk3Gjn1IgFNJnAhi818gVhuqZW0CyUjaUGp1Cl3Y+gqtVe8g+3T2rAAWWDYdDQu6UfUschPPjVvlybFqYdmZNCqVefdBe92q8AHlHAA5BwATUrRpB-X6tBMunYKnIzEsOhsthq+NEZQgrEG6HYaFQABIWlVT2fRYwdH1lkowEsvkA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index e9d356930..4034c9935 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -22,16 +22,13 @@ tm_g_distribution( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{dist_var}{(\code{picks} or \code{list} of multiple \code{picks}) Variable(s) for which the distribution will be analyzed.} -\item{strata_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{strata_var}{(\code{picks} or \code{list} of multiple \code{picks}) Categorical variable used to split the distribution analysis.} -\item{group_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{group_var}{(\code{picks} or \code{list} of multiple \code{picks}) Variable used for faceting plot into multiple panels.} \item{freq}{(\code{logical}) optional, whether to display frequency (\code{TRUE}) or density (\code{FALSE}). @@ -65,9 +62,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -121,9 +115,10 @@ app <- init( data = data, modules = list( tm_g_distribution( - dist_var = data_extract_spec( - dataname = "iris", - select = select_spec(variable_choices("iris"), "Petal.Length") + dist_var = picks( + datasets("iris"), + variables(tidyselect::where(is.numeric)), + values(selected = "Petal.Length") ) ) ) @@ -139,37 +134,22 @@ data <- within(data, { }) join_keys(data) <- default_cdisc_join_keys[names(data)] -vars1 <- choices_selected( - variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), - selected = NULL -) - app <- init( data = data, modules = modules( tm_g_distribution( - dist_var = data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), - selected = "BMRKR1", - multiple = FALSE, - fixed = FALSE - ) + dist_var = picks( + datasets("ADSL"), + variables(c("BMRKR1", "AGE")), + values(multiple = FALSE) ), - strata_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = vars1, - multiple = TRUE - ) + strata_var = picks( + datasets("ADSL"), + variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ), - group_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = vars1, - multiple = TRUE - ) + group_var = picks( + datasets("ADSL"), + variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ) ) ) @@ -182,13 +162,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDo1CJYdvqpImiqHAEi0dHKdDwFwpg1bU-4yWb0qojgIg0F1B4Puj2e7DONSg9BEiQI+SItAIYj6v0aPzkpR+AAU4EEeAAZCgSAr4w7LNpHBm6NptWgmXTsFTkZiWHQ2WzlIGiQoQVgAQXQ7E6ABJBLRSjLQYwdIw2s0lGBmgBdIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDuqi0BADWootHRymicKT3CmDVtR9y40uPlTONSg9GmnFo-FYLxEGkQiGy+RkcHYtQwEEE8BqBDkv0OjzO1EEYnY0LgGjg-AuHwACq9uBgADIUCQFH54yptI6c3RtNq0Ey6FGqZiWHQ2Wzlf6iQoQVgAQXQ7E6ABJBLRSiqXowdIw2s0lGBmgBdIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTcILRZRAEY2ghLxgjE00TgRDTh+dlqujujFoUHoIk2r1o73OuWAwAUYD6zURl0uVQIAKRWAAsoiqoivAB5RwAOQcAE18bpEQFnAANRFyOS4QFfH7kfi6AC8ulJjmaKIgwyUaFQbRUxQBEDqmR5IVyrJluj4QhEonlquEYmldTqpBgaQkGR2pBB9EEmmsgL1IVNaWB8syaWiZvUG1EqDgmJttoV4VOel5iOR+N9tvZ3tI8sjGk+Xp9yr9epebzE8uBoPBcEhadh4XhIaaKLAaIxWPqAHFXHgaWAAEI4rAAaSwDyZLPDftjnPliMbLbbYaTyZV61ocSDugAYvVmnSlaO9SZaFE-vLZ-PXCPbcNk52d7pRG7wg6WE7ci6om6457vbrR5lA32kcXh0uV9RyIx5Z-v-H7y7W1gQ1XkQIeRclzHL8JxEeUHBcIDdD3P0D2TCRGCIQRUDPH9eWdV1mFvBMH2TJ9YCnIt+jwJC-xkX9aC-GQAMTKCgXuDN7ggpC6hgcdJ3gpxtyXFDd19FDhmGWgTF0dgVG-d1tDgGxbBqZVRDKCBWHqdB2DFAASQRaCqAyvkYHRGGGAYlDAAZLiAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQkGR2pEYDEEmmszwhIXhaS0LEBqFoBEmczR6M+UFEcFIRLAfWaCjAcm+4JJdWxiKg9H+7AITzAACEALJYADSWAAjHSqnT6gBxVz0hnE9HY6iCUEwda0OJ6D4AMXqzQCzmGzIVTPRogRuSxOI+eIJRLNJMy5MpPJpdNNzJZLFo7M53KlWH5Et0dK8AHlHAA5BwATRDdMNAA0PVVySINHB+ICo45ms1jSTPSSJIwiIJUNbGLj8YSwV7SS6qe76YyG6zfRzQQHqUGE2AI9G4-3k6ndOm4Jnsx9c-nC+j57pC8NhrQTLp2CpyMxLDobLYakzRGUIKx6uh2GhUAASQS0KpX6-kxg6RjDAZKMADS5AA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_distribution.default.Rd b/man/tm_g_distribution.default.Rd deleted file mode 100644 index bcb3c55cc..000000000 --- a/man/tm_g_distribution.default.Rd +++ /dev/null @@ -1,196 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_g_distribution_old.R -\name{tm_g_distribution.default} -\alias{tm_g_distribution.default} -\title{\code{teal} module: Distribution analysis} -\usage{ -\method{tm_g_distribution}{default}( - label = "Distribution Module", - dist_var, - strata_var = NULL, - group_var = NULL, - freq = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - bins = c(30L, 1L, 100L), - plot_height = c(600, 200, 2000), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{dist_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable(s) for which the distribution will be analyzed.} - -\item{strata_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Categorical variable used to split the distribution analysis.} - -\item{group_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) -Variable used for faceting plot into multiple panels.} - -\item{freq}{(\code{logical}) optional, whether to display frequency (\code{TRUE}) or density (\code{FALSE}). -Defaults to density (\code{FALSE}).} - -\item{ggtheme}{(\code{character}) optional, \code{ggplot2} theme to be used by default. Defaults to \code{"gray"}.} - -\item{ggplot2_args}{(\code{ggplot2_args}) optional, object created by \code{\link[teal.widgets:ggplot2_args]{teal.widgets::ggplot2_args()}} with settings for all the plots or named list of \code{ggplot2_args} objects for plot-specific settings. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. - -List names should match the following: \code{c("default", "Histogram", "QQplot")}. - -For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} - -\item{bins}{(\code{integer(1)} or \code{integer(3)}) optional, specifies the number of bins for the histogram. -\itemize{ -\item When the length of \code{bins} is one: The histogram bins will have a fixed size based on the \code{bins} provided. -\item When the length of \code{bins} is three: The histogram bins are dynamically adjusted based on vector of \code{value}, \code{min}, -and \code{max}. -Defaults to \code{c(30L, 1L, 100L)}. -}} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of -\code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} - -\item{pre_output}{(\code{shiny.tag}) optional,\cr -with text placed before the output to put the output into context. For example a title.} - -\item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output -into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - -\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -(named \code{list} of lists of \code{teal_transform_module}) optional, -decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects.} -} -\value{ -Object of class \code{teal_module} to be used in \code{teal} applications. -} -\description{ -Module is designed to explore the distribution of a single variable within a given dataset. -It offers several tools, such as histograms, Q-Q plots, and various statistical tests to -visually and statistically analyze the variable's distribution. -} -\section{Decorating Module}{ - - -This module generates the following objects, which can be modified in place using decorators:: -\itemize{ -\item \code{histogram_plot} (\code{ggplot}) -\item \code{qq_plot} (\code{ggplot}) -} - -A Decorator is applied to the specific output using a named list of \code{teal_transform_module} objects. -The name of this list corresponds to the name of the output to which the decorator is applied. -See code snippet below: - -\if{html}{\out{
}}\preformatted{tm_g_distribution( - ..., # arguments for module - decorators = list( - histogram_plot = teal_transform_module(...), # applied only to `histogram_plot` output - qq_plot = teal_transform_module(...) # applied only to `qq_plot` output - ) -) -}\if{html}{\out{
}} - -For additional details and examples of decorators, refer to the vignette -\code{vignette("decorate-module-output", package = "teal.modules.general")}. - -To learn more please refer to the vignette -\code{vignette("transform-module-output", package = "teal")} or the \code{\link[teal:teal_transform_module]{teal::teal_transform_module()}} documentation. -} - -\examples{ -# general data example -data <- teal_data() -data <- within(data, { - iris <- iris -}) - -app <- init( - data = data, - modules = list( - tm_g_distribution( - dist_var = data_extract_spec( - dataname = "iris", - select = select_spec(variable_choices("iris"), "Petal.Length") - ) - ) - ) -) -if (interactive()) { - shinyApp(app$ui, app$server) -} - -# CDISC data example -data <- teal_data() -data <- within(data, { - ADSL <- teal.data::rADSL -}) -join_keys(data) <- default_cdisc_join_keys[names(data)] - -vars1 <- choices_selected( - variable_choices(data[["ADSL"]], c("ARM", "COUNTRY", "SEX")), - selected = NULL -) - -app <- init( - data = data, - modules = modules( - tm_g_distribution( - dist_var = data_extract_spec( - dataname = "ADSL", - select = select_spec( - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), - selected = "BMRKR1", - multiple = FALSE, - fixed = FALSE - ) - ), - strata_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = vars1, - multiple = TRUE - ) - ), - group_var = data_extract_spec( - dataname = "ADSL", - filter = filter_spec( - vars = vars1, - multiple = TRUE - ) - ) - ) - ) -) -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} -\section{Examples in Shinylive}{ -\describe{ - \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDo1CJYdvqpImiqHAEi0dHKdDwFwpg1bU-4yWb0qojgIg0F1B4Puj2e7DONSg9BEiQI+SItAIYj6v0aPzkpR+AAU4EEeAAZCgSAr4w7LNpHBm6NptWgmXTsFTkZiWHQ2WzlIGiQoQVgAQXQ7E6ABJBLRSjLQYwdIw2s0lGBmgBdIA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } - \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTcILRZRAEY2ghLxgjE00TgRDTh+dlqujujFoUHoIk2r1o73OuWAwAUYD6zURl0uVQIAKRWAAsoiqoivAB5RwAOQcAE18bpEQFnAANRFyOS4QFfH7kfi6AC8ulJjmaKIgwyUaFQbRUxQBEDqmR5IVyrJluj4QhEonlquEYmldTqpBgaQkGR2pBB9EEmmsgL1IVNaWB8syaWiZvUG1EqDgmJttoV4VOel5iOR+N9tvZ3tI8sjGk+Xp9yr9epebzE8uBoPBcEhadh4XhIaaKLAaIxWPqAHFXHgaWAAEI4rAAaSwDyZLPDftjnPliMbLbbYaTyZV61ocSDugAYvVmnSlaO9SZaFE-vLZ-PXCPbcNk52d7pRG7wg6WE7ci6om6457vbrR5lA32kcXh0uV9RyIx5Z-v-H7y7W1gQ1XkQIeRclzHL8JxEeUHBcIDdD3P0D2TCRGCIQRUDPH9eWdV1mFvBMH2TJ9YCnIt+jwJC-xkX9aC-GQAMTKCgXuDN7ggpC6hgcdJ3gpxtyXFDd19FDhmGWgTF0dgVG-d1tDgGxbBqZVRDKCBWHqdB2DFAASQRaCqAyvkYHRGGGAYlDAAZLiAA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } -} -} - diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index d3d09a5ec..30e9f7736 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -27,25 +27,18 @@ tm_g_response( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{response}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{response}{(\code{picks}) Which variable to use as the response. -You can define one fixed column by setting \code{fixed = TRUE} inside the \code{select_spec}. - -The \code{data_extract_spec} must not allow multiple selection in this case.} +The \code{picks} must not allow multiple variable selection in this case.} -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{x}{(\code{picks} ) Specifies which variable to use on the X-axis of the response plot. -Allow the user to select multiple columns from the \code{data} allowed in teal. +The \code{picks} must not allow multiple selection in this case.} -The \code{data_extract_spec} must not allow multiple selection in this case.} - -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{row_facet}{(\code{picks}) optional specification of the data variable(s) to use for faceting rows.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{col_facet}{(\code{picks}) optional specification of the data variable(s) to use for faceting columns.} \item{coord_flip}{(\code{logical(1)}) @@ -85,9 +78,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -151,25 +141,25 @@ app <- init( modules = modules( tm_g_response( label = "Response Plots", - response = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["mtcars"]], c("cyl", "gear")), + response = picks( + datasets("mtcars"), + variables( + choices = c("cyl", "gear"), selected = "cyl", multiple = FALSE, fixed = FALSE - ) + ), + values() ), - x = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["mtcars"]], c("vs", "am")), + x = picks( + datasets("mtcars"), + variables( + choices = c("vs", "am"), selected = "vs", multiple = FALSE, fixed = FALSE - ) + ), + values() ) ) ) @@ -191,25 +181,21 @@ app <- init( modules = modules( tm_g_response( label = "Response Plots", - response = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "COUNTRY")), - selected = "BMRKR2", - multiple = FALSE, - fixed = FALSE - ) + response = picks( + datasets("ADSL"), + variables( + choices = c("BMRKR2", "COUNTRY"), + selected = "BMRKR2" + ), + values() ), - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("SEX", "RACE")), - selected = "RACE", - multiple = FALSE, - fixed = FALSE - ) + x = picks( + datasets("ADSL"), + variables( + choices = c("SEX", "RACE"), + selected = "RACE" + ), + values() ) ) ) @@ -222,13 +208,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRKUSYVIzA0iXJcHmQtpKWg8AR2zAXyuqyV+KpIg06v1CtIctQCpptPO9MZzI1AGUmSbdFoWLQGSJEDqzlbKgR8kRaAQxOrXYx3fQRIl-YHg6JihkbostQKHqVFUsVngNQdGEc5Cifb7jRo4Px1YsCMtvb7zjBhJpInpEQAxACCABl7c5C7XKiZaKEy+r213XEX8f9aQXdbpQuqJVKZab5YqJ+cVbBmxqUzXi07DYiSyvzWu+3SGUyK2BHQbSC63R64F7Bev8TGgyHEWGI1GP3GEyCJNNUuVM7nTBYwA2PYUBgfNez7Y9hxZKCBQQ2t62oRsRBHTtu3Q30ByHctWzw8daynSclSnLouloExJhUchl20aljjKMZREKCBWDbdB2HBAASepSiEqlGB0TpgSUMAATuIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRqFoBAA1qIabSkUEqfyFmAvlcjiizvKtCxaAyMXL5XN8kRJWIEXMVQRlnswAdGBqhUaqSINHB+BbFtaVoKtUaYMJNJE9IiAGIAQQAMgBlZyao3nEy0ULui0RmOuP34uTxo066iCXH-Wk5p2VUIWiXS2Vl84pJU11WXAWlrPnHWMPX0A21-EEE1mzGW9YCtYoGCOtv4l1wN0ellgDarXvnAPUIMiNNR2O5hNJlPz3Tp2Mr1sJ-OF2XF7NO4tdLq0EyTFTkZiWHQ2E5jUSFCCscPoOw4IACT1KUIFUowOidMCShgACdxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQzJpaKkZgaNIEuAEUlkzGZN56SF0hajbkguW6YkiDRI7XSy5SmUazW6ClUmnKsABakG3RaFi0SkiRDq3mmgglDYEMRIh2MJ30ERXL20H0fXLAYAqkZqsBfL5VY1gABCAFksABpLAAJm5ujpXgA8o4AHIOACadLkch5psx+o0cH4tNTGezebwJs1MAutDiSt0ADFBqMAs46-XTLQos2kSOx653WT+pra93dFEkcLReLDahpbLNQrYIOY4su8uG7bdZDG-vDxuyebqa2bTrSPbHc64K7L1PdE9b1fUhf1A2DICwzRTIo3POMEyTYFrWcAANfM6SwQYvFcMAa0net7znK1MOwt0AN7ahNAHedR3HfDTRMGciOHWil3rVc5Q4uoOP6fpaBMXR2BUcg920Eka2qEFRDKCBWEGdB2DQVAABIWiqJTlOJRgdD6ZYlDAJYviAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQ1C0AhbfYgsl1TLEznAsALUZ0uQ8yWYrQsWiUhGk1WYgglDYEMRIghygBCAFksABpLAAJm5ujpXgA8o4AHIOACaSpVurqxJEGjg-FpYEtNvtdIlkuVMbJ6uogjR-VVcd5mKiSOFovFGbJ0rgsrpCt98bVGq1aPLZP1huNkNNdICzgAGo66VhBl5XGB0-6A9S4MHQ5DO93ezXdP3dYnk-tU7GY4v+v1aCZdOwVORmJYdDZbDUMaIyhBWIN0Ow0KgACQtKrXm-Exg6PrLJRgJZfIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index 383eeae00..b20f94f64 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -29,25 +29,22 @@ tm_g_scatterplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies +\item{x}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable names selected to plot along the x-axis by default.} -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) Specifies +\item{y}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable names selected to plot along the y-axis by default.} -\item{color_by}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{color_by}{(\code{picks} or \code{list} of multiple \code{picks}) optional, defines the color encoding. If \code{NULL} then no color encoding option will be displayed.} -\item{size_by}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{size_by}{(\code{picks} or \code{list} of multiple \code{picks}) optional, defines the point size encoding. If \code{NULL} then no size encoding option will be displayed.} -\item{row_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{row_facet}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the variable(s) for faceting rows.} -\item{col_facet}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{col_facet}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the variable(s) for faceting columns.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -96,9 +93,6 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -157,68 +151,47 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "conc", - multiple = FALSE, - fixed = FALSE - ) + x = picks( + datasets("CO2"), + variables( + choices = c("conc", "uptake"), + selected = "conc" + ), + values() ), - y = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + y = picks( + datasets("CO2"), + variables( + choices = c("conc", "uptake"), + selected = "uptake" + ), + values() ), - color_by = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["CO2"]], - c("Plant", "Type", "Treatment", "conc", "uptake") - ), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + color_by = picks( + datasets("CO2"), + variables( + choices = c("Plant", "Type", "Treatment", "conc", "uptake"), + selected = NULL + ), + values() ), - size_by = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("conc", "uptake")), - selected = "uptake", - multiple = FALSE, - fixed = FALSE - ) + size_by = picks( + datasets("CO2"), + variables(choices = c("conc", "uptake"), selected = "uptake"), + values() ), - row_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + row_facet = picks( + datasets("CO2"), + variables( + choices = c("Plant", "Type", "Treatment"), + selected = NULL + ), + values() ), - col_facet = data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["CO2"]], c("Plant", "Type", "Treatment")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + col_facet = picks( + datasets("CO2"), + variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), + values() ) ) ) @@ -240,68 +213,35 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), - selected = "AGE", - multiple = FALSE, - fixed = FALSE - ) + x = picks( + datasets("ADSL"), + variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), + values() ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1", "BMRKR2")), - selected = "BMRKR1", - multiple = FALSE, - fixed = FALSE - ) + y = picks( + datasets("ADSL"), + variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), + values() ), - color_by = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices( - data[["ADSL"]], - c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1") - ), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + color_by = picks( + datasets("ADSL"), + variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), + values() ), - size_by = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), - selected = "AGE", - multiple = FALSE, - fixed = FALSE - ) + size_by = picks( + datasets("ADSL"), + variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), + values() ), - row_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + row_facet = picks( + datasets("ADSL"), + variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + values() ), - col_facet = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", - choices = variable_choices(data[["ADSL"]], c("BMRKR2", "RACE", "REGION1")), - selected = NULL, - multiple = FALSE, - fixed = FALSE - ) + col_facet = picks( + datasets("ADSL"), + variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + values() ) ) ) @@ -314,13 +254,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDilEmFSMwNLdUHACG93ucUtB4Ad-qM4Ut8bpRD8ceD1tSRJjRNjcRTKbpPt9frp-gCaRpdFoWLQviJEOSEeyCJDoWIDkLGCL6CJEtKoTDRMUMsBgKTBv8ALoG0qswgkAhwnlgQSoIIAazg-zkcnh7PODNpcH4JLNFglbsqMGEmkienWADEAIIAGQBzldAZMtFCXoOUdjrkl7y6lJdbMqrGRGVRoXR6lIWJxeMphNgYatZLw+fd-LpVNbldZWfxnJ+Pr5jPBCqVYv9AbVsv262HorgqplGq1QR1erGYCNJsWvoteCtNvtjrAzoTbo9GlTf2ttqgDrHbqD1BDIjTMbjJ-ZSZT3ojr8zbpz+J5t2bQdIk9CFusKJohiFbMlWzaVLWxKXo277vGebYYZ21bsr23K8q2grCrO4pNt27wThq8rEcqc6UScCH4ikK5gI2G6MRRW4AAqfGQlr-HYrDYvxYB2NUgTwHxu7-MQfrSVeB5OhxuhAQG7aDheugAHKONG0ZofiD5PvW6Zvspn6aaZf7sgB2YGaItAAF5zuBRZBCWZZMiyOHvEh9arne+IYQcWFwV2al4f2hEzrRpEGRRC5ytONEqvRmrMbqrH6uuxq6Kask7qU-z7jeh7HspGGacV163mRalGbQoYvhm8XnBZ366FZjG2ecqn4owRDZIkJjqHAbZQaWMHYYxfk+qhjHBfSHZhT5PZfH2l4DrSRGKiRgWUml1G7bR87qicGUBTlm7-DxUBSUVolCYeD1iXAEkUKQTp9aeraaTpemtYGwaNc+P4teZyaWb+3XNt95xtMNo3jcW0HltN5EbHddZzdlrWLeptLoxF634YC0UpXAcXKYdyXHaliXpdqmVsblpq3fdVqCcJ8mve9UnlRjlSVR1-36cpDVNWDZmC6YkMdV1GM9ZUPUAV0XS0CYujsCojzltocA2LY5RnKIhQQKwkboOwMwACT1KUtvUowOidBMShgOMBpAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDqhoQBrURvd7nFKiOCkDH-Ub-OTwrHnLQsWhfPaYsmVAiQ6FiA4ERaEEgEOG6f6CVBBVFwYmkumVXEiDRwfgHf7ECz-JZkkkKrEU6iCE5dRXC96sZFogkIrE4vEEsBEsBKw3vCmMKn0GnKskMqEw-brVkyjlcnl8qACoWOrFiuASqV-MC8-mCsCByqWkWq9UYzVY+NYtodRL0XXrFEEdG0o0ZXH4tnmtNkm12h1W9OM10stkABU+ZG9YDsrFQ0dK-zs1UC8DbeG57LlI59UYDtfewdDBwAco4ADLL2O6Csq7hJtK1zei2gALzgWZzujzBfXxtLhMG04TlOpJ2dTLdug9Y85E4jvv9FtKc7kGGo6Rn60b7uS24aoGEGMEQ2SJCY6h4nq+YGiK16muW2pbraT7oSK771sy7rNq2pDtp23aUQOlwUBR-7rqKPwhkBi4rmuM4bjh1pQcmME8e+RBJEhMLgrm+qFu8mFlnejFcVW+HsC+Dakf8LZQMOvYdl2Pajv2cCDvRQq6IBkrsauEGVIm0F7sqKZdF0tAmLo7AqI86iaDoNi2OUZyiIUECsAAgug7AzAAJPUpSRbijA6J0ExKGA4wALpAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokjMmloqRmBo8ag4AQyeTMZk3npIfSFqMeSDZbpRDSpWzIVqROLRJLpeqNbpKdTaUqGdqNLotCxaFSRIg1XyzQQObQuYjIQ7GE76CIrl6fQdwsBgMqRqqwF8vlUTWBBgBxVx4XT0gBCAFksABpLAARh5mbAuYLWAATPS5HJeWbMfqdXB+HTk2m3Y26jALrQ4ordAAxQajALOBvdky0KKtpEjseud3k-oa+umuqsQW5YVRUXqS5GqUyjXy2CD6OLPAbpu23Wau8S4838kWmntgJ3+2O51wV3X5dZU9TkxCRf1A2DYDvTRTJI0vWN40TYEO3TKpszzQsSwzdDKxrMA60nRtmw0OdrQrTCu27XtqE0Ad51HcdCLNadZzbSEF3HF9dFXWV10A7pejSegt0hIURTFQ9jRPWUz3gdsVUojViPvZSnxNQDXypd9rU-A02XA39-yYjUoJ9MCfyDOAQxA-YuPJWCo2TGN6UQuzMSTVNULLcji1LHDCzwtCwCwQYvC8+ksGcFM-AAeQAOSwnjGz47sHz00jdDixxRlGYzZWo2iRHoxc8vJFiMo4pdkpvFLZVEWgAC8rOE7dwl3fdDSkrjZIvJyr1KtKdSRVSj3U1K3ytMtdKGgzLKMtzTNAv0LMg0MYNyOC+oQhNdA8ztsPLDDfPw2qiLvDLlX2gaez7Oj2IYic3PKtjhweriksxU7MUYIgCjSM4uXvMS9wktTpPs3IFXk5yALOvThsfUbwdlCaPy-WaXUUj01t9b8A1-azoI+DbHIUuMdqTHzArLEKwr84KotihLay+pTzperKcuu5FbqK+6SqemcKrejTuJqvLun+9Q4CBndxIPMHush89of6rjlIRvTFdFupUZ09GVr-LGTJx8z8cswmwwc+CXIp5Cqfp2nwoZ6L4sS1m6vZpFOdytyCv7PnXoFnXTCFl7KvemrTR4-p+loExdHYFRCQPbQ4BsWwagxUQyggVhBnQdg0FQAASFoqmLkutUYHQ+mWJQwCWL4gA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokjULQCFt9iDyXVMqI4KQxWAFqN6XJeRLMVoWLQqQj2AQOcKxEiCMD5QBxVx4XT0gBCAFksABpLAARh5lrAtodWAATEqqtKRBo4Pw6abzcrxRL1dRBGj+qrw3zMaxBcLRWTVVCoNLZcaFb6I+T1YxNfRtbrOQbIUb6YMza7rXbHS6LQ3PT6wMrdP64IHg5DW0384nC9wY-s4xKE6rur00vRk5ChSKxcPMVKZXK8x2VRmiyWy7m6y33Y3nfWT23z1hBl5zVV6VhnCa-AB5AByzc73d7SLfjlGoxTruo6xgWuhAeSoi0AAXnAc4LroS5pmBkq5Nmm4jIq24oboe5ami5b6oiVaHneboeoO25djSPbkH2bq1mGO6qlGY7ZKuEGYowRAFGkZxcmyi6piuGaZuhuaYUOol4aWBF6lyxG6NWF6Ou295gNet5Xk+r4fr61EBnRv7-oBzGRiB45gZxdTdHx6gyimy7pqq645jWknYaudQyWW8mVkpxoUd6V43mRD46e+n5+jRP6Qn+AHWWqFnsfGEYTv0-S0CYujsCohLqJoOg2LYNQYqIZQQKwgzoOwaCoAAJC0VR1fV0qMDofTLEoYBLF8QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index f4b8bfe8c..4d6161972 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -16,12 +16,9 @@ tm_g_scatterplotmatrix( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{variables}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{variables}{(\code{picks} or \code{list} of \code{picks}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -\code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if plot elements should be +\code{picks} use \code{variables(..., ordered = TRUE)} if plot elements should be rendered according to selection order.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -37,9 +34,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -130,33 +124,32 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - data_extract_spec( - dataname = "countries", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["countries"]]), + picks( + datasets("countries"), + variables( + choices = tidyselect::everything(), selected = c("area", "gdp", "debt"), multiple = TRUE, - ordered = TRUE, - fixed = FALSE - ) - ), - data_extract_spec( - dataname = "sales", - filter = filter_spec( - label = "Select variable:", - vars = "country_id", - choices = value_choices(data[["sales"]], "country_id"), - selected = c("DE", "FR", "IT", "PT", "GR", "NL", "BE", "LU", "AT"), - multiple = TRUE + ordered = TRUE ), - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["sales"]], c("quantity", "costs", "profit")), + values() + ), + picks( + datasets("sales"), + variables( + choices = c("quantity", "costs", "profit"), selected = c("quantity", "costs", "profit"), multiple = TRUE, - ordered = TRUE, - fixed = FALSE + ordered = TRUE + ) + ) + ), + transformators = list( + teal_transform_filter( + picks( + datasets("sales"), + variables("country_id"), + values() ) ) ) @@ -181,35 +174,30 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADSL"]]), + picks( + datasets("ADSL"), + variables( + choices = tidyselect::everything(), selected = c("AGE", "RACE", "SEX"), multiple = TRUE, ordered = TRUE, fixed = FALSE - ) - ), - data_extract_spec( - dataname = "ADRS", - filter = filter_spec( - label = "Select endpoints:", - vars = c("PARAMCD", "AVISIT"), - choices = value_choices(data[["ADRS"]], c("PARAMCD", "AVISIT"), c("PARAM", "AVISIT")), - selected = "INVET - END OF INDUCTION", - multiple = TRUE ), - select = select_spec( - label = "Select variables:", - choices = variable_choices(data[["ADRS"]]), + values() + ), + picks( + datasets("ADRS"), + variables( + choices = tidyselect::everything(), selected = c("AGE", "AVAL", "ADY"), multiple = TRUE, ordered = TRUE, fixed = FALSE ) ) + ), + transformators = list( + teal_transform_filter(picks(datasets("ADRS"), variables("PARAMCD"), values(selected = "BESRSPI"))) ) ) ) @@ -222,13 +210,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQikiRhLUIL46gcAUkBhopNA8D04DH14LRUKiCSMu7pBWsaFLMvC4aRq034AyTOseu7tzdR82IiCc3Lxt0kNTGlboNu82ycCJC7tBu1NQTAMAANvXtd0ALoR32xuPlbvlmpMxZQFcEgDlcW47sdTuGjAwiaDBrmsSRsddGCW70X5LEuCXpemLQoQJwMoXhWxdcPoaMddKL4vMProjS7LdcK7AzEXc+33q10TXUMTMqSsTBtD3XJsmvTlsiBoHs83bDtqznio2+7oegaw4H8I7K9VPkrsNAM3PUGpvs3-7GMpMH49XZMUf3IDZ-A7XUumtN7kCrtpRCJxkInFQicTCJxsInFwicfCJxCInFeNnK+edZ60ELgMNyU97yANIlbHiVsl5G0NMaOm5sGakM9nbUQe9iHOxfm7IEDDvbP1vpNd+IcdIT2-hHH6QwkrWk0KQBkJxiDFW+qseqjU8ici7iQkBTdBiTDESlSRO0iolSuAopqpBMEr2wQXEQRca6ELLowCu6jgrWMqE1RuVcW4RWsR3RUnj7xek6FyLktATC6HYCoYmIJtCfiUmUToohCgQFYM8dA7AIYABJBC0FKKkzWjBfi9SUGAHqEcgA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQqgtAECNk20VCKSiHAJWvaBH2PSRhpdNzdR8xjUuKnSQ1MaVuiaPwE0knAGiIIgcC-KwBQqBINgq6rXSyyIGi+WakzFlAVwSAOVxbjux1AU7MDCJoMGuaxjtO7oYJbvRfksS42v3tHhrc9QamTQ+hp9iLYsS8Lioy3Lks6c+1154q6u82yWvB6rutiw0ZZDEl1qaKQDInMQxXfas9WNXkQcx87ptu4n2ntylXc7UVJVXIPTWkCPo+6KH1DhyIkcuGnqtxzI7sDG5Ke6Dnirn6ntG1NaogmJlgRggbgv8drCSJDfEB35lYqSsTRf53FpLBuhoS7ywuhXVeo8a6azLoDVg4F+BQJjhnLOaQQE8m1pfM+XpOhci5LQEwuh2AqGJiCbQn4lJlE6KIQoEBWDPHQOwCGAASQQtBSisNlowX4vUlBgB6gAXSAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdy6pk0tFSMwNBjUHACGLxRLcg89EDaX1mhyBirdKIqYqWUDDSI5aIFUq9frdOTKdTNXSjRoeXyBWJELqubbdAQSksCGJobzCR6TgHaEGnrlgMAtU0dWAXi85JzfXUzca4PxodawPUAOKuPC6WlYepeEtVWkBZwADVpaZt+pgR1ocQ19icznTGaIjD2jBz0IcLj7vpMRJHQIAYvVmnWW9y5vrmz7uZLpbLjpbFcqVZl1TSC0MAt7J7RqNjoVPrzJ5fvl+L7VSTwEXSyKPxUEsyKIvTwZ9uVDKEgXzAAFeoKwAWV8DkywLAA1QI-DsJsJ1tf1A2DIFeWoQQ4AjHCY3COMEymZMXiqSDoPqOCfAQrUUICNCML9X4wCg2CmOQ1D0LAOR1wzA1PxnRC-AAOSQ5w7F0YxnEknxdAAeVnXQpJ8RwvDsPwVMki8Mzba8OxEUce2AuphNtLNXVNT9H2tDd9VfR1EI-c0WVDfl6EhQDMP1bCo1wt0w18oigujLYyPjU9KJTazfVs8hc3Azii2rRD6iQhdeMaABNDDLKRYzNE7czx2KuoByHcSx17KrTGnVLdHnRdXGcldgNXLqNx6uY5loExdHYFRsXUTQdBsWwai5UQyggVh6nQdg0FQAASQRaCqNb1sNRgdEYOZpiUMBpheIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdy6qhaAQVpsBuK6plRHBSLKwH1mrS5Jz5UjeYSBfC5TrdAQSksCGJoZp+BsqXANN04Do2KUVBIbNrjXUlSINHB+NCCL81QBxVx4XS0rD1Lzhqq0gLOAAams9XpgR1ocT0QIcLjTxqIjD2jH90LzzgLOpMRLLQIAYvVmomjeKta3ubzqIJ4XMde2ueLJdLZYP5YrlarJgFUx3SXr+fRIWKvabzZagdbbb7SI7naxXRB3QOvd67X6A0Cg7T6mGOZG1QA1Jv3m8+ACas7HOoz1E02fLJxKznbkixLOt7CAqt5RrKIIMbZtXG-bk+3lVDSRPblSGYCBRBMIsYDCIsoSBYVRRA1I0mwqBcPwxhURrP8ZHYYcZS2cIlRVYNp1THk+QNVUAAV6mjABZXxeK7HtNh9e1yEvB8ACFnACYZBL8TU5HQpFtNQuY5loExdHYFRsXUTQdBsWwai5UQyggVh6nQdg0FQAASQRaCqVy3KVRhnTmaYlDAaYXiAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index ef6abaf03..7da0234f1 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -21,24 +21,12 @@ tm_missing_data( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} \item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of \code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{parent_dataname}{(\code{character(1)}) Specifies the parent dataset name. Default is \code{ADSL} for \code{CDISC} data. If provided and exists, enables additional analysis "by subject". For non-\code{CDISC} data, this parameter can be ignored.} @@ -58,9 +46,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index f5118a117..9c8afcbfc 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -19,13 +19,10 @@ tm_outliers( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{outlier_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{outlier_var}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable(s) to be analyzed for outliers.} -\item{categorical_var}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) optional, +\item{categorical_var}{(\code{picks} or \code{list} of multiple \code{picks}) optional, specifies the categorical variable(s) to split the selected outlier variables on.} \item{ggtheme}{(\code{character}) optional, \code{ggplot2} theme to be used by default. Defaults to \code{"gray"}.} @@ -49,9 +46,6 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -113,21 +107,22 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - data_extract_spec( - dataname = "CO2", - select = select_spec( - label = "Select variable:", + picks( + datasets("CO2"), + variables( choices = variable_choices(data[["CO2"]], c("conc", "uptake")), selected = "uptake", multiple = FALSE, fixed = FALSE - ) + ), + values() ) ), categorical_var = list( - data_extract_spec( - dataname = "CO2", - filter = filter_spec( + picks( + datasets("CO2"), + variables(), + values( vars = vars, choices = value_choices(data[["CO2"]], vars$selected), selected = value_choices(data[["CO2"]], vars$selected), @@ -160,21 +155,22 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + picks( + datasets("ADSL"), + variables( choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), selected = "AGE", multiple = FALSE, fixed = FALSE - ) + ), + values() ) ), categorical_var = list( - data_extract_spec( - dataname = "ADSL", - filter = filter_spec( + picks( + datasets("ADSL"), + variables(), + values( vars = vars, choices = value_choices(data[["ADSL"]], vars$selected), selected = value_choices(data[["ADSL"]], vars$selected), @@ -193,13 +189,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm52y4JJcKkZgaOHMskml2ummwPQywnvf0u+FwDS2qPe0S+p0Bl3U+hwfyhsAAZXT0dIulRtHRIkQ4fFyed2NoMJVBZYRYxcCxUOruNSBLAbzAk1J5MIJAIrLAglQwRGQLk8vLFaqcfI-FtXRHY5ZeAjAZgwk0URDugAYgBBAAyWecU5nppMtDCSNth5PrmnyZ2FZfLsnEYIQTgEiIvS-yQ2jK9qOuugbumEnrqKQPrRkmFapNA8CLp2XznjOV7UOQjC2ph2GwX6T4VqitYkehF5VjWtqgtQghNpRbaZB2XY9nWjCiAAJHOSIfkRybcQuMo0XRzY4uc7adKhRLdiSbGcQJvEXlUm5YbQO62g4LhgVUb4Brppr6W+Ow7LQJi6OwKjYdB2hwDYtgVOWohFBArAHug7CChxgi0GUnkzIwOiMDsuxKGAuzjEAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm526VC0AhDY3il3O1IzUjGsBvXny70+qqo2jo5VO8PO7HusS2yPRuBYqGJ86pAlBr6TUnkwgkAissCCVDBEZAuShuPO+FwRH8W1dcuVll4E1xmDCTRRPQygBiAEEADIAZWctbrVRMtDCSNtI4nrjD4ZrXZdoOoglxOzj+5dG7XVQIQTgEiIvTPyRtMvtjs3VTdHq9M79cADheDx5nKYxe7TnG267m+M66KiKoQWCQF1gmMJQSBabwbi2adLmRJgPm0GMKIAAkDZNr+4GEeQzYykh6Y4lmmQ5sG2GQQRcAImRxEzj21B9iItoOC4T6moePqCQJJqHjsOy0CYujsCo5DMJYOg2LYFTeqIRQQKww7oOwgp4YItBlLpMyMDojA7LsShgLs4xAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3EpIe0VCV2HVQnldABeJURXCKvhCEREtXa4TfRX1UgwdJEQSkOgyebG+q6C1W2gyB4sVW6OiiUgKiD2v3qqDpGKkZj3USoOAEH3+-1ZL7u3nNJF4O0xqk00ju9ORzbhyPRmP+6jM6kJsCBak53SM5kiRDwzW+wt+klksTumssuBsttciI8hFJ-nVKO8gDirjwunhACEALJYADSWAAjPDcY3m37s7T+GWGhOG6nCzANrR4no1T8Gi1As5N1v6iZaNE6e7r7fXE3myMf8e5A+LbhHAEjYhy3Cuow7qet6x71FkQbRCGQqUhGo7foWcawJe06DgMKYYTGz4AjI7rEYCqH5nB-oih2TyAVurYcu2aqPNQgjdkxnILP2cJ4cmKLVCKAAkO7kPwAHUdula7nR7Gcey3EwnxfJgIJ1ZPKJMniZJhEnmeF7uqCX6Pr+hZmX6Fm6GZIwjLQJi6MCqihpoOg2LYtRNqI5QQKwDToOwkLCYItDVEFVKMDoOJDEoYCDFcQA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3EpIe0VCV2HVQnldABeJURXCKvhCEREtXa4TfRX1UgwdJEQSkOgyebG+q6C1W2gyB4sVW6OiiUgKiD2v26VAcqa233+v1ZKmkW0I5pIsByTWhsP1RnM3U+5P+klksTu1MsuBsnNciI8mMDMAo6oEBUIgDirjwunhACEALJYADSWAAjPDcYnM36qTTyPx3byG-DB0P6jANrR4no1T8Gi1As4Z7OTLRonT3av164k8mE3aw49qIJviNM7f-WeT-UCOE4BJsRzuK7GO7Pd7z-agYEMGGZDhGcBRrWfLxluyb5umj6zpe14hrOKZPHmTywZm2YcrmarIYWuGcgspZwuWcZVroIoACQjnAtL8IhaH0YxmFXkR7IkTC5HQVRtGsWOzGzvOAKLiI7qgses73mGsn2vJ94jCMtAmLowKqMwlg6DYti1KGojlBArANOg7CQjRgi0NUFlUowOg4kMShgIMVxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 1f8cdcce3..740cd0a08 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -20,9 +20,6 @@ tm_p_spiderplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} @@ -49,9 +46,6 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 85f7598fc..0404d54ec 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -21,9 +21,6 @@ tm_p_swimlane( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} \item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index eabdeea88..f33b9a993 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -19,9 +19,6 @@ tm_p_waterfall( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index 7b0c159ab..f506b10b7 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -12,24 +12,12 @@ tm_rmarkdown( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{text}{(\code{character}) arbitrary Rmd code} \item{params}{A list of named parameters that override custom params specified within the YAML front-matter (e.g. specifying a dataset to read or a date range to confine output to). Pass \code{"ask"} to start an application that helps guide parameter configuration.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index 5f2b07110..49f6d23dd 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -19,18 +19,15 @@ tm_t_crosstable( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{x}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{x}{(\code{picks} or \code{list} of \code{picks}) Object with all available choices with pre-selected option for variable X - row values. -In case of \code{data_extract_spec} use \code{select_spec(..., ordered = TRUE)} if table elements should be +In case of \code{picks} use \code{variables(..., ordered = TRUE)} if table elements should be rendered according to selection order.} -\item{y}{(\code{data_extract_spec} or \code{list} of multiple \code{data_extract_spec}) +\item{y}{(\code{picks} or \code{list} of multiple \code{picks}) Object with all available choices with pre-selected option for variable Y - column values. -\code{data_extract_spec} must not allow multiple selection in this case.} +\code{picks} must not allow multiple selection in this case.} \item{show_percentage}{(\code{logical(1)}) Indicates whether to show percentages (relevant only when \code{x} is a \code{factor}). @@ -57,9 +54,6 @@ The argument is merged with options variable \code{teal.basic_table_args} and de For more details see the vignette: \code{vignette("custom-basic-table-arguments", package = "teal.widgets")}} -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -130,26 +124,26 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", + x = picks( + datasets("mtcars"), + variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = c("cyl", "gear"), multiple = TRUE, ordered = TRUE, fixed = FALSE - ) + ), + values() ), - y = data_extract_spec( - dataname = "mtcars", - select = select_spec( - label = "Select variable:", + y = picks( + datasets("mtcars"), + variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = "vs", multiple = FALSE, fixed = FALSE - ) + ), + values() ) ) ) @@ -170,10 +164,9 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + x = picks( + datasets("ADSL"), + variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) return(names(data)[idx]) @@ -182,12 +175,12 @@ app <- init( multiple = TRUE, ordered = TRUE, fixed = FALSE - ) + ), + values() ), - y = data_extract_spec( - dataname = "ADSL", - select = select_spec( - label = "Select variable:", + y = picks( + datasets("ADSL"), + variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- vapply(data, is.factor, logical(1)) return(names(data)[idx]) @@ -195,7 +188,8 @@ app <- init( selected = "SEX", multiple = FALSE, fixed = FALSE - ) + ), + values() ) ) ) @@ -208,13 +202,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIKlKJMKkZgaRKiVBwPquk0paDwBV0lEM6UPE2VcEiDQKxNBrUBoPG+Mms0Wq1MgDKlrTui0LFoTrgiBGIfjBHyOII8olZa+le1DdoTYJKXezOjIL2pWDg2GjLGMaZM3HYHmjG5sezJtTGjg-AVI4IQ1Zc8Wi6X62EmkieglDhc+4PbX4MjXCvPzkvS5MtFCd4lADEAIIAGQLrjjeN7mzOQn0qVgPQyL1Qh9M5-UDYNANDDJw1PJkWRdJC1hXUgU2LP0M0Qg9KlzS1IzAIsk1w1sK0NKsaywk160bZtS3LdtmK7MRCSCPsMIOYd+lHVlxlZadRlnOAFjAJYwPjHD3yZUTMOIqoj1oE8FW-P9H1rE0XzfddP1-f89N0YCgNdCz7nuWgTA6FRyF9TQdBsZYWlEQoIFYL90HYPkABJBFoUpAvBRgdEYe5nggMBHj2IA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIK1C0Aj-FUPE2VFLg0gq5kohlyaV+-1aFi0J1iY3+k0EfI4gjyiUxr7x7Wpr0JlLvUObBkHUp9AYEIas8asmaMuZwBZgJaRpMm8EiDRwfgKiuDYYNsDzRiLNvt9bCTSRPQShwuccTtr8GQ9hXz5yL9smWihNcSgBiAEEADIAZVcUZNEddJpj1EECfuSZvV90rA9Xp9iaTgbgwf6YtmhbLc71jeNfQnSoUzTDNdCzONDTgXNYIJQtgDpMMQT2ctAKrQdRjAWsh3rQiR25UD-U7OBu17a0iIZSiTRgKdaBnBVj3PTdb39Hc9zo3ROIvHjKlfCd70fAln39aTRJae57loEwOhUchmEsHQbGWFpREKCBWCPdB2D5AASQRaFKUzwUYHRGHuZ4IDAR49iAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBmTS0VIzA0aVEqDgBDR6IhmVOeg++L6zXx33BHLqohxrNIgLFIkZzNZ7JFdUx2NxvLAAXFGl0WhYtFJcEQgopioIJXGBDEgJ1jD1KLgmzNtAt51ywGAfKaArAl0uVVEgnoYslHzMFk01gu1WNit0tH4VPyAEIdehqBxKrGICUZMVRFVqEQJE7uOwAIxyKps-E+MJwQW6fEABQA8gE-AANDT1putjvUUj4uTDGPoxhwUiCRgQdjcl3hOTAONRS7DkdDIUj3TSiVwfh4gnNxwAOQcAE0jcKYzB1rQ4jz7E5nBuR0RGMsx3uPg4XM+YyZaFEu6AgAYvUzQBK4l4cqu6IVtGuisNSuS0lE9LqBscpVlB6JcrA94ev05LYRC25ah8pEYSyWGbsqOL7hqMqStatoiIaRGbqa5qWh8zH6g6XFzlAboEV6Pp+gGQaAqGlgRgsUbESKS5tCmcTprkVQ7BgqwaK++aFsW1BlkO8EimOE5TjOeGCQuS4riZELrvZoqauQn4Nuqzjthem7Xv2t4iCBYEQb+ir-oBbmgeBkExjBEKxauwzDLQJi6OwKjkAymg6DYtg1MKohlBArD1Og7BoKgAAkgi0FU5UVWKjA6IwwwDEoYADJcQA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBqFoBEmcwp6M+UFEcFIDLAfWa+Lk33BTLqWhYtFJoMZAoIJXGBDEgKFjBFKLgmyltNBmWAwHxXPxl0uVVEgnorNIgLMFk01gu1XFAt0tH4VPyAEIhehqBxKvaICUZMVRFVqEQJLTuOwAIy83QEJ5gHxhOD4qr4gAKAHkAn4ABoaJO6VMZ7PUUg84Z2pmMNmCRgQdindULYAOqKXMvl3RDPnt3SskQaOD8PEEtOOAByDgAmknbeiYOtaHE9B8HC4u+2iIxlpXB8unM41+WTLQogPAQAxerNAKufkC3kz3RC6iCUFt9H328Q1jU2n0tF2zITQ5HUwA-ct5UVf5-3LSVpVlD4INFFU4POXJNW1JpuTAPUDSNE0zXMSwrQWG1P3LZs2jdOJPVyKodgwVYNA3QNg1DagIzkN920rUhq1retUPCOQm0dVsHzqTtxJ7HE4H7Hd8zAa8s2nMimTnYsFxEc9L2vA87SPE95IvK8b3LMC7SfF85i4uouLbYZhloExdHYFRyGYSwdBsWwan5UQyggVh6nQdg0FQAASQRaCqMLwtZRgdEYYYBiUMABkuIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd index 6257d9d2f..0db9451c3 100644 --- a/man/tm_t_reactables.Rd +++ b/man/tm_t_reactables.Rd @@ -14,21 +14,6 @@ tm_t_reactables( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 9f439c157..408d6b5ed 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -16,21 +16,9 @@ tm_variable_browser( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} vector of datasets to show, please use the \code{datanames} argument.} -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - \item{parent_dataname}{(\code{character(1)}) string specifying a parent dataset. If it exists in \code{datanames} then an extra checkbox will be shown to allow users to not show variables in other datasets which exist in this \code{dataname}. @@ -49,9 +37,6 @@ with settings for the module plot. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/validate_input.Rd b/man/validate_input.Rd deleted file mode 100644 index dcdd204f6..000000000 --- a/man/validate_input.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_variable_browser.R -\name{validate_input} -\alias{validate_input} -\title{Validates the variable browser inputs} -\usage{ -validate_input( - inputId, - condition = function(x) TRUE, - message = "", - session = shiny::getDefaultReactiveDomain() -) -} -\arguments{ -\item{input}{(\code{session$input}) the \code{shiny} session input} - -\item{plot_var}{(\code{list}) list of a data frame and an array of variable names} - -\item{data}{(\code{teal_data}) the datasets passed to the module} -} -\value{ -\code{logical} TRUE if validations pass; a \code{shiny} validation error otherwise -} -\description{ -Validates the variable browser inputs -} -\keyword{internal} diff --git a/tests/testthat/helper-testing-depth.R b/tests/testthat/helper-testing-depth.R index 3aa6cf3ec..818394ee8 100644 --- a/tests/testthat/helper-testing-depth.R +++ b/tests/testthat/helper-testing-depth.R @@ -8,7 +8,7 @@ #' @return `numeric(1)` the testing depth. #' get_testing_depth <- function() { - default_depth <- 3 + default_depth <- 5 depth <- getOption("TESTING_DEPTH", Sys.getenv("TESTING_DEPTH", default_depth)) depth <- tryCatch( as.numeric(depth), From c3e8381ca2d279995b4816e1c777ba1c3c01b505 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 9 Oct 2025 14:59:34 +0200 Subject: [PATCH 143/158] rename files so that .default is still in the original file --- R/tm_a_pca.R | 457 +++-- R/{tm_a_pca_old.R => tm_a_pca_picks.R} | 452 ++--- R/tm_a_regression.R | 562 +++--- ...gression_old.R => tm_a_regression_picks.R} | 562 +++--- R/tm_g_association.R | 292 +-- ...ciation_old.R => tm_g_association_picks.R} | 292 ++- R/tm_g_bivariate.R | 576 +++--- R/tm_g_bivariate_old.R | 565 ------ R/tm_g_bivariate_picks.R | 495 +++++ R/tm_g_distribution.R | 1733 +++++++++-------- R/tm_g_distribution_old.R | 1277 ------------ R/tm_g_distribution_picks.R | 1170 +++++++++++ R/tm_g_response.R | 410 ++-- R/tm_g_response_old.R | 449 ----- R/tm_g_response_picks.R | 405 ++++ R/tm_g_scatterplot.R | 564 +++--- ...terplot_old.R => tm_g_scatterplot_picks.R} | 564 +++--- R/tm_g_scatterplotmatrix.R | 158 +- ...x_old.R => tm_g_scatterplotmatrix_picks.R} | 158 +- R/tm_t_crosstable.R | 306 +-- R/tm_t_crosstable_old.R | 331 ---- R/tm_t_crosstable_picks.R | 280 +++ 22 files changed, 6027 insertions(+), 6031 deletions(-) rename R/{tm_a_pca_old.R => tm_a_pca_picks.R} (71%) rename R/{tm_a_regression_old.R => tm_a_regression_picks.R} (58%) rename R/{tm_g_association_old.R => tm_g_association_picks.R} (55%) delete mode 100644 R/tm_g_bivariate_old.R create mode 100644 R/tm_g_bivariate_picks.R delete mode 100644 R/tm_g_distribution_old.R create mode 100644 R/tm_g_distribution_picks.R delete mode 100644 R/tm_g_response_old.R create mode 100644 R/tm_g_response_picks.R rename R/{tm_g_scatterplot_old.R => tm_g_scatterplot_picks.R} (57%) rename R/{tm_g_scatterplotmatrix_old.R => tm_g_scatterplotmatrix_picks.R} (72%) delete mode 100644 R/tm_t_crosstable_old.R create mode 100644 R/tm_t_crosstable_picks.R diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index d490c183f..c9026f8b1 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -134,35 +134,29 @@ tm_a_pca <- function(label = "Principal Component Analysis", } #' @export -tm_a_pca.picks <- function(label = "Principal Component Analysis", - dat = picks( - datasets(), - variables( - choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), - selected = tidyselect::everything(), - multiple = TRUE - ) - ), - plot_height = c(600, 200, 2000), - plot_width = NULL, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - rotate_xaxis_labels = FALSE, - font_size = c(12, 8, 20), - alpha = c(1, 0, 1), - size = c(2, 1, 8), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_a_pca.default <- function(label = "Principal Component Analysis", + dat, + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_a_pca") # Normalize the parameters + if (inherits(dat, "data_extract_spec")) dat <- list(dat) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(dat, "picks") + checkmate::assert_list(dat, types = "data_extract_spec") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -210,59 +204,55 @@ tm_a_pca.picks <- function(label = "Principal Component Analysis", # Make UI args args <- as.list(environment()) + data_extract_list <- list(dat = dat) + ans <- module( label = label, - ui = ui_a_pca.picks, - server = srv_a_pca.picks, - ui_args = args[names(args) %in% names(formals(ui_a_pca.picks))], - server_args = args[names(args) %in% names(formals(srv_a_pca.picks))], + server = srv_a_pca.default, + ui = ui_a_pca.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(dat)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the PCA module -ui_a_pca.picks <- function(id, - dat, - plot_choices, - ggtheme, - rotate_xaxis_labels, - font_size, - alpha, - size, - pre_output, - post_output, - decorators) { +ui_a_pca.default <- function(id, ...) { ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) + + color_selector <- args$dat + for (i in seq_along(color_selector)) { + color_selector[[i]]$select$multiple <- FALSE + color_selector[[i]]$select$always_selected <- NULL + color_selector[[i]]$select$selected <- NULL + } + tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( - tags$div( - tags$div( - align = "center", - tags$h4("Principal components importance"), - tableOutput(ns("tbl_importance")), - tags$hr() - ), - tags$div( - align = "center", - tags$h4("Eigenvectors"), - tableOutput(ns("tbl_eigenvector")), - tags$hr() - ), - teal.widgets::plot_with_settings_ui(id = ns("pca_plot")) - ) + uiOutput(ns("all_plots")) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Data selection"), - teal.transform::module_input_ui(id = ns("dat"), spec = dat) + teal.transform::datanames_input(args["dat"]), + teal.transform::data_extract_ui( + id = ns("dat"), + label = "Data selection", + data_extract_spec = args$dat, + is_single_dataset = is_single_dataset_value ), bslib::accordion( open = TRUE, @@ -277,35 +267,35 @@ ui_a_pca.picks <- function(id, radioButtons( ns("plot_type"), label = "Plot type", - choices = plot_choices, - selected = plot_choices[1] + choices = args$plot_choices, + selected = args$plot_choices[1] ), conditionalPanel( condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_elbow_plot"), - decorators = select_decorators(decorators, "elbow_plot") + decorators = select_decorators(args$decorators, "elbow_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_circle_plot"), - decorators = select_decorators(decorators, "circle_plot") + decorators = select_decorators(args$decorators, "circle_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), ui_decorate_teal_data( ns("d_biplot"), - decorators = select_decorators(decorators, "biplot") + decorators = select_decorators(args$decorators, "biplot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_eigenvector_plot"), - decorators = select_decorators(decorators, "eigenvector_plot") + decorators = select_decorators(args$decorators, "eigenvector_plot") ) ) ), @@ -328,9 +318,14 @@ ui_a_pca.picks <- function(id, conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), list( - shinyWidgets::pickerInput(inputId = ns("response"), label = "Color by", choices = NULL), - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE) + teal.transform::data_extract_ui( + id = ns("response"), + label = "Color by", + data_extract_spec = color_selector, + is_single_dataset = is_single_dataset_value + ), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE) ) ) ), @@ -339,165 +334,243 @@ ui_a_pca.picks <- function(id, collapsed = TRUE, conditionalPanel( condition = sprintf( - "input['%1$s'] == 'Elbow plot' || input['%1$s'] == 'Eigenvector plot'", ns("plot_type") + "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", + ns("plot_type"), + ns("plot_type") ), - list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels)) + list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels)) ), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = ggtheme, + selected = args$ggtheme, multiple = FALSE ), - teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", font_size, ticks = FALSE) + teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE) ) ) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) ) } # Server function for the PCA module -srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { +srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(dat = dat), data = data) + response <- dat - qenv <- reactive({ - validate_input( - "dat-variables-selected", - length(selectors$dat()$variables$selected) > 1, - "Please select more than 1 variable to perform PCA." + for (i in seq_along(response)) { + response[[i]]$select$multiple <- FALSE + response[[i]]$select$always_selected <- NULL + response[[i]]$select$selected <- NULL + all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) + ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) + color_cols <- all_cols[!names(all_cols) %in% ignore_cols] + response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) + } + + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(dat = dat, response = response), + datasets = data, + select_validation_rule = list( + dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", + response = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (isTRUE(is.element(., selector_list()$dat()$select))) { + "Response must not have been used for PCA." + } + ) ) - obj <- req(data()) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + iv_extra <- shinyvalidate::InputValidator$new() + iv_extra$add_rule("x_axis", function(value) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (!shinyvalidate::input_provided(value)) { + "Need X axis" + } + } + }) + iv_extra$add_rule("y_axis", function(value) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (!shinyvalidate::input_provided(value)) { + "Need Y axis" + } + } + }) + rule_dupl <- function(...) { + if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { + if (isTRUE(input$x_axis == input$y_axis)) { + "Please choose different X and Y axes." + } + } + } + iv_extra$add_rule("x_axis", rule_dupl) + iv_extra$add_rule("y_axis", rule_dupl) + iv_extra$add_rule("variables", function(value) { + if (identical(input$plot_type, "Circle plot")) { + if (!shinyvalidate::input_provided(value)) { + "Need Original Coordinates" + } + } + }) + iv_extra$add_rule("pc", function(value) { + if (identical(input$plot_type, "Eigenvector plot")) { + if (!shinyvalidate::input_provided(value)) { + "Need PC" + } + } + }) + iv_extra$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + qenv <- reactive({ + obj <- data() teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Principal Component Analysis"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') # nolint: quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) }) - merged <- merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") - anl_merged_q <- merged$data - selected_vars <- reactive(merged$merge_vars()$dat) - - validate_data <- reactive({ - obj <- req(anl_merged_q()) - anl <- obj[["anl"]] - validate_input( - "dat-variables-selected", - condition = sum(stats::complete.cases(anl[selected_vars()])) > 10, - message = "Number of complete cases is less than 10" - ) - validate_input( - "na_action", - condition = input$na_action != "none" | !anyNA(anl[selected_vars()]), - message = paste( - "There are NAs in the dataset. Please deal with them in preprocessing", - "or select \"Drop\" in the NA actions." - ) - ) + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + + validation <- reactive({ + req(merged$anl_q_r()) + # inputs + keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + na_action <- input$na_action standardization <- input$standardization + center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" + ANL <- merged$anl_q_r()[["ANL"]] - if (scale) { - not_single <- vapply( - anl[selected_vars()], - function(column) length(unique(column)) != 1, - FUN.VALUE = logical(1) + teal::validate_has_data(ANL, 10) + validate(need( + na_action != "none" | !anyNA(ANL[keep_cols]), + paste( + "There are NAs in the dataset. Please deal with them in preprocessing", + "or select \"Drop\" in the NA actions inside the encodings panel (left)." ) - validate_input( - "standarization", - condition = all(not_single), - message = paste0( - "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", - "but one or more of your columns has/have a variance value of zero, indicating all values are identical" - ) + )) + if (scale) { + not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) + + msg <- paste0( + "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", + "but one or more of your columns has/have a variance value of zero, indicating all values are identical" ) + validate(need(all(not_single), msg)) } }) - validate_xy_axis <- reactive({ - validate_input( - "x_axis", - condition = input$x_axis != input$y_axis, - message = "Please choose different X and Y axes." - ) - }) - - observeEvent(selected_vars(), { - shinyWidgets::updatePickerInput( - inputId = "response", - choices = selected_vars(), - selected = input$response - ) - }) - + # computation ---- computation <- reactive({ - validate_data() + validation() + # inputs - anl_cols <- selected_vars() + keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) na_action <- input$na_action standardization <- input$standardization center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - anl <- anl_merged_q()[["anl"]] + ANL <- merged$anl_q_r()[["ANL"]] - qenv <- within(anl_merged_q(), anl_cols <- cols, cols = unname(anl_cols)) + qenv <- teal.code::eval_code( + merged$anl_q_r(), + substitute( + expr = keep_columns <- keep_cols, + env = list(keep_cols = keep_cols) + ) + ) if (na_action == "drop") { - qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(anl_cols))) + qenv <- teal.code::eval_code( + qenv, + quote(ANL <- tidyr::drop_na(ANL, keep_columns)) + ) } - qenv <- within( + qenv <- teal.code::eval_code( qenv, - pca <- summary(stats::prcomp(anl[anl_cols], center = center, scale. = scale, retx = TRUE)), - center = center, scale = scale + substitute( + expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), + env = list(center = center, scale = scale) + ) ) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Principal Components Table") - qenv <- within(qenv, { - tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") - tbl_importance - }) + qenv <- teal.code::eval_code( + qenv, + quote({ + tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") + tbl_importance + }) + ) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Eigenvectors Table") - within(qenv, { - tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") - tbl_eigenvector - }) + teal.code::eval_code( + qenv, + quote({ + tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") + tbl_eigenvector + }) + ) }) + # plot args ---- output$plot_settings <- renderUI({ # reactivity triggers + req(iv_r()$is_valid()) req(computation()) qenv <- computation() ns <- session$ns + pca <- qenv[["pca"]] chcs_pcs <- colnames(pca$rotation) - chcs_vars <- qenv$anl_cols + chcs_vars <- qenv[["keep_columns"]] tagList( conditionalPanel( - condition = sprintf("input['%1$s'] == 'Biplot' || input['%1$s'] == 'Circle plot'", ns("plot_type")), + condition = sprintf( + "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", + ns("plot_type"), ns("plot_type") + ), list( - shinyWidgets::pickerInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), - shinyWidgets::pickerInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), - shinyWidgets::pickerInput( + teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), + teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), + teal.widgets::optionalSelectInput( ns("variables"), "Original coordinates", choices = chcs_vars, selected = chcs_vars, multiple = TRUE @@ -510,13 +583,13 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ), conditionalPanel( condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"), - shinyWidgets::pickerInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) + teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) ) ) }) + # plot elbow ---- plot_elbow <- function(base_q) { - logger::log_debug("srv_a_pca recalculate plot_elbow") ggtheme <- input$ggtheme rotate_xaxis_labels <- input$rotate_xaxis_labels font_size <- input$font_size @@ -589,14 +662,8 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ) } + # plot circle ---- plot_circle <- function(base_q) { - logger::log_debug("srv_a_pca recalculate plot_circle") - validate_xy_axis() - validate_input( - "variables", - condition = length(input$variables) > 0, - message = "Please select Original Coordinates for this visualization." - ) x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -668,19 +735,14 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ) } + # plot biplot ---- plot_biplot <- function(base_q) { - logger::log_debug("srv_a_pca recalculate plot_biplot") - validate_xy_axis() - validate_input( - "response", - condition = length(input$response) == 1, - message = "Please select Response variable to see this visualization." - ) qenv <- base_q - anl <- qenv[["anl"]] - anl_cols <- selected_vars() - resp_col <- input$response + ANL <- qenv[["ANL"]] + + resp_col <- as.character(merged$anl_input_r()$columns_source$response) + dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -724,7 +786,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args expr = { rot_vars <- rot_vars %>% tibble::column_to_rownames("label") %>% - sweep(1, apply(anl[anl_cols], 2, mean, na.rm = TRUE)) %>% + sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% tibble::rownames_to_column("label") %>% dplyr::mutate( xstart = mean(pca$x[, x_axis], na.rm = TRUE), @@ -759,7 +821,9 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ) dev_labs <- list() } else { - response <- anl[[resp_col]] + rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) + + response <- ANL[[resp_col]] aes_biplot <- substitute( ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"), @@ -768,10 +832,10 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args qenv <- teal.code::eval_code( qenv, - substitute(response <- anl[[resp_col]], env = list(resp_col = resp_col)) + substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) ) - dev_labs <- list(color = varname_w_label(resp_col, anl)) + dev_labs <- list(color = varname_w_label(resp_col, ANL)) scales_biplot <- if ( @@ -890,13 +954,8 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args ) } + # plot eigenvector_plot ---- plot_eigenvector <- function(base_q) { - logger::log_debug("srv_a_pca recalculate plot_eigenvector") - validate_input( - "pc", - condition = length(input$pc) > 0, - "Please select a Principal Component for this visualization" - ) req(input$pc) pc <- input$pc ggtheme <- input$ggtheme @@ -985,6 +1044,8 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args function(fun) { reactive({ req(computation()) + teal::validate_inputs(iv_r()) + teal::validate_inputs(iv_extra, header = "Plot settings are required") fun(computation()) }) } @@ -1035,7 +1096,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args output$tbl_importance <- renderTable( expr = { req("importance" %in% input$tables_display, computation()) - logger::log_debug("srv_a_pca rerender tbl_importance") computation()[["tbl_importance"]] }, bordered = TRUE, @@ -1043,10 +1103,19 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args digits = 3 ) + output$tbl_importance_ui <- renderUI({ + req("importance" %in% input$tables_display) + tags$div( + align = "center", + tags$h4("Principal components importance"), + tableOutput(session$ns("tbl_importance")), + tags$hr() + ) + }) + output$tbl_eigenvector <- renderTable( expr = { req("eigenvector" %in% input$tables_display, req(computation())) - logger::log_debug("srv_a_pca rerender tbl_eigenvector") computation()[["tbl_eigenvector"]] }, bordered = TRUE, @@ -1056,8 +1125,25 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args output$tbl_eigenvector_ui <- renderUI({ req("eigenvector" %in% input$tables_display) + tags$div( + align = "center", + tags$h4("Eigenvectors"), + tableOutput(session$ns("tbl_eigenvector")), + tags$hr() + ) }) + output$all_plots <- renderUI({ + teal::validate_inputs(iv_r()) + teal::validate_inputs(iv_extra, header = "Plot settings are required") + + validation() + tags$div( + uiOutput(session$ns("tbl_importance_ui")), + uiOutput(session$ns("tbl_eigenvector_ui")), + teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot")) + ) + }) # Render R code. source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) @@ -1070,8 +1156,3 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args decorated_output_dims_q }) } - - -ui_elbow <- function(id) { - ns <- NS(id) -} diff --git a/R/tm_a_pca_old.R b/R/tm_a_pca_picks.R similarity index 71% rename from R/tm_a_pca_old.R rename to R/tm_a_pca_picks.R index ed25e8a96..7431a5aa1 100644 --- a/R/tm_a_pca_old.R +++ b/R/tm_a_pca_picks.R @@ -1,27 +1,33 @@ #' @export -tm_a_pca.default <- function(label = "Principal Component Analysis", - dat, - plot_height = c(600, 200, 2000), - plot_width = NULL, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - rotate_xaxis_labels = FALSE, - font_size = c(12, 8, 20), - alpha = c(1, 0, 1), - size = c(2, 1, 8), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_a_pca.picks <- function(label = "Principal Component Analysis", + dat = picks( + datasets(), + variables( + choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), + selected = tidyselect::everything(), + multiple = TRUE + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + rotate_xaxis_labels = FALSE, + font_size = c(12, 8, 20), + alpha = c(1, 0, 1), + size = c(2, 1, 8), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_a_pca") # Normalize the parameters - if (inherits(dat, "data_extract_spec")) dat <- list(dat) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(dat, types = "data_extract_spec") + checkmate::assert_class(dat, "picks") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -69,55 +75,59 @@ tm_a_pca.default <- function(label = "Principal Component Analysis", # Make UI args args <- as.list(environment()) - data_extract_list <- list(dat = dat) - ans <- module( label = label, - server = srv_a_pca.default, - ui = ui_a_pca.default, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + ui = ui_a_pca.picks, + server = srv_a_pca.picks, + ui_args = args[names(args) %in% names(formals(ui_a_pca.picks))], + server_args = args[names(args) %in% names(formals(srv_a_pca.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(dat)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the PCA module -ui_a_pca.default <- function(id, ...) { +ui_a_pca.picks <- function(id, + dat, + plot_choices, + ggtheme, + rotate_xaxis_labels, + font_size, + alpha, + size, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$dat) - - color_selector <- args$dat - for (i in seq_along(color_selector)) { - color_selector[[i]]$select$multiple <- FALSE - color_selector[[i]]$select$always_selected <- NULL - color_selector[[i]]$select$selected <- NULL - } - tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( - uiOutput(ns("all_plots")) + tags$div( + tags$div( + align = "center", + tags$h4("Principal components importance"), + tableOutput(ns("tbl_importance")), + tags$hr() + ), + tags$div( + align = "center", + tags$h4("Eigenvectors"), + tableOutput(ns("tbl_eigenvector")), + tags$hr() + ), + teal.widgets::plot_with_settings_ui(id = ns("pca_plot")) + ) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args["dat"]), - teal.transform::data_extract_ui( - id = ns("dat"), - label = "Data selection", - data_extract_spec = args$dat, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Data selection"), + teal.transform::module_input_ui(id = ns("dat"), spec = dat) ), bslib::accordion( open = TRUE, @@ -132,35 +142,35 @@ ui_a_pca.default <- function(id, ...) { radioButtons( ns("plot_type"), label = "Plot type", - choices = args$plot_choices, - selected = args$plot_choices[1] + choices = plot_choices, + selected = plot_choices[1] ), conditionalPanel( condition = sprintf("input['%s'] == 'Elbow plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_elbow_plot"), - decorators = select_decorators(args$decorators, "elbow_plot") + decorators = select_decorators(decorators, "elbow_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Circle plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_circle_plot"), - decorators = select_decorators(args$decorators, "circle_plot") + decorators = select_decorators(decorators, "circle_plot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), ui_decorate_teal_data( ns("d_biplot"), - decorators = select_decorators(args$decorators, "biplot") + decorators = select_decorators(decorators, "biplot") ) ), conditionalPanel( condition = sprintf("input['%s'] == 'Eigenvector plot'", ns("plot_type")), ui_decorate_teal_data( ns("d_eigenvector_plot"), - decorators = select_decorators(args$decorators, "eigenvector_plot") + decorators = select_decorators(decorators, "eigenvector_plot") ) ) ), @@ -183,14 +193,9 @@ ui_a_pca.default <- function(id, ...) { conditionalPanel( condition = sprintf("input['%s'] == 'Biplot'", ns("plot_type")), list( - teal.transform::data_extract_ui( - id = ns("response"), - label = "Color by", - data_extract_spec = color_selector, - is_single_dataset = is_single_dataset_value - ), - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE) + shinyWidgets::pickerInput(inputId = ns("response"), label = "Color by", choices = NULL), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE) ) ) ), @@ -199,243 +204,165 @@ ui_a_pca.default <- function(id, ...) { collapsed = TRUE, conditionalPanel( condition = sprintf( - "input['%s'] == 'Elbow plot' || input['%s'] == 'Eigenvector plot'", - ns("plot_type"), - ns("plot_type") + "input['%1$s'] == 'Elbow plot' || input['%1$s'] == 'Eigenvector plot'", ns("plot_type") ), - list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels)) + list(checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels)) ), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ), - teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", args$font_size, ticks = FALSE) + teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", font_size, ticks = FALSE) ) ) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) ) } # Server function for the PCA module -srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { +srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - response <- dat - - for (i in seq_along(response)) { - response[[i]]$select$multiple <- FALSE - response[[i]]$select$always_selected <- NULL - response[[i]]$select$selected <- NULL - all_cols <- teal.data::col_labels(isolate(data())[[response[[i]]$dataname]]) - ignore_cols <- unlist(teal.data::join_keys(isolate(data()))[[response[[i]]$dataname]]) - color_cols <- all_cols[!names(all_cols) %in% ignore_cols] - response[[i]]$select$choices <- teal.transform::choices_labeled(names(color_cols), color_cols) - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(dat = dat, response = response), - datasets = data, - select_validation_rule = list( - dat = ~ if (length(.) < 2L) "Please select more than 1 variable to perform PCA.", - response = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (isTRUE(is.element(., selector_list()$dat()$select))) { - "Response must not have been used for PCA." - } - ) - ) - ) + selectors <- teal.transform::module_input_srv(spec = list(dat = dat), data = data) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - iv_extra <- shinyvalidate::InputValidator$new() - iv_extra$add_rule("x_axis", function(value) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (!shinyvalidate::input_provided(value)) { - "Need X axis" - } - } - }) - iv_extra$add_rule("y_axis", function(value) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (!shinyvalidate::input_provided(value)) { - "Need Y axis" - } - } - }) - rule_dupl <- function(...) { - if (isTRUE(input$plot_type %in% c("Circle plot", "Biplot"))) { - if (isTRUE(input$x_axis == input$y_axis)) { - "Please choose different X and Y axes." - } - } - } - iv_extra$add_rule("x_axis", rule_dupl) - iv_extra$add_rule("y_axis", rule_dupl) - iv_extra$add_rule("variables", function(value) { - if (identical(input$plot_type, "Circle plot")) { - if (!shinyvalidate::input_provided(value)) { - "Need Original Coordinates" - } - } - }) - iv_extra$add_rule("pc", function(value) { - if (identical(input$plot_type, "Eigenvector plot")) { - if (!shinyvalidate::input_provided(value)) { - "Need PC" - } - } - }) - iv_extra$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) qenv <- reactive({ - obj <- data() + validate_input( + "dat-variables-selected", + length(selectors$dat()$variables$selected) > 1, + "Please select more than 1 variable to perform PCA." + ) + obj <- req(data()) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Principal Component Analysis"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') # nolint: quotes - }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tidyr")') }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - validation <- reactive({ - req(merged$anl_q_r()) - # inputs - keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) - na_action <- input$na_action + merged <- merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + anl_merged_q <- merged$data + selected_vars <- reactive(merged$merge_vars()$dat) + + validate_data <- reactive({ + obj <- req(anl_merged_q()) + anl <- obj[["anl"]] + validate_input( + "dat-variables-selected", + condition = sum(stats::complete.cases(anl[selected_vars()])) > 10, + message = "Number of complete cases is less than 10" + ) + validate_input( + "na_action", + condition = input$na_action != "none" | !anyNA(anl[selected_vars()]), + message = paste( + "There are NAs in the dataset. Please deal with them in preprocessing", + "or select \"Drop\" in the NA actions." + ) + ) standardization <- input$standardization - center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - ANL <- merged$anl_q_r()[["ANL"]] - teal::validate_has_data(ANL, 10) - validate(need( - na_action != "none" | !anyNA(ANL[keep_cols]), - paste( - "There are NAs in the dataset. Please deal with them in preprocessing", - "or select \"Drop\" in the NA actions inside the encodings panel (left)." - ) - )) if (scale) { - not_single <- vapply(ANL[keep_cols], function(column) length(unique(column)) != 1, FUN.VALUE = logical(1)) - - msg <- paste0( - "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", - "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + not_single <- vapply( + anl[selected_vars()], + function(column) length(unique(column)) != 1, + FUN.VALUE = logical(1) + ) + validate_input( + "standarization", + condition = all(not_single), + message = paste0( + "You have selected `Center & Scale` under `Standardization` in the `Pre-processing` panel, ", + "but one or more of your columns has/have a variance value of zero, indicating all values are identical" + ) ) - validate(need(all(not_single), msg)) } }) - # computation ---- - computation <- reactive({ - validation() + validate_xy_axis <- reactive({ + validate_input( + "x_axis", + condition = input$x_axis != input$y_axis, + message = "Please choose different X and Y axes." + ) + }) + observeEvent(selected_vars(), { + shinyWidgets::updatePickerInput( + inputId = "response", + choices = selected_vars(), + selected = input$response + ) + }) + + computation <- reactive({ + validate_data() # inputs - keep_cols <- as.character(merged$anl_input_r()$columns_source$dat) + anl_cols <- selected_vars() na_action <- input$na_action standardization <- input$standardization center <- standardization %in% c("center", "center_scale") scale <- standardization == "center_scale" - ANL <- merged$anl_q_r()[["ANL"]] + anl <- anl_merged_q()[["anl"]] - qenv <- teal.code::eval_code( - merged$anl_q_r(), - substitute( - expr = keep_columns <- keep_cols, - env = list(keep_cols = keep_cols) - ) - ) + qenv <- within(anl_merged_q(), anl_cols <- cols, cols = unname(anl_cols)) if (na_action == "drop") { - qenv <- teal.code::eval_code( - qenv, - quote(ANL <- tidyr::drop_na(ANL, keep_columns)) - ) + qenv <- within(qenv, anl <- tidyr::drop_na(anl, any_of(anl_cols))) } - qenv <- teal.code::eval_code( + qenv <- within( qenv, - substitute( - expr = pca <- summary(stats::prcomp(ANL[keep_columns], center = center, scale. = scale, retx = TRUE)), - env = list(center = center, scale = scale) - ) + pca <- summary(stats::prcomp(anl[anl_cols], center = center, scale. = scale, retx = TRUE)), + center = center, scale = scale ) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Principal Components Table") - qenv <- teal.code::eval_code( - qenv, - quote({ - tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") - tbl_importance - }) - ) + qenv <- within(qenv, { + tbl_importance <- dplyr::as_tibble(pca$importance, rownames = "Metric") + tbl_importance + }) teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Eigenvectors Table") - teal.code::eval_code( - qenv, - quote({ - tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") - tbl_eigenvector - }) - ) + within(qenv, { + tbl_eigenvector <- dplyr::as_tibble(pca$rotation, rownames = "Variable") + tbl_eigenvector + }) }) - # plot args ---- output$plot_settings <- renderUI({ # reactivity triggers - req(iv_r()$is_valid()) req(computation()) qenv <- computation() ns <- session$ns - pca <- qenv[["pca"]] chcs_pcs <- colnames(pca$rotation) - chcs_vars <- qenv[["keep_columns"]] + chcs_vars <- qenv$anl_cols tagList( conditionalPanel( - condition = sprintf( - "input['%s'] == 'Biplot' || input['%s'] == 'Circle plot'", - ns("plot_type"), ns("plot_type") - ), + condition = sprintf("input['%1$s'] == 'Biplot' || input['%1$s'] == 'Circle plot'", ns("plot_type")), list( - teal.widgets::optionalSelectInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), - teal.widgets::optionalSelectInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), - teal.widgets::optionalSelectInput( + shinyWidgets::pickerInput(ns("x_axis"), "X axis", choices = chcs_pcs, selected = chcs_pcs[1]), + shinyWidgets::pickerInput(ns("y_axis"), "Y axis", choices = chcs_pcs, selected = chcs_pcs[2]), + shinyWidgets::pickerInput( ns("variables"), "Original coordinates", choices = chcs_vars, selected = chcs_vars, multiple = TRUE @@ -448,13 +375,13 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar ), conditionalPanel( condition = paste0("input['", ns("plot_type"), "'] == 'Eigenvector plot'"), - teal.widgets::optionalSelectInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) + shinyWidgets::pickerInput(ns("pc"), "PC", choices = chcs_pcs, selected = chcs_pcs[1]) ) ) }) - # plot elbow ---- plot_elbow <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_elbow") ggtheme <- input$ggtheme rotate_xaxis_labels <- input$rotate_xaxis_labels font_size <- input$font_size @@ -527,8 +454,14 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar ) } - # plot circle ---- plot_circle <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_circle") + validate_xy_axis() + validate_input( + "variables", + condition = length(input$variables) > 0, + message = "Please select Original Coordinates for this visualization." + ) x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -600,14 +533,19 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar ) } - # plot biplot ---- plot_biplot <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_biplot") + validate_xy_axis() + validate_input( + "response", + condition = length(input$response) == 1, + message = "Please select Response variable to see this visualization." + ) qenv <- base_q + anl <- qenv[["anl"]] + anl_cols <- selected_vars() - ANL <- qenv[["ANL"]] - - resp_col <- as.character(merged$anl_input_r()$columns_source$response) - dat_cols <- as.character(merged$anl_input_r()$columns_source$dat) + resp_col <- input$response x_axis <- input$x_axis y_axis <- input$y_axis variables <- input$variables @@ -651,7 +589,7 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar expr = { rot_vars <- rot_vars %>% tibble::column_to_rownames("label") %>% - sweep(1, apply(ANL[keep_columns], 2, mean, na.rm = TRUE)) %>% + sweep(1, apply(anl[anl_cols], 2, mean, na.rm = TRUE)) %>% tibble::rownames_to_column("label") %>% dplyr::mutate( xstart = mean(pca$x[, x_axis], na.rm = TRUE), @@ -686,9 +624,7 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar ) dev_labs <- list() } else { - rp_keys <- setdiff(colnames(ANL), as.character(unlist(merged$anl_input_r()$columns_source))) - - response <- ANL[[resp_col]] + response <- anl[[resp_col]] aes_biplot <- substitute( ggplot2::aes_string(x = x_axis, y = y_axis, color = "response"), @@ -697,10 +633,10 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar qenv <- teal.code::eval_code( qenv, - substitute(response <- ANL[[resp_col]], env = list(resp_col = resp_col)) + substitute(response <- anl[[resp_col]], env = list(resp_col = resp_col)) ) - dev_labs <- list(color = varname_w_label(resp_col, ANL)) + dev_labs <- list(color = varname_w_label(resp_col, anl)) scales_biplot <- if ( @@ -819,8 +755,13 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar ) } - # plot eigenvector_plot ---- plot_eigenvector <- function(base_q) { + logger::log_debug("srv_a_pca recalculate plot_eigenvector") + validate_input( + "pc", + condition = length(input$pc) > 0, + "Please select a Principal Component for this visualization" + ) req(input$pc) pc <- input$pc ggtheme <- input$ggtheme @@ -909,8 +850,6 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar function(fun) { reactive({ req(computation()) - teal::validate_inputs(iv_r()) - teal::validate_inputs(iv_extra, header = "Plot settings are required") fun(computation()) }) } @@ -961,6 +900,7 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar output$tbl_importance <- renderTable( expr = { req("importance" %in% input$tables_display, computation()) + logger::log_debug("srv_a_pca rerender tbl_importance") computation()[["tbl_importance"]] }, bordered = TRUE, @@ -968,19 +908,10 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar digits = 3 ) - output$tbl_importance_ui <- renderUI({ - req("importance" %in% input$tables_display) - tags$div( - align = "center", - tags$h4("Principal components importance"), - tableOutput(session$ns("tbl_importance")), - tags$hr() - ) - }) - output$tbl_eigenvector <- renderTable( expr = { req("eigenvector" %in% input$tables_display, req(computation())) + logger::log_debug("srv_a_pca rerender tbl_eigenvector") computation()[["tbl_eigenvector"]] }, bordered = TRUE, @@ -990,25 +921,8 @@ srv_a_pca.default <- function(id, data, dat, plot_height, plot_width, ggplot2_ar output$tbl_eigenvector_ui <- renderUI({ req("eigenvector" %in% input$tables_display) - tags$div( - align = "center", - tags$h4("Eigenvectors"), - tableOutput(session$ns("tbl_eigenvector")), - tags$hr() - ) }) - output$all_plots <- renderUI({ - teal::validate_inputs(iv_r()) - teal::validate_inputs(iv_extra, header = "Plot settings are required") - - validation() - tags$div( - uiOutput(session$ns("tbl_importance_ui")), - uiOutput(session$ns("tbl_eigenvector_ui")), - teal.widgets::plot_with_settings_ui(id = session$ns("pca_plot")) - ) - }) # Render R code. source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 086b11ffa..989f44d74 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -161,55 +161,35 @@ tm_a_regression <- function(label = "Regression Analysis", } #' @export -tm_a_regression.picks <- function(label = "Regression Analysis", - regressor = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric), - selected = tidyselect::last_col(), - multiple = TRUE - ), - values() - ), - response = picks( - datasets(), - variables(choices = tidyselect::where(is.numeric)), - values() - ), - outlier = picks( - regressor$datasets, - variables(choices = where(~ is.factor(.) || is.character(.))), - values() - ), # default should be picks(datasets(), variables(primary_keys()) - plot_height = c(600, 200, 2000), - plot_width = NULL, - alpha = c(1, 0, 1), - size = c(2, 1, 8), - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - default_plot_type = 1, - default_outlier_label, - label_segment_threshold = c(0.5, 0, 10), - transformators = list(), - decorators = list()) { +tm_a_regression.default <- function(label = "Regression Analysis", + regressor, + response, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label = "USUBJID", + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { message("Initializing tm_a_regression") + # Normalize the parameters + if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) + if (inherits(response, "data_extract_spec")) response <- list(response) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(regressor, "picks") + checkmate::assert_list(regressor, types = "data_extract_spec") - checkmate::assert_class(response, "picks") - if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(response$variables, "multiple") <- FALSE - } - checkmate::assert_class(outlier, "picks", null.ok = TRUE) - if (isTRUE(attr(outlier$variables, "multiple"))) { - warning("`outlier` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(outlier$variables, "multiple") <- FALSE - } + checkmate::assert_list(response, types = "data_extract_spec") + assert_single_selection(response) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -239,7 +219,6 @@ tm_a_regression.picks <- function(label = "Regression Analysis", ggtheme <- match.arg(ggtheme) - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) plot_choices <- c( "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" @@ -250,9 +229,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) - if (!missing(default_outlier_label)) { - warning("`default_outlier_label` is not supported when using picks. Please use `outlier` argument.") - } + checkmate::assert_string(default_outlier_label) checkmate::assert_list(decorators, "teal_transform_module") if (length(label_segment_threshold) == 1) { @@ -271,38 +248,39 @@ tm_a_regression.picks <- function(label = "Regression Analysis", # Make UI args args <- as.list(environment()) + args[["plot_choices"]] <- plot_choices + data_extract_list <- list( + regressor = regressor, + response = response + ) ans <- module( label = label, - server = srv_a_regression.picks, - ui = ui_a_regression.picks, - ui_args = args[names(args) %in% names(formals(ui_a_regression.picks))], - server_args = args[names(args) %in% names(formals(srv_a_regression.picks))], , + server = srv_a_regression.default, + ui = ui_a_regression.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + default_outlier_label = default_outlier_label, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(regressor, response)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the regression module -ui_a_regression.picks <- function(id, - response, - regressor, - outlier, - plot_choices, - default_plot_type, - alpha, - size, - label_segment_threshold, - ggtheme, - pre_output, - post_output, - decorators) { +ui_a_regression.default <- function(id, ...) { ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) teal.widgets::standard_layout( output = teal.widgets::white_small_well(tags$div( teal.widgets::plot_with_settings_ui(id = ns("myplot")), @@ -310,26 +288,31 @@ ui_a_regression.picks <- function(id, )), encoding = tags$div( tags$label("Encodings", class = "text-primary"), tags$br(), - teal::teal_nav_item( - label = tags$strong("Response variable"), - teal.transform::module_input_ui(id = ns("response"), spec = response) + teal.transform::datanames_input(args[c("response", "regressor")]), + teal.transform::data_extract_ui( + id = ns("response"), + label = "Response variable", + data_extract_spec = args$response, + is_single_dataset = is_single_dataset_value ), - teal::teal_nav_item( - label = tags$strong("Regressor variables"), - teal.transform::module_input_ui(id = ns("regressor"), spec = regressor) + teal.transform::data_extract_ui( + id = ns("regressor"), + label = "Regressor variables", + data_extract_spec = args$regressor, + is_single_dataset = is_single_dataset_value ), radioButtons( ns("plot_type"), label = "Plot type:", - choices = plot_choices, - selected = plot_choices[default_plot_type] + choices = args$plot_choices, + selected = args$plot_choices[args$default_plot_type] ), - checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = FALSE), + checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE), conditionalPanel( condition = "input['show_outlier']", ns = ns, teal.widgets::optionalSliderInput( - ns("outlier_cutoff"), + ns("outlier"), tags$div( tagList( "Outlier definition:", @@ -345,15 +328,19 @@ ui_a_regression.picks <- function(id, ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.transform::module_input_ui(id = ns("outlier"), spec = outlier) + teal.widgets::optionalSelectInput( + ns("label_var"), + multiple = FALSE, + label = "Outlier label" + ) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE), teal.widgets::optionalSliderInputValMinMax( inputId = ns("label_min_segment"), label = tags$div( @@ -371,7 +358,7 @@ ui_a_regression.picks <- function(id, ) ) ), - value_min_max = label_segment_threshold, + value_min_max = args$label_segment_threshold, # Extra parameters to sliderInput ticks = FALSE, step = .1, @@ -381,7 +368,7 @@ ui_a_regression.picks <- function(id, inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = ggtheme, + selected = args$ggtheme, multiple = FALSE ) ) @@ -390,118 +377,194 @@ ui_a_regression.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the regression module -srv_a_regression.picks <- function(id, - data, - response, - regressor, - outlier, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_a_regression.default <- function(id, + data, + response, + regressor, + plot_height, + plot_width, + ggplot2_args, + default_outlier_label, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + ns <- session$ns - selectors <- teal.transform::module_input_srv( - spec = list(response = response, regressor = regressor, outlier = outlier), - data = data - ) + rule_rvr1 <- function(value) { + if (isTRUE(input$plot_type == "Response vs Regressor")) { + if (length(value) > 1L) { + "This plot can only have one regressor." + } + } + } + rule_rvr2 <- function(other) { + function(value) { + if (isTRUE(input$plot_type == "Response vs Regressor")) { + otherval <- selector_list()[[other]]()$select + if (isTRUE(value == otherval)) { + "Response and Regressor must be different." + } + } + } + } - validated_q <- reactive({ - req(data()) - validate_input( - inputId = "response-variables-selected", - condition = is.numeric( - data()[[selectors$response()$datasets$selected]][[selectors$response()$variables$selected]] + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(response = response, regressor = regressor), + datasets = data, + select_validation_rule = list( + regressor = shinyvalidate::compose_rules( + shinyvalidate::sv_required("At least one regressor should be selected."), + rule_rvr1, + rule_rvr2("response") ), - message = "A response variable needs to be numeric." - ) - validate_input( - inputId = "regressor-variables-selected", - condition = length(selectors$regressor()$variables$selected) > 0, - message = "A regressor variables need to be selected." - ) - validate_input( - inputId = c("regressor-variables-selected", "response-variables-selected"), - condition = !any(selectors$regressor()$variables$selected %in% selectors$response()$variables$selected), - message = "Response and Regressor must be different." + response = shinyvalidate::compose_rules( + shinyvalidate::sv_required("At least one response should be selected."), + rule_rvr2("regressor") + ) ) - validate_input( - inputId = c("show_outlier", "outlier-variables-selected"), - condition = !(isTRUE(input$show_outlier) && length(selectors$outlier()$variables$selected) == 0), - message = "Please provide an `Outlier label` variable" + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + iv_out <- shinyvalidate::InputValidator$new() + iv_out$condition(~ isTRUE(input$show_outlier)) + iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) + iv_out$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + + regression_var <- reactive({ + teal::validate_inputs(iv_r()) + + list( + response = as.vector(anl_merged_input()$columns_source$response), + regressor = as.vector(anl_merged_input()$columns_source$regressor) ) + }) + qenv <- reactive({ obj <- data() - teal.reporter::teal_card(obj) <- c( - teal.reporter::teal_card("# Linear Regression Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Linear Regression Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') # nolint: quotes }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) # sets qenv object and populates it with data merge call and fit expression fit_r <- reactive({ - obj <- req(merged$data()) - anl <- obj[["anl"]] - teal::validate_has_data(anl, 10) + ANL <- anl_merged_q()[["ANL"]] + teal::validate_has_data(ANL, 10) + + validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) teal::validate_has_data( - anl[, c(merged$merge_vars()$response, merged$merge_vars()$regressor)], 10, + ANL[, c(regression_var()$response, regression_var()$regressor)], 10, complete = TRUE, allow_inf = FALSE ) form <- stats::as.formula( paste( - merged$merge_vars()$response, + regression_var()$response, paste( - merged$merge_vars()$regressor, + regression_var()$regressor, collapse = " + " ), sep = " ~ " ) ) - anl_fit <- within(obj, form = form, { - fit <- stats::lm(form, data = anl) - for (regressor in names(fit$contrasts)) { - alts <- paste0(levels(anl[[regressor]]), collapse = "|") - names(fit$coefficients) <- gsub( - paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) - ) + if (input$show_outlier) { + opts <- teal.transform::variable_choices(ANL) + selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) { + isolate(input$label_var) + } else { + if (length(opts[as.character(opts) == default_outlier_label]) == 0) { + opts[[1]] + } else { + opts[as.character(opts) == default_outlier_label] + } } - fit_summary <- summary(fit) - fit_summary - }) + teal.widgets::updateOptionalSelectInput( + session = session, + inputId = "label_var", + choices = opts, + selected = restoreInput(ns("label_var"), selected) + ) + + data <- ggplot2::fortify(stats::lm(form, data = ANL)) + cooksd <- data$.cooksd[!is.nan(data$.cooksd)] + max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) + cur_outlier <- isolate(input$outlier) + updateSliderInput( + session = session, + inputId = "outlier", + min = 1, + max = max_outlier, + value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9) + ) + } + + anl_fit <- anl_merged_q() %>% + teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% + teal.code::eval_code(quote({ + for (regressor in names(fit$contrasts)) { + alts <- paste0(levels(ANL[[regressor]]), collapse = "|") + names(fit$coefficients) <- gsub( + paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) + ) + } + })) %>% + teal.code::eval_code(quote({ + fit_summary <- summary(fit) + fit_summary + })) teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "## Plot") anl_fit }) - outlier_label_call <- reactive({ + label_col <- reactive({ + teal::validate_inputs(iv_out) + substitute( expr = dplyr::if_else( - data$.cooksd > outlier_cutoff * mean(data$.cooksd, na.rm = TRUE), - as.character(stats::na.omit(anl)[[label_var]]), + data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), + as.character(stats::na.omit(ANL)[[label_var]]), "" ) %>% dplyr::if_else(is.na(.), "cooksd == NaN", .), - env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$merge_vars()$outlier) + env = list(outliers = input$outlier, label_var = input$label_var) ) }) - outlier_label_geom <- reactive({ + label_min_segment <- reactive({ + input$label_min_segment + }) + + outlier_label <- reactive({ substitute( expr = ggrepel::geom_text_repel( label = label_col, @@ -513,14 +576,14 @@ srv_a_regression.picks <- function(id, segment.alpha = 0.5, seed = 123 ), - env = list(label_col = outlier_label_call(), label_min_segment = input$label_min_segment) + env = list(label_col = label_col(), label_min_segment = label_min_segment()) ) }) output_plot_base <- reactive({ - obj <- fit_r() + base_fit <- fit_r() teal.code::eval_code( - obj, + base_fit, quote({ class(fit$residuals) <- NULL @@ -538,11 +601,12 @@ srv_a_regression.picks <- function(id, }) output_plot_0 <- reactive({ - obj <- req(fit_r()) - fit <- obj[["fit"]] - anl <- obj[["anl"]] + fit <- fit_r()[["fit"]] + ANL <- anl_merged_q()[["ANL"]] - if (!is.factor(anl[[merged$merge_vars()$regressor]])) { + stopifnot(ncol(fit$model) == 2) + + if (!is.factor(ANL[[regression_var()$regressor]])) { shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -550,8 +614,8 @@ srv_a_regression.picks <- function(id, ggplot2::geom_point(size = size, alpha = alpha) + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), env = list( - regressor = merged$merge_vars()$regressor, - response = merged$merge_vars()$response, + regressor = regression_var()$regressor, + response = regression_var()$response, size = input$size, alpha = input$alpha ) @@ -559,7 +623,7 @@ srv_a_regression.picks <- function(id, if (input$show_outlier) { plot <- substitute( expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) + env = list(plot = plot, outlier_label = outlier_label()) ) } } else { @@ -568,13 +632,10 @@ srv_a_regression.picks <- function(id, plot <- substitute( expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + ggplot2::geom_boxplot(), - env = list(regressor = merged$merge_vars()$regressor, response = merged$merge_vars()$response) + env = list(regressor = regression_var()$regressor, response = regression_var()$response) ) if (input$show_outlier) { - plot <- substitute( - expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) - ) + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) } } @@ -585,8 +646,8 @@ srv_a_regression.picks <- function(id, module_plot = teal.widgets::ggplot2_args( labs = list( title = "Response vs Regressor", - x = varname_w_label(merged$merge_vars()$regressor, anl), - y = varname_w_label(merged$merge_vars()$response, anl) + x = varname_w_label(regression_var()$regressor, ANL), + y = varname_w_label(regression_var()$response, ANL) ), theme = list() ) @@ -595,7 +656,7 @@ srv_a_regression.picks <- function(id, ) teal.code::eval_code( - obj, + fit_r(), substitute( expr = { class(fit$residuals) <- NULL @@ -610,7 +671,7 @@ srv_a_regression.picks <- function(id, }) output_plot_1 <- reactive({ - obj <- req(output_plot_base()) + plot_base <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -621,10 +682,7 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute( - expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) - ) + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -642,20 +700,24 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = { - smoothy <- smooth(data$.fitted, data$.resid) - plot <- graph - }, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.fitted, data$.resid) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_plot_2 <- reactive({ - obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") + plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) + ggplot2::stat_qq(size = size, alpha = alpha) + @@ -667,7 +729,10 @@ srv_a_regression.picks <- function(id, expr = plot + ggplot2::stat_qq( geom = ggrepel::GeomTextRepel, - label = label_col, + label = label_col %>% + data.frame(label = .) %>% + dplyr::filter(label != "cooksd == NaN") %>% + unlist(), color = "red", hjust = 0, vjust = 0, @@ -676,7 +741,7 @@ srv_a_regression.picks <- function(id, segment.alpha = .5, seed = 123 ), - env = list(plot = plot, label_col = outlier_label_call(), label_min_segment = input$label_min_segment) + env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) ) } @@ -695,17 +760,23 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = plot <- graph, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_plot_3 <- reactive({ - obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") + plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) + ggplot2::geom_point(size = size, alpha = alpha) + @@ -713,10 +784,7 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute( - expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) - ) + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -734,20 +802,24 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = { - smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) - plot <- graph - }, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_plot_4 <- reactive({ - obj <- output_plot_base() shinyjs::hide("size") shinyjs::show("alpha") + plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) + ggplot2::geom_col(alpha = alpha), @@ -775,7 +847,7 @@ srv_a_regression.picks <- function(id, angle = 90 ) + outlier_label, - env = list(plot = plot, outlier = input$outlier_cutoff, outlier_label = outlier_label_geom()) + env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) ) } @@ -794,17 +866,23 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = plot <- graph, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_plot_5 <- reactive({ - obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") + plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) + ggplot2::geom_vline( @@ -824,10 +902,7 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute( - expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) - ) + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -845,20 +920,24 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = { - smoothy <- smooth(data$.hat, data$.stdresid) - plot <- graph - }, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.hat, data$.stdresid) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_plot_6 <- reactive({ - obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") + plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) + ggplot2::geom_vline(xintercept = 0, colour = NA) + @@ -873,10 +952,7 @@ srv_a_regression.picks <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute( - expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label_geom()) - ) + plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -894,34 +970,30 @@ srv_a_regression.picks <- function(id, ggtheme = input$ggtheme ) - within( - obj, - expr = { - smoothy <- smooth(data$.hat, data$.cooksd) - plot <- graph - }, - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + teal.code::eval_code( + plot_base, + substitute( + expr = { + smoothy <- smooth(data$.hat, data$.cooksd) + plot <- graph + }, + env = list( + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) + ) + ) ) }) output_q <- reactive({ - req(input$plot_type) - validate_input( - inputId = c("plot_type", "regressor-variables-selected"), - condition = !( - identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 - ), - message = "This plot works only with single Regressor variable" - ) - + teal::validate_inputs(iv_r()) switch(input$plot_type, - "Response vs Regressor" = req(output_plot_0()), - "Residuals vs Fitted" = req(output_plot_1()), - "Normal Q-Q" = req(output_plot_2()), - "Scale-Location" = req(output_plot_3()), - "Cook's distance" = req(output_plot_4()), - "Residuals vs Leverage" = req(output_plot_5()), - "Cook's dist vs Leverage" = req(output_plot_6()) + "Response vs Regressor" = output_plot_0(), + "Residuals vs Fitted" = output_plot_1(), + "Normal Q-Q" = output_plot_2(), + "Scale-Location" = output_plot_3(), + "Cook's distance" = output_plot_4(), + "Residuals vs Leverage" = output_plot_5(), + "Cook's dist vs Leverage" = output_plot_6() ) }) @@ -952,6 +1024,8 @@ srv_a_regression.picks <- function(id, decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) output$text <- renderText({ + req(iv_r()$is_valid()) + req(iv_out$is_valid()) paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") }) diff --git a/R/tm_a_regression_old.R b/R/tm_a_regression_picks.R similarity index 58% rename from R/tm_a_regression_old.R rename to R/tm_a_regression_picks.R index d7b8ab987..05bcb11bc 100644 --- a/R/tm_a_regression_old.R +++ b/R/tm_a_regression_picks.R @@ -1,33 +1,53 @@ #' @export -tm_a_regression.default <- function(label = "Regression Analysis", - regressor, - response, - plot_height = c(600, 200, 2000), - plot_width = NULL, - alpha = c(1, 0, 1), - size = c(2, 1, 8), - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - default_plot_type = 1, - default_outlier_label = "USUBJID", - label_segment_threshold = c(0.5, 0, 10), - transformators = list(), - decorators = list()) { +tm_a_regression.picks <- function(label = "Regression Analysis", + regressor = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric), + selected = tidyselect::last_col(), + multiple = TRUE + ), + values() + ), + response = picks( + datasets(), + variables(choices = tidyselect::where(is.numeric)), + values() + ), + outlier = picks( + regressor$datasets, + variables(choices = where(~ is.factor(.) || is.character(.))), + values() + ), # default should be picks(datasets(), variables(primary_keys()) + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + size = c(2, 1, 8), + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + default_plot_type = 1, + default_outlier_label, + label_segment_threshold = c(0.5, 0, 10), + transformators = list(), + decorators = list()) { message("Initializing tm_a_regression") - # Normalize the parameters - if (inherits(regressor, "data_extract_spec")) regressor <- list(regressor) - if (inherits(response, "data_extract_spec")) response <- list(response) - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) - # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(regressor, types = "data_extract_spec") + checkmate::assert_class(regressor, "picks") - checkmate::assert_list(response, types = "data_extract_spec") - assert_single_selection(response) + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE + } + checkmate::assert_class(outlier, "picks", null.ok = TRUE) + if (isTRUE(attr(outlier$variables, "multiple"))) { + warning("`outlier` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(outlier$variables, "multiple") <- FALSE + } checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -57,6 +77,7 @@ tm_a_regression.default <- function(label = "Regression Analysis", ggtheme <- match.arg(ggtheme) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) plot_choices <- c( "Response vs Regressor", "Residuals vs Fitted", "Normal Q-Q", "Scale-Location", "Cook's distance", "Residuals vs Leverage", "Cook's dist vs Leverage" @@ -67,7 +88,9 @@ tm_a_regression.default <- function(label = "Regression Analysis", checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) checkmate::assert_choice(default_plot_type, seq.int(1L, length(plot_choices))) - checkmate::assert_string(default_outlier_label) + if (!missing(default_outlier_label)) { + warning("`default_outlier_label` is not supported when using picks. Please use `outlier` argument.") + } checkmate::assert_list(decorators, "teal_transform_module") if (length(label_segment_threshold) == 1) { @@ -86,39 +109,38 @@ tm_a_regression.default <- function(label = "Regression Analysis", # Make UI args args <- as.list(environment()) - args[["plot_choices"]] <- plot_choices - data_extract_list <- list( - regressor = regressor, - response = response - ) ans <- module( label = label, - server = srv_a_regression, - ui = ui_a_regression, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - default_outlier_label = default_outlier_label, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + server = srv_a_regression.picks, + ui = ui_a_regression.picks, + ui_args = args[names(args) %in% names(formals(ui_a_regression.picks))], + server_args = args[names(args) %in% names(formals(srv_a_regression.picks))], , transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(regressor, response)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- FALSE ans } # UI function for the regression module -ui_a_regression <- function(id, ...) { +ui_a_regression.picks <- function(id, + response, + regressor, + outlier, + plot_choices, + default_plot_type, + alpha, + size, + label_segment_threshold, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$regressor, args$response) teal.widgets::standard_layout( output = teal.widgets::white_small_well(tags$div( teal.widgets::plot_with_settings_ui(id = ns("myplot")), @@ -126,31 +148,26 @@ ui_a_regression <- function(id, ...) { )), encoding = tags$div( tags$label("Encodings", class = "text-primary"), tags$br(), - teal.transform::datanames_input(args[c("response", "regressor")]), - teal.transform::data_extract_ui( - id = ns("response"), - label = "Response variable", - data_extract_spec = args$response, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Response variable"), + teal.transform::module_input_ui(id = ns("response"), spec = response) ), - teal.transform::data_extract_ui( - id = ns("regressor"), - label = "Regressor variables", - data_extract_spec = args$regressor, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Regressor variables"), + teal.transform::module_input_ui(id = ns("regressor"), spec = regressor) ), radioButtons( ns("plot_type"), label = "Plot type:", - choices = args$plot_choices, - selected = args$plot_choices[args$default_plot_type] + choices = plot_choices, + selected = plot_choices[default_plot_type] ), - checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = TRUE), + checkboxInput(ns("show_outlier"), label = "Display outlier labels", value = FALSE), conditionalPanel( condition = "input['show_outlier']", ns = ns, teal.widgets::optionalSliderInput( - ns("outlier"), + ns("outlier_cutoff"), tags$div( tagList( "Outlier definition:", @@ -166,19 +183,15 @@ ui_a_regression <- function(id, ...) { ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.widgets::optionalSelectInput( - ns("label_var"), - multiple = FALSE, - label = "Outlier label" - ) + teal.transform::module_input_ui(id = ns("outlier"), spec = outlier) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE), teal.widgets::optionalSliderInputValMinMax( inputId = ns("label_min_segment"), label = tags$div( @@ -196,7 +209,7 @@ ui_a_regression <- function(id, ...) { ) ) ), - value_min_max = args$label_segment_threshold, + value_min_max = label_segment_threshold, # Extra parameters to sliderInput ticks = FALSE, step = .1, @@ -206,7 +219,7 @@ ui_a_regression <- function(id, ...) { inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -215,194 +228,118 @@ ui_a_regression <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the regression module -srv_a_regression <- function(id, - data, - response, - regressor, - plot_height, - plot_width, - ggplot2_args, - default_outlier_label, - decorators) { +srv_a_regression.picks <- function(id, + data, + response, + regressor, + outlier, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - ns <- session$ns - rule_rvr1 <- function(value) { - if (isTRUE(input$plot_type == "Response vs Regressor")) { - if (length(value) > 1L) { - "This plot can only have one regressor." - } - } - } - rule_rvr2 <- function(other) { - function(value) { - if (isTRUE(input$plot_type == "Response vs Regressor")) { - otherval <- selector_list()[[other]]()$select - if (isTRUE(value == otherval)) { - "Response and Regressor must be different." - } - } - } - } + selectors <- teal.transform::module_input_srv( + spec = list(response = response, regressor = regressor, outlier = outlier), + data = data + ) - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(response = response, regressor = regressor), - datasets = data, - select_validation_rule = list( - regressor = shinyvalidate::compose_rules( - shinyvalidate::sv_required("At least one regressor should be selected."), - rule_rvr1, - rule_rvr2("response") + validated_q <- reactive({ + req(data()) + validate_input( + inputId = "response-variables-selected", + condition = is.numeric( + data()[[selectors$response()$datasets$selected]][[selectors$response()$variables$selected]] ), - response = shinyvalidate::compose_rules( - shinyvalidate::sv_required("At least one response should be selected."), - rule_rvr2("regressor") - ) + message = "A response variable needs to be numeric." ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - iv_out <- shinyvalidate::InputValidator$new() - iv_out$condition(~ isTRUE(input$show_outlier)) - iv_out$add_rule("label_var", shinyvalidate::sv_required("Please provide an `Outlier label` variable")) - iv_out$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - - regression_var <- reactive({ - teal::validate_inputs(iv_r()) - - list( - response = as.vector(anl_merged_input()$columns_source$response), - regressor = as.vector(anl_merged_input()$columns_source$regressor) + validate_input( + inputId = "regressor-variables-selected", + condition = length(selectors$regressor()$variables$selected) > 0, + message = "A regressor variables need to be selected." + ) + validate_input( + inputId = c("regressor-variables-selected", "response-variables-selected"), + condition = !any(selectors$regressor()$variables$selected %in% selectors$response()$variables$selected), + message = "Response and Regressor must be different." + ) + validate_input( + inputId = c("show_outlier", "outlier-variables-selected"), + condition = !(isTRUE(input$show_outlier) && length(selectors$outlier()$variables$selected) == 0), + message = "Please provide an `Outlier label` variable" ) - }) - qenv <- reactive({ obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Linear Regression Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') # nolint: quotes + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Linear Regression Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") # sets qenv object and populates it with data merge call and fit expression fit_r <- reactive({ - ANL <- anl_merged_q()[["ANL"]] - teal::validate_has_data(ANL, 10) - - validate(need(is.numeric(ANL[regression_var()$response][[1]]), "Response variable should be numeric.")) + obj <- req(merged$data()) + anl <- obj[["anl"]] + teal::validate_has_data(anl, 10) teal::validate_has_data( - ANL[, c(regression_var()$response, regression_var()$regressor)], 10, + anl[, c(merged$merge_vars()$response, merged$merge_vars()$regressor)], 10, complete = TRUE, allow_inf = FALSE ) form <- stats::as.formula( paste( - regression_var()$response, + merged$merge_vars()$response, paste( - regression_var()$regressor, + merged$merge_vars()$regressor, collapse = " + " ), sep = " ~ " ) ) - if (input$show_outlier) { - opts <- teal.transform::variable_choices(ANL) - selected <- if (!is.null(isolate(input$label_var)) && isolate(input$label_var) %in% as.character(opts)) { - isolate(input$label_var) - } else { - if (length(opts[as.character(opts) == default_outlier_label]) == 0) { - opts[[1]] - } else { - opts[as.character(opts) == default_outlier_label] - } + anl_fit <- within(obj, form = form, { + fit <- stats::lm(form, data = anl) + for (regressor in names(fit$contrasts)) { + alts <- paste0(levels(anl[[regressor]]), collapse = "|") + names(fit$coefficients) <- gsub( + paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) + ) } - teal.widgets::updateOptionalSelectInput( - session = session, - inputId = "label_var", - choices = opts, - selected = restoreInput(ns("label_var"), selected) - ) - - data <- ggplot2::fortify(stats::lm(form, data = ANL)) - cooksd <- data$.cooksd[!is.nan(data$.cooksd)] - max_outlier <- max(ceiling(max(cooksd) / mean(cooksd)), 2) - cur_outlier <- isolate(input$outlier) - updateSliderInput( - session = session, - inputId = "outlier", - min = 1, - max = max_outlier, - value = restoreInput(ns("outlier"), if (cur_outlier < max_outlier) cur_outlier else max_outlier * .9) - ) - } - - anl_fit <- anl_merged_q() %>% - teal.code::eval_code(substitute(fit <- stats::lm(form, data = ANL), env = list(form = form))) %>% - teal.code::eval_code(quote({ - for (regressor in names(fit$contrasts)) { - alts <- paste0(levels(ANL[[regressor]]), collapse = "|") - names(fit$coefficients) <- gsub( - paste0("^(", regressor, ")(", alts, ")$"), paste0("\\1", ": ", "\\2"), names(fit$coefficients) - ) - } - })) %>% - teal.code::eval_code(quote({ - fit_summary <- summary(fit) - fit_summary - })) + fit_summary <- summary(fit) + fit_summary + }) teal.reporter::teal_card(anl_fit) <- c(teal.reporter::teal_card(anl_fit), "## Plot") anl_fit }) - label_col <- reactive({ - teal::validate_inputs(iv_out) - + outlier_label_call <- reactive({ substitute( expr = dplyr::if_else( - data$.cooksd > outliers * mean(data$.cooksd, na.rm = TRUE), - as.character(stats::na.omit(ANL)[[label_var]]), + data$.cooksd > outlier_cutoff * mean(data$.cooksd, na.rm = TRUE), + as.character(stats::na.omit(anl)[[label_var]]), "" ) %>% dplyr::if_else(is.na(.), "cooksd == NaN", .), - env = list(outliers = input$outlier, label_var = input$label_var) + env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$merge_vars()$outlier) ) }) - label_min_segment <- reactive({ - input$label_min_segment - }) - - outlier_label <- reactive({ + outlier_label_geom <- reactive({ substitute( expr = ggrepel::geom_text_repel( label = label_col, @@ -414,14 +351,14 @@ srv_a_regression <- function(id, segment.alpha = 0.5, seed = 123 ), - env = list(label_col = label_col(), label_min_segment = label_min_segment()) + env = list(label_col = outlier_label_call(), label_min_segment = input$label_min_segment) ) }) output_plot_base <- reactive({ - base_fit <- fit_r() + obj <- fit_r() teal.code::eval_code( - base_fit, + obj, quote({ class(fit$residuals) <- NULL @@ -439,12 +376,11 @@ srv_a_regression <- function(id, }) output_plot_0 <- reactive({ - fit <- fit_r()[["fit"]] - ANL <- anl_merged_q()[["ANL"]] + obj <- req(fit_r()) + fit <- obj[["fit"]] + anl <- obj[["anl"]] - stopifnot(ncol(fit$model) == 2) - - if (!is.factor(ANL[[regression_var()$regressor]])) { + if (!is.factor(anl[[merged$merge_vars()$regressor]])) { shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -452,8 +388,8 @@ srv_a_regression <- function(id, ggplot2::geom_point(size = size, alpha = alpha) + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), env = list( - regressor = regression_var()$regressor, - response = regression_var()$response, + regressor = merged$merge_vars()$regressor, + response = merged$merge_vars()$response, size = input$size, alpha = input$alpha ) @@ -461,7 +397,7 @@ srv_a_regression <- function(id, if (input$show_outlier) { plot <- substitute( expr = plot + outlier_label, - env = list(plot = plot, outlier_label = outlier_label()) + env = list(plot = plot, outlier_label = outlier_label_geom()) ) } } else { @@ -470,10 +406,13 @@ srv_a_regression <- function(id, plot <- substitute( expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + ggplot2::geom_boxplot(), - env = list(regressor = regression_var()$regressor, response = regression_var()$response) + env = list(regressor = merged$merge_vars()$regressor, response = merged$merge_vars()$response) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } } @@ -484,8 +423,8 @@ srv_a_regression <- function(id, module_plot = teal.widgets::ggplot2_args( labs = list( title = "Response vs Regressor", - x = varname_w_label(regression_var()$regressor, ANL), - y = varname_w_label(regression_var()$response, ANL) + x = varname_w_label(merged$merge_vars()$regressor, anl), + y = varname_w_label(merged$merge_vars()$response, anl) ), theme = list() ) @@ -494,7 +433,7 @@ srv_a_regression <- function(id, ) teal.code::eval_code( - fit_r(), + obj, substitute( expr = { class(fit$residuals) <- NULL @@ -509,7 +448,7 @@ srv_a_regression <- function(id, }) output_plot_1 <- reactive({ - plot_base <- output_plot_base() + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -520,7 +459,10 @@ srv_a_regression <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -538,24 +480,20 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.fitted, data$.resid) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, data$.resid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_2 <- reactive({ + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(sample = .stdresid)) + ggplot2::stat_qq(size = size, alpha = alpha) + @@ -567,10 +505,7 @@ srv_a_regression <- function(id, expr = plot + ggplot2::stat_qq( geom = ggrepel::GeomTextRepel, - label = label_col %>% - data.frame(label = .) %>% - dplyr::filter(label != "cooksd == NaN") %>% - unlist(), + label = label_col, color = "red", hjust = 0, vjust = 0, @@ -579,7 +514,7 @@ srv_a_regression <- function(id, segment.alpha = .5, seed = 123 ), - env = list(plot = plot, label_col = label_col(), label_min_segment = label_min_segment()) + env = list(plot = plot, label_col = outlier_label_call(), label_min_segment = input$label_min_segment) ) } @@ -598,23 +533,17 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_3 <- reactive({ + obj <- req(output_plot_base()) shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.fitted, sqrt(abs(.stdresid)))) + ggplot2::geom_point(size = size, alpha = alpha) + @@ -622,7 +551,10 @@ srv_a_regression <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -640,24 +572,20 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.fitted, sqrt(abs(data$.stdresid))) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_4 <- reactive({ + obj <- output_plot_base() shinyjs::hide("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(seq_along(.cooksd), .cooksd)) + ggplot2::geom_col(alpha = alpha), @@ -685,7 +613,7 @@ srv_a_regression <- function(id, angle = 90 ) + outlier_label, - env = list(plot = plot, outlier = input$outlier, outlier_label = outlier_label()) + env = list(plot = plot, outlier = input$outlier_cutoff, outlier_label = outlier_label_geom()) ) } @@ -704,23 +632,17 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = plot <- graph, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_5 <- reactive({ + obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .stdresid)) + ggplot2::geom_vline( @@ -740,7 +662,10 @@ srv_a_regression <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -758,24 +683,20 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.hat, data$.stdresid) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.stdresid) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_plot_6 <- reactive({ + obj <- output_plot_base() shinyjs::show("size") shinyjs::show("alpha") - plot_base <- output_plot_base() plot <- substitute( expr = ggplot2::ggplot(data = data, ggplot2::aes(.hat, .cooksd)) + ggplot2::geom_vline(xintercept = 0, colour = NA) + @@ -790,7 +711,10 @@ srv_a_regression <- function(id, env = list(size = input$size, alpha = input$alpha) ) if (input$show_outlier) { - plot <- substitute(expr = plot + outlier_label, env = list(plot = plot, outlier_label = outlier_label())) + plot <- substitute( + expr = plot + outlier_label, + env = list(plot = plot, outlier_label = outlier_label_geom()) + ) } parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( @@ -808,30 +732,34 @@ srv_a_regression <- function(id, ggtheme = input$ggtheme ) - teal.code::eval_code( - plot_base, - substitute( - expr = { - smoothy <- smooth(data$.hat, data$.cooksd) - plot <- graph - }, - env = list( - graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) - ) - ) + within( + obj, + expr = { + smoothy <- smooth(data$.hat, data$.cooksd) + plot <- graph + }, + graph = Reduce(function(x, y) call("+", x, y), c(plot, parsed_ggplot2_args)) ) }) output_q <- reactive({ - teal::validate_inputs(iv_r()) + req(input$plot_type) + validate_input( + inputId = c("plot_type", "regressor-variables-selected"), + condition = !( + identical(input$plot_type, "Response vs Regressor") && length(selectors$regressor()$variables$selected) > 1 + ), + message = "This plot works only with single Regressor variable" + ) + switch(input$plot_type, - "Response vs Regressor" = output_plot_0(), - "Residuals vs Fitted" = output_plot_1(), - "Normal Q-Q" = output_plot_2(), - "Scale-Location" = output_plot_3(), - "Cook's distance" = output_plot_4(), - "Residuals vs Leverage" = output_plot_5(), - "Cook's dist vs Leverage" = output_plot_6() + "Response vs Regressor" = req(output_plot_0()), + "Residuals vs Fitted" = req(output_plot_1()), + "Normal Q-Q" = req(output_plot_2()), + "Scale-Location" = req(output_plot_3()), + "Cook's distance" = req(output_plot_4()), + "Residuals vs Leverage" = req(output_plot_5()), + "Cook's dist vs Leverage" = req(output_plot_6()) ) }) @@ -862,8 +790,6 @@ srv_a_regression <- function(id, decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) output$text <- renderText({ - req(iv_r()$is_valid()) - req(iv_out$is_valid()) paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") }) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 0b91b4784..3d927fcb3 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -163,49 +163,37 @@ tm_g_association <- function(label = "Association", } #' @export -tm_g_association.picks <- function(label = "Association", - ref = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 - ), - values() - ), - vars = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2, - multiple = TRUE - ) - ), - show_association = TRUE, - plot_height = c(600, 400, 5000), - plot_width = NULL, - distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. - association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. - pre_output = NULL, - post_output = NULL, - ggplot2_args = teal.widgets::ggplot2_args(), - transformators = list(), - decorators = list()) { +tm_g_association.default <- function(label = "Association", + ref, + vars, + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_association") # Normalize the parameters + if (inherits(ref, "data_extract_spec")) ref <- list(ref) + if (inherits(vars, "data_extract_spec")) vars <- list(vars) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(ref, "picks") - if (isTRUE(attr(ref$variables, "multiple"))) { - warning("`ref` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(ref$variables, "multiple") <- FALSE + + checkmate::assert_list(ref, types = "data_extract_spec") + if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) { + stop("'ref' should not allow multiple selection") } - checkmate::assert_class(vars, "picks") + + checkmate::assert_list(vars, types = "data_extract_spec") checkmate::assert_flag(show_association) + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) @@ -227,34 +215,35 @@ tm_g_association.picks <- function(label = "Association", assert_decorators(decorators, "plot") # End of assertions + # Make UI args args <- as.list(environment()) + + data_extract_list <- list( + ref = ref, + vars = vars + ) + ans <- module( label = label, - ui = ui_g_association.picks, - server = srv_g_association.picks, - ui_args = args[names(args) %in% names(formals(ui_g_association.picks))], - server_args = args[names(args) %in% names(formals(srv_g_association.picks))], + server = srv_tm_g_association.default, + ui = ui_tm_g_association.default, + ui_args = args, + server_args = c( + data_extract_list, + list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(ref = ref, vars = vars)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the association module -ui_g_association.picks <- function(id, - ref, - vars, - show_association, - distribution_theme, - association_theme, - pre_output, - post_output, - decorators) { +ui_tm_g_association.default <- function(id, ...) { ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -264,18 +253,35 @@ ui_g_association.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Reference variable"), - teal.transform::module_input_ui(id = ns("ref"), spec = ref) + teal.transform::datanames_input(args[c("ref", "vars")]), + teal.transform::data_extract_ui( + id = ns("ref"), + label = "Reference variable", + data_extract_spec = args$ref, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("vars"), + label = "Associated variables", + data_extract_spec = args$vars, + is_single_dataset = is_single_dataset_value ), - teal::teal_nav_item( - label = tags$strong("Associated variables"), - teal.transform::module_input_ui(id = ns("vars"), spec = vars) + checkboxInput( + ns("association"), + "Association with reference variable", + value = args$show_association ), - checkboxInput(ns("association"), "Association with reference variable", value = show_association), - checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), - checkboxInput(ns("log_transformation"), "Log transformed", value = FALSE), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + checkboxInput( + ns("show_dist"), + "Scaled frequencies", + value = FALSE + ), + checkboxInput( + ns("log_transformation"), + "Log transformed", + value = FALSE + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -288,14 +294,14 @@ ui_g_association.picks <- function(id, inputId = ns("distribution_theme"), label = "Distribution theme (by ggplot):", choices = ggplot_themes, - selected = distribution_theme, + selected = args$distribution_theme, multiple = FALSE ), selectInput( inputId = ns("association_theme"), label = "Association theme (by ggplot):", choices = ggplot_themes, - selected = association_theme, + selected = args$association_theme, multiple = FALSE ) ) @@ -304,65 +310,84 @@ ui_g_association.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the association module -srv_g_association.picks <- function(id, - data, - ref, - vars, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_tm_g_association.default <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) - - validated_q <- reactive({ - obj <- req(data()) - validate_input( - inputId = "ref-variables-selected", - condition = !is.null(selectors$ref()$variables$selected), - message = "A reference variable must be selected." - ) - validate_input( - inputId = "vars-variables-selected", - condition = !is.null(selectors$vars()$variables$selected), - message = "A associated variables must be selected." - ) - validate_input( - inputId = c("ref-variables-selected", "vars-variables-selected"), - condition = !any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected), - message = "Associated variables and reference variable cannot overlap" + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(ref = ref, vars = vars), + datasets = data, + select_validation_rule = list( + ref = shinyvalidate::compose_rules( + shinyvalidate::sv_required("A reference variable needs to be selected."), + ~ if ((.) %in% selector_list()$vars()$select) { + "Associated variables and reference variable cannot overlap" + } + ), + vars = shinyvalidate::compose_rules( + shinyvalidate::sv_required("An associated variable needs to be selected."), + ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) { + "Associated variables and reference variable cannot overlap" + } + ) ) + ) + + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list + ) + + qenv <- reactive({ + obj <- data() teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Association Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("ggmosaic")') # nolint: quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) output_q <- reactive({ - req(merged$data()) - logger::log_debug("srv_g_association@1 recalculating a plot") - anl <- merged$data()[["anl"]] - ref_name <- merged$merge_vars()$ref - vars_names <- merged$merge_vars()$vars - teal::validate_has_data(anl, 3) - teal::validate_has_data(anl[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) + teal::validate_inputs(iv_r()) + + ANL <- merged$anl_q_r()[["ANL"]] + teal::validate_has_data(ANL, 3) + + vars_names <- merged$anl_input_r()$columns_source$vars + ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) association <- input$association show_dist <- input$show_dist log_transformation <- input$log_transformation @@ -371,7 +396,7 @@ srv_g_association.picks <- function(id, distribution_theme <- input$distribution_theme association_theme <- input$association_theme - is_scatterplot <- is.numeric(anl[[ref_name]]) && any(vapply(anl[vars_names], is.numeric, logical(1))) + is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) if (is_scatterplot) { shinyjs::show("alpha") shinyjs::show("size") @@ -384,17 +409,19 @@ srv_g_association.picks <- function(id, size <- 2 } + teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) + # reference - ref_class <- class(anl[[ref_name]])[1] - if (is.numeric(anl[[ref_name]]) && log_transformation) { + ref_class <- class(ANL[[ref_name]])[1] + if (is.numeric(ANL[[ref_name]]) && log_transformation) { # works for both integers and doubles ref_cl_name <- call("log", as.name(ref_name)) - ref_cl_lbl <- varname_w_label(ref_name, anl, prefix = "Log of ") + ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not ref_cl_name <- as.name(ref_name) - ref_cl_lbl <- varname_w_label(ref_name, anl) + ref_cl_lbl <- varname_w_label(ref_name, ANL) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -403,7 +430,7 @@ srv_g_association.picks <- function(id, ) ref_call <- bivariate_plot_call( - data_name = "anl", + data_name = "ANL", x = ref_cl_name, x_class = ref_class, x_label = ref_cl_lbl, @@ -420,15 +447,16 @@ srv_g_association.picks <- function(id, ref_class_cov <- ifelse(association, ref_class, "NULL") var_calls <- lapply(vars_names, function(var_i) { - if (is.numeric(anl[[var_i]]) && log_transformation) { + var_class <- class(ANL[[var_i]])[1] + if (is.numeric(ANL[[var_i]]) && log_transformation) { # works for both integers and doubles var_cl_name <- call("log", as.name(var_i)) - var_cl_lbl <- varname_w_label(var_i, anl, prefix = "Log of ") + var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not var_cl_name <- as.name(var_i) - var_cl_lbl <- varname_w_label(var_i, anl) + var_cl_lbl <- varname_w_label(var_i, ANL) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -437,11 +465,11 @@ srv_g_association.picks <- function(id, ) bivariate_plot_call( - data_name = "anl", + data_name = "ANL", x = ref_cl_name, y = var_cl_name, x_class = ref_class_cov, - y_class = class(anl[[var_i]])[1], + y_class = var_class, x_label = ref_cl_lbl, y_label = var_cl_lbl, theme = association_theme, @@ -456,10 +484,10 @@ srv_g_association.picks <- function(id, # helper function to format variable name format_varnames <- function(x) { - if (is.numeric(anl[[x]]) && log_transformation) { - varname_w_label(x, anl, prefix = "Log of ") + if (is.numeric(ANL[[x]]) && log_transformation) { + varname_w_label(x, ANL, prefix = "Log of ") } else { - varname_w_label(x, anl) + varname_w_label(x, ANL) } } new_title <- @@ -487,21 +515,30 @@ srv_g_association.picks <- function(id, ) ) } - obj <- merged$data() - + obj <- merged$anl_q_r() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") - within( + teal.code::eval_code( obj, - expr = { - title <- new_title - ref_plot <- plot1 - var_plot <- plot2 - plot <- gridExtra::arrangeGrob(ref_plot, var_plot, ncol = 1) - }, - new_title = new_title, - plot1 = ref_call, - plot2 = var_calls[[1]] - ) + substitute( + expr = title <- new_title, + env = list(new_title = new_title) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = { + plots <- plot_calls + plot <- gridExtra::arrangeGrob(plots[[1]], plots[[2]], ncol = 1) + }, + env = list( + plot_calls = do.call( + "call", + c(list("list", ref_call), var_calls), + quote = TRUE + ) + ) + ) + ) }) decorated_output_grob_q <- srv_decorate_teal_data( @@ -515,6 +552,7 @@ srv_g_association.picks <- function(id, ) plot_r <- reactive({ + req(iv_r()$is_valid()) req(decorated_output_grob_q())[["plot"]] }) diff --git a/R/tm_g_association_old.R b/R/tm_g_association_picks.R similarity index 55% rename from R/tm_g_association_old.R rename to R/tm_g_association_picks.R index 4117a829e..999306c29 100644 --- a/R/tm_g_association_old.R +++ b/R/tm_g_association_picks.R @@ -1,35 +1,47 @@ #' @export -tm_g_association.default <- function(label = "Association", - ref, - vars, - show_association = TRUE, - plot_height = c(600, 400, 5000), - plot_width = NULL, - distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. - association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. - pre_output = NULL, - post_output = NULL, - ggplot2_args = teal.widgets::ggplot2_args(), - transformators = list(), - decorators = list()) { +tm_g_association.picks <- function(label = "Association", + ref = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ), + values() + ), + vars = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2, + multiple = TRUE + ) + ), + show_association = TRUE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + distribution_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + association_theme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), # nolint: line_length. + pre_output = NULL, + post_output = NULL, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_association") # Normalize the parameters - if (inherits(ref, "data_extract_spec")) ref <- list(ref) - if (inherits(vars, "data_extract_spec")) vars <- list(vars) if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) # Start of assertions checkmate::assert_string(label) - - checkmate::assert_list(ref, types = "data_extract_spec") - if (!all(vapply(ref, function(x) !x$select$multiple, logical(1)))) { - stop("'ref' should not allow multiple selection") + checkmate::assert_class(ref, "picks") + if (isTRUE(attr(ref$variables, "multiple"))) { + warning("`ref` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(ref$variables, "multiple") <- FALSE } - - checkmate::assert_list(vars, types = "data_extract_spec") + checkmate::assert_class(vars, "picks") checkmate::assert_flag(show_association) - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) @@ -51,35 +63,34 @@ tm_g_association.default <- function(label = "Association", assert_decorators(decorators, "plot") # End of assertions - # Make UI args args <- as.list(environment()) - - data_extract_list <- list( - ref = ref, - vars = vars - ) - ans <- module( label = label, - server = srv_tm_g_association.default, - ui = ui_tm_g_association.default, - ui_args = args, - server_args = c( - data_extract_list, - list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) - ), + ui = ui_g_association.picks, + server = srv_g_association.picks, + ui_args = args[names(args) %in% names(formals(ui_g_association.picks))], + server_args = args[names(args) %in% names(formals(srv_g_association.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(ref = ref, vars = vars)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the association module -ui_tm_g_association.default <- function(id, ...) { +ui_g_association.picks <- function(id, + ref, + vars, + show_association, + distribution_theme, + association_theme, + pre_output, + post_output, + decorators) { ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$ref, args$vars) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -89,35 +100,18 @@ ui_tm_g_association.default <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("ref", "vars")]), - teal.transform::data_extract_ui( - id = ns("ref"), - label = "Reference variable", - data_extract_spec = args$ref, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("vars"), - label = "Associated variables", - data_extract_spec = args$vars, - is_single_dataset = is_single_dataset_value + teal::teal_nav_item( + label = tags$strong("Reference variable"), + teal.transform::module_input_ui(id = ns("ref"), spec = ref) ), - checkboxInput( - ns("association"), - "Association with reference variable", - value = args$show_association + teal::teal_nav_item( + label = tags$strong("Associated variables"), + teal.transform::module_input_ui(id = ns("vars"), spec = vars) ), - checkboxInput( - ns("show_dist"), - "Scaled frequencies", - value = FALSE - ), - checkboxInput( - ns("log_transformation"), - "Log transformed", - value = FALSE - ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + checkboxInput(ns("association"), "Association with reference variable", value = show_association), + checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), + checkboxInput(ns("log_transformation"), "Log transformed", value = FALSE), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -130,14 +124,14 @@ ui_tm_g_association.default <- function(id, ...) { inputId = ns("distribution_theme"), label = "Distribution theme (by ggplot):", choices = ggplot_themes, - selected = args$distribution_theme, + selected = distribution_theme, multiple = FALSE ), selectInput( inputId = ns("association_theme"), label = "Association theme (by ggplot):", choices = ggplot_themes, - selected = args$association_theme, + selected = association_theme, multiple = FALSE ) ) @@ -146,84 +140,65 @@ ui_tm_g_association.default <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the association module -srv_tm_g_association.default <- function(id, - data, - ref, - vars, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_association.picks <- function(id, + data, + ref, + vars, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(ref = ref, vars = vars), - datasets = data, - select_validation_rule = list( - ref = shinyvalidate::compose_rules( - shinyvalidate::sv_required("A reference variable needs to be selected."), - ~ if ((.) %in% selector_list()$vars()$select) { - "Associated variables and reference variable cannot overlap" - } - ), - vars = shinyvalidate::compose_rules( - shinyvalidate::sv_required("An associated variable needs to be selected."), - ~ if (length(selector_list()$ref()$select) != 0 && selector_list()$ref()$select %in% (.)) { - "Associated variables and reference variable cannot overlap" - } - ) - ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) + selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list - ) - - qenv <- reactive({ - obj <- data() + validated_q <- reactive({ + obj <- req(data()) + validate_input( + inputId = "ref-variables-selected", + condition = !is.null(selectors$ref()$variables$selected), + message = "A reference variable must be selected." + ) + validate_input( + inputId = "vars-variables-selected", + condition = !is.null(selectors$vars()$variables$selected), + message = "A associated variables must be selected." + ) + validate_input( + inputId = c("ref-variables-selected", "vars-variables-selected"), + condition = !any(selectors$ref()$variables$selected %in% selectors$vars()$variables$selected), + message = "Associated variables and reference variable cannot overlap" + ) teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Association Plot"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("ggmosaic")') # nolint: quotes - }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% teal.code::eval_code(as.expression(anl_merged_input()$expr)) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") output_q <- reactive({ - teal::validate_inputs(iv_r()) - - ANL <- merged$anl_q_r()[["ANL"]] - teal::validate_has_data(ANL, 3) - - vars_names <- merged$anl_input_r()$columns_source$vars + req(merged$data()) + logger::log_debug("srv_g_association@1 recalculating a plot") + anl <- merged$data()[["anl"]] + ref_name <- merged$merge_vars()$ref + vars_names <- merged$merge_vars()$vars + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) - ref_name <- as.vector(merged$anl_input_r()$columns_source$ref) association <- input$association show_dist <- input$show_dist log_transformation <- input$log_transformation @@ -232,7 +207,7 @@ srv_tm_g_association.default <- function(id, distribution_theme <- input$distribution_theme association_theme <- input$association_theme - is_scatterplot <- is.numeric(ANL[[ref_name]]) && any(vapply(ANL[vars_names], is.numeric, logical(1))) + is_scatterplot <- is.numeric(anl[[ref_name]]) && any(vapply(anl[vars_names], is.numeric, logical(1))) if (is_scatterplot) { shinyjs::show("alpha") shinyjs::show("size") @@ -245,19 +220,17 @@ srv_tm_g_association.default <- function(id, size <- 2 } - teal::validate_has_data(ANL[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) - # reference - ref_class <- class(ANL[[ref_name]])[1] - if (is.numeric(ANL[[ref_name]]) && log_transformation) { + ref_class <- class(anl[[ref_name]])[1] + if (is.numeric(anl[[ref_name]]) && log_transformation) { # works for both integers and doubles ref_cl_name <- call("log", as.name(ref_name)) - ref_cl_lbl <- varname_w_label(ref_name, ANL, prefix = "Log of ") + ref_cl_lbl <- varname_w_label(ref_name, anl, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not ref_cl_name <- as.name(ref_name) - ref_cl_lbl <- varname_w_label(ref_name, ANL) + ref_cl_lbl <- varname_w_label(ref_name, anl) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -266,7 +239,7 @@ srv_tm_g_association.default <- function(id, ) ref_call <- bivariate_plot_call( - data_name = "ANL", + data_name = "anl", x = ref_cl_name, x_class = ref_class, x_label = ref_cl_lbl, @@ -283,16 +256,15 @@ srv_tm_g_association.default <- function(id, ref_class_cov <- ifelse(association, ref_class, "NULL") var_calls <- lapply(vars_names, function(var_i) { - var_class <- class(ANL[[var_i]])[1] - if (is.numeric(ANL[[var_i]]) && log_transformation) { + if (is.numeric(anl[[var_i]]) && log_transformation) { # works for both integers and doubles var_cl_name <- call("log", as.name(var_i)) - var_cl_lbl <- varname_w_label(var_i, ANL, prefix = "Log of ") + var_cl_lbl <- varname_w_label(var_i, anl, prefix = "Log of ") } else { # silently ignore when non-numeric even if `log` is selected because some # variables may be numeric and others not var_cl_name <- as.name(var_i) - var_cl_lbl <- varname_w_label(var_i, ANL) + var_cl_lbl <- varname_w_label(var_i, anl) } user_ggplot2_args <- teal.widgets::resolve_ggplot2_args( @@ -301,11 +273,11 @@ srv_tm_g_association.default <- function(id, ) bivariate_plot_call( - data_name = "ANL", + data_name = "anl", x = ref_cl_name, y = var_cl_name, x_class = ref_class_cov, - y_class = var_class, + y_class = class(anl[[var_i]])[1], x_label = ref_cl_lbl, y_label = var_cl_lbl, theme = association_theme, @@ -320,10 +292,10 @@ srv_tm_g_association.default <- function(id, # helper function to format variable name format_varnames <- function(x) { - if (is.numeric(ANL[[x]]) && log_transformation) { - varname_w_label(x, ANL, prefix = "Log of ") + if (is.numeric(anl[[x]]) && log_transformation) { + varname_w_label(x, anl, prefix = "Log of ") } else { - varname_w_label(x, ANL) + varname_w_label(x, anl) } } new_title <- @@ -351,30 +323,21 @@ srv_tm_g_association.default <- function(id, ) ) } - obj <- merged$anl_q_r() + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") - teal.code::eval_code( + within( obj, - substitute( - expr = title <- new_title, - env = list(new_title = new_title) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = { - plots <- plot_calls - plot <- gridExtra::arrangeGrob(plots[[1]], plots[[2]], ncol = 1) - }, - env = list( - plot_calls = do.call( - "call", - c(list("list", ref_call), var_calls), - quote = TRUE - ) - ) - ) - ) + expr = { + title <- new_title + ref_plot <- plot1 + var_plot <- plot2 + plot <- gridExtra::arrangeGrob(ref_plot, var_plot, ncol = 1) + }, + new_title = new_title, + plot1 = ref_call, + plot2 = var_calls[[1]] + ) }) decorated_output_grob_q <- srv_decorate_teal_data( @@ -388,7 +351,6 @@ srv_tm_g_association.default <- function(id, ) plot_r <- reactive({ - req(iv_r()$is_valid()) req(decorated_output_grob_q())[["plot"]] }) diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 7343681e3..b2a074ddc 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -189,63 +189,66 @@ tm_g_bivariate <- function(label = "Bivariate Plots", } #' @export -tm_g_bivariate.picks <- function(label = "Bivariate Plots", - x = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 - ), - values(selected = tidyselect::everything(), multiple = TRUE) - ), - y = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2 - ), - values(selected = tidyselect::everything(), multiple = TRUE) - ), - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), - color = NULL, - fill = NULL, - size = NULL, - use_density = FALSE, - color_settings = FALSE, - free_x_scales = FALSE, - free_y_scales = FALSE, - plot_height = c(600, 200, 2000), - plot_width = NULL, - rotate_xaxis_labels = FALSE, - swap_axes = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_g_bivariate.default <- function(label = "Bivariate Plots", + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_bivariate") + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + if (inherits(color, "data_extract_spec")) color <- list(color) + if (inherits(fill, "data_extract_spec")) fill <- list(fill) + if (inherits(size, "data_extract_spec")) size <- list(size) + # Start of assertions - checkmate::assert_class(x, "picks") - checkmate::assert_class(y, "picks") - if (isTRUE(attr(x$variables, "multiple"))) { - warning("`x`-axis doesn't accept multiple variables. Changing automatically.") - attr(x$variables, "multiple") <- FALSE - } - if (isTRUE(attr(y$variables, "multiple"))) { - warning("`y`-axis doesn't accept multiple variables. Changing automatically.") - attr(x$variables, "multiple") <- FALSE - } - checkmate::assert_class(col_facet, "picks", null.ok = TRUE) - checkmate::assert_class(row_facet, "picks", null.ok = TRUE) - checkmate::assert_class(color, "picks", null.ok = TRUE) - checkmate::assert_class(size, "picks", null.ok = TRUE) checkmate::assert_string(label) + + checkmate::assert_list(x, types = "data_extract_spec") + assert_single_selection(x) + + checkmate::assert_list(y, types = "data_extract_spec") + assert_single_selection(y) + + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(row_facet) + + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(col_facet) + + checkmate::assert_flag(facet) + + checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(color) + + checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(fill) + + checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(size) + checkmate::assert_flag(use_density) # Determines color, fill & size if they are not explicitly set @@ -253,15 +256,15 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", if (color_settings) { if (is.null(color)) { color <- x - color$selected <- NULL + color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) } if (is.null(fill)) { fill <- x - fill$selected <- NULL + fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) } if (is.null(size)) { size <- x - size$selected <- NULL + size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) } } else { if (!is.null(c(color, fill, size))) { @@ -295,228 +298,310 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", # Make UI args args <- as.list(environment()) + data_extract_list <- list( + x = x, + y = y, + row_facet = row_facet, + col_facet = col_facet, + color_settings = color_settings, + color = color, + fill = fill, + size = size + ) + ans <- module( label = label, - server = srv_g_bivariate.picks, - ui = ui_g_bivariate.picks, - ui_args = args[names(args) %in% names(formals(ui_g_bivariate.picks))], - server_args = args[names(args) %in% names(formals(srv_g_bivariate.picks))], + server = srv_g_bivariate.default, + ui = ui_g_bivariate.default, + ui_args = args, + server_args = c( + data_extract_list, + list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) + ), transformators = transformators, - datanames = { - datanames <- teal.transform::datanames(list(x, y, row_facet, col_facet, color, fill, size)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the bivariate module -ui_g_bivariate.picks <- function(id, - x, - y, - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), - color = NULL, - fill = NULL, - size = NULL, - use_density = FALSE, - color_settings = FALSE, - free_x_scales = FALSE, - free_y_scales = FALSE, - rotate_xaxis_labels = FALSE, - swap_axes = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - decorators = list()) { +ui_g_bivariate.default <- function(id, ...) { + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset( + args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size + ) + ns <- NS(id) - teal::standard_layout2( - output = bslib::card( - teal.widgets::plot_with_settings_ui(id = ns("myplot")), - full_screen = TRUE + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot"))) ), - encoding = shiny::tagList( - teal::teal_nav_item( - label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x) + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]), + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value ), - teal::teal_nav_item( - label = tags$strong("Y variable"), - teal.transform::module_input_ui(id = ns("y"), spec = y) + teal.transform::data_extract_ui( + id = ns("y"), + label = "Y variable", + data_extract_spec = args$y, + is_single_dataset = is_single_dataset_value ), conditionalPanel( condition = "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || - $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", - teal::teal_nav_item( + $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", + shinyWidgets::radioGroupButtons( + inputId = ns("use_density"), label = NULL, - shinyWidgets::radioGroupButtons( - inputId = ns("use_density"), - label = NULL, - choices = c("frequency", "density"), - selected = ifelse(use_density, "density", "frequency"), - justified = TRUE - ) + choices = c("frequency", "density"), + selected = ifelse(args$use_density, "density", "frequency"), + justified = TRUE ) ), - if (!is.null(row_facet)) { - teal::teal_nav_item( - tags$div( - tags$strong("Row facetting variable"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet), - checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) - ) - ) - }, - if (!is.null(col_facet)) { - teal::teal_nav_item( - tags$div( - tags$strong("Column facetting variable"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet), - checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + if (!is.null(args$row_facet) || !is.null(args$col_facet)) { + tags$div( + class = "data-extract-box", + tags$br(), + bslib::input_switch( + id = ns("facetting"), + label = "Facetting", + value = args$facet + ), + conditionalPanel( + condition = paste0("input['", ns("facetting"), "']"), + tags$div( + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting variable", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value + ) + }, + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting variable", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value + ) + }, + checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales), + checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales) + ) ) ) }, - if (color_settings) { + if (args$color_settings) { # Put a grey border around the coloring settings - teal::teal_nav_item( - label = tags$strong("Color settings"), - tags$div( - bslib::input_switch(id = ns("coloring"), label = "Color settings", value = TRUE), - conditionalPanel( - condition = paste0("input['", ns("coloring"), "']"), + tags$div( + class = "data-extract-box", + tags$label("Color settings"), + bslib::input_switch( + id = ns("coloring"), + label = "Color settings", + value = TRUE + ), + conditionalPanel( + condition = paste0("input['", ns("coloring"), "']"), + tags$div( + teal.transform::data_extract_ui( + id = ns("color"), + label = "Outline color by variable", + data_extract_spec = args$color, + is_single_dataset = is_single_dataset_value + ), + teal.transform::data_extract_ui( + id = ns("fill"), + label = "Fill color by variable", + data_extract_spec = args$fill, + is_single_dataset = is_single_dataset_value + ), tags$div( - teal.transform::module_input_ui(id = ns("color"), spec = color), # label = "Outline color by variable" - teal.transform::module_input_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" - tags$div( - id = ns("size_settings"), - teal.transform::module_input_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" + id = ns("size_settings"), + teal.transform::data_extract_ui( + id = ns("size"), + label = "Size of points by variable (only if x and y are numeric)", + data_extract_spec = args$size, + is_single_dataset = is_single_dataset_value ) ) ) ) ) }, - teal::teal_nav_item( - label = NULL, - teal:::.teal_navbar_menu( - id = ns("plot_settings"), - label = "Plot settings", - icon = "gear", - tags$div( - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), - checkboxInput(ns("swap_axes"), "Swap axes", value = swap_axes), - selectInput( - inputId = ns("ggtheme"), - label = "Theme (by ggplot):", - choices = ggplot_themes, - selected = ggtheme, - multiple = FALSE - ), - sliderInput( - ns("alpha"), "Opacity Scatterplot:", - min = 0, max = 1, - step = .05, value = .5, ticks = FALSE - ), - sliderInput( - ns("fixed_size"), "Scatterplot point size:", - min = 1, max = 8, - step = 1, value = 2, ticks = FALSE - ), - checkboxInput(ns("add_lines"), "Add lines") - ) + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = args$ggtheme, + multiple = FALSE + ), + sliderInput( + ns("alpha"), "Opacity Scatterplot:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("fixed_size"), "Scatterplot point size:", + min = 1, max = 8, + step = 1, value = 2, ticks = FALSE + ), + checkboxInput(ns("add_lines"), "Add lines"), ) - ), - teal::teal_nav_item( - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) ) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the bivariate module -srv_g_bivariate.picks <- function(id, - data, - x, - y, - row_facet, - col_facet, - color_settings = FALSE, - color, - fill, - size, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_bivariate.default <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - selectors <- teal.transform::module_input_srv( - spec = list( - x = x, - y = y, - row_facet = row_facet, - col_facet = col_facet, - color = color, - fill = fill, - size = size - ), - data = data + + data_extract <- list( + x = x, y = y, row_facet = row_facet, col_facet = col_facet, + color = color, fill = fill, size = size ) - validated_q <- reactive({ - validate_input( - inputId = c("x-variables-selected", "y-variables-selected"), - condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), - message = "Please select at least one of x-variable or y-variable" - ) - if (!is.null(col_facet) && !is.null(row_facet)) { - validate_input( - inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), - condition = is.null(selectors$row_facet()$variables$selected) || - is.null(selectors$col_facet()$variables$selected) || - !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), - message = "Row and column facetting variables must be different." - ) + rule_var <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()$select + if (length(value) == 0L && length(othervalue) == 0L) { + "Please select at least one of x-variable or y-variable" + } } + } + rule_diff <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } - obj <- req(data()) - teal.reporter::teal_card(obj) <- c( - teal.reporter::teal_card("# Bivariate Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + x = rule_var("y"), + y = rule_var("x"), + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("row_facet") + ) ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + ) + + iv_r <- reactive({ + iv_facet <- shinyvalidate::InputValidator$new() + iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, + validator_names = c("row_facet", "col_facet") + ) + iv_child$condition(~ isTRUE(input$facetting)) + + iv <- shinyvalidate::InputValidator$new() + iv$add_validator(iv_child) + teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y")) }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) - output_q <- reactive(label = "make bivariateplot", { - req(merged$data()) - logger::log_debug("Plotting bivariate") - anl <- merged$data()[["anl"]] - teal::validate_has_data(anl, 3) + anl_merged_q <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Bivariate Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + obj %>% + teal.code::eval_code( + c( + 'library("ggplot2");library("dplyr")', # nolint: quotes + as.expression(anl_merged_input()$expr) + ) + ) + }) + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) - x_name <- merged$merge_vars()$x - y_name <- merged$merge_vars()$y - row_facet_name <- merged$merge_vars()$row_facet - col_facet_name <- merged$merge_vars()$col_facet - color_name <- merged$merge_vars()$color - fill_name <- merged$merge_vars()$fill - size_name <- merged$merge_vars()$size + output_q <- reactive({ + teal::validate_inputs(iv_r()) + + ANL <- merged$anl_q_r()[["ANL"]] + teal::validate_has_data(ANL, 3) + + x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) + x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) + y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) + y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) + + row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) + col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) + color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$color) + } else { + character(0) + } + fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$fill) + } else { + character(0) + } + size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) { + as.vector(merged$anl_input_r()$columns_source$size) + } else { + character(0) + } use_density <- input$use_density == "density" free_x_scales <- input$free_x_scales @@ -525,22 +610,7 @@ srv_g_bivariate.picks <- function(id, rotate_xaxis_labels <- input$rotate_xaxis_labels swap_axes <- input$swap_axes - - supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") - x_class <- class(anl[[x_name]])[1] - validate_input( - "x-variables-selected", - condition = x_class %in% supported_types, - message = paste0("Data type '", x_class, "' is not supported.") - ) - y_class <- class(anl[[y_name]])[[1]] - validate_input( - "x-variables-selected", - condition = y_class %in% supported_types, - message = paste0("Data type '", y_class, "' is not supported.") - ) - - is_scatterplot <- all(vapply(anl[c(x_name, y_name)], is.numeric, logical(1))) && + is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && length(x_name) > 0 && length(y_name) > 0 if (is_scatterplot) { @@ -566,18 +636,16 @@ srv_g_bivariate.picks <- function(id, size <- NULL } - teal::validate_has_data(anl[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) - - + teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) cl <- bivariate_plot_call( - data_name = "anl", + data_name = "ANL", x = x_name, y = y_name, - x_class = ifelse(length(x_name), class(anl[[x_name]]), "NULL"), - y_class = ifelse(length(y_name), class(anl[[y_name]]), "NULL"), - x_label = varname_w_label(x_name, anl), - y_label = varname_w_label(y_name, anl), + x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), + y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, ANL), + y_label = varname_w_label(y_name, ANL), freq = !use_density, theme = ggtheme, rotate_xaxis_labels = rotate_xaxis_labels, @@ -587,7 +655,9 @@ srv_g_bivariate.picks <- function(id, ggplot2_args = ggplot2_args ) - if (!is.null(row_facet_name) || !is.null(col_facet_name)) { + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + + if (facetting) { facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) if (!is.null(facet_cl)) { @@ -622,7 +692,7 @@ srv_g_bivariate.picks <- function(id, } } - obj <- merged$data() + obj <- merged$anl_q_r() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) }) @@ -632,13 +702,13 @@ srv_g_bivariate.picks <- function(id, data = output_q, decorators = select_decorators(decorators, "plot"), expr = reactive({ - anl <- merged$data()[["anl"]] - row_facet_name <- merged$merge_vars()$row_facet - col_facet_name <- merged$merge_vars()$col_facet + ANL <- merged$anl_q_r()[["ANL"]] + row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) + col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) # Add labels to facets - nulled_row_facet_name <- varname_w_label(row_facet_name, anl) - nulled_col_facet_name <- varname_w_label(col_facet_name, anl) + nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) + nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting diff --git a/R/tm_g_bivariate_old.R b/R/tm_g_bivariate_old.R deleted file mode 100644 index ae764fd0f..000000000 --- a/R/tm_g_bivariate_old.R +++ /dev/null @@ -1,565 +0,0 @@ -#' @export -tm_g_bivariate.default <- function(label = "Bivariate Plots", - x, - y, - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), - color = NULL, - fill = NULL, - size = NULL, - use_density = FALSE, - color_settings = FALSE, - free_x_scales = FALSE, - free_y_scales = FALSE, - plot_height = c(600, 200, 2000), - plot_width = NULL, - rotate_xaxis_labels = FALSE, - swap_axes = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { - message("Initializing tm_g_bivariate") - - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) - if (inherits(color, "data_extract_spec")) color <- list(color) - if (inherits(fill, "data_extract_spec")) fill <- list(fill) - if (inherits(size, "data_extract_spec")) size <- list(size) - - # Start of assertions - checkmate::assert_string(label) - - checkmate::assert_list(x, types = "data_extract_spec") - assert_single_selection(x) - - checkmate::assert_list(y, types = "data_extract_spec") - assert_single_selection(y) - - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(row_facet) - - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(col_facet) - - checkmate::assert_flag(facet) - - checkmate::assert_list(color, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(color) - - checkmate::assert_list(fill, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(fill) - - checkmate::assert_list(size, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(size) - - checkmate::assert_flag(use_density) - - # Determines color, fill & size if they are not explicitly set - checkmate::assert_flag(color_settings) - if (color_settings) { - if (is.null(color)) { - color <- x - color[[1]]$select <- teal.transform::select_spec(choices = color[[1]]$select$choices, selected = NULL) - } - if (is.null(fill)) { - fill <- x - fill[[1]]$select <- teal.transform::select_spec(choices = fill[[1]]$select$choices, selected = NULL) - } - if (is.null(size)) { - size <- x - size[[1]]$select <- teal.transform::select_spec(choices = size[[1]]$select$choices, selected = NULL) - } - } else { - if (!is.null(c(color, fill, size))) { - stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.") - } - } - - checkmate::assert_flag(free_x_scales) - checkmate::assert_flag(free_y_scales) - - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) - checkmate::assert_numeric( - plot_width[1], - lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" - ) - - checkmate::assert_flag(rotate_xaxis_labels) - checkmate::assert_flag(swap_axes) - - ggtheme <- match.arg(ggtheme) - checkmate::assert_class(ggplot2_args, "ggplot2_args") - - checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - - assert_decorators(decorators, "plot") - # End of assertions - - # Make UI args - args <- as.list(environment()) - - data_extract_list <- list( - x = x, - y = y, - row_facet = row_facet, - col_facet = col_facet, - color_settings = color_settings, - color = color, - fill = fill, - size = size - ) - - ans <- module( - label = label, - server = srv_g_bivariate.default, - ui = ui_g_bivariate.default, - ui_args = args, - server_args = c( - data_extract_list, - list(plot_height = plot_height, plot_width = plot_width, ggplot2_args = ggplot2_args, decorators = decorators) - ), - transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) - ) - attr(ans, "teal_bookmarkable") <- TRUE - ans -} - -# UI function for the bivariate module -ui_g_bivariate.default <- function(id, ...) { - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset( - args$x, args$y, args$row_facet, args$col_facet, args$color, args$fill, args$size - ) - - ns <- NS(id) - teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - tags$div(teal.widgets::plot_with_settings_ui(id = ns("myplot"))) - ), - encoding = tags$div( - tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("x", "y", "row_facet", "col_facet", "color", "fill", "size")]), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("y"), - label = "Y variable", - data_extract_spec = args$y, - is_single_dataset = is_single_dataset_value - ), - conditionalPanel( - condition = - "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || - $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", - shinyWidgets::radioGroupButtons( - inputId = ns("use_density"), - label = NULL, - choices = c("frequency", "density"), - selected = ifelse(args$use_density, "density", "frequency"), - justified = TRUE - ) - ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), - if (!is.null(args$row_facet) || !is.null(args$col_facet)) { - tags$div( - class = "data-extract-box", - tags$br(), - bslib::input_switch( - id = ns("facetting"), - label = "Facetting", - value = args$facet - ), - conditionalPanel( - condition = paste0("input['", ns("facetting"), "']"), - tags$div( - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting variable", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value - ) - }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting variable", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value - ) - }, - checkboxInput(ns("free_x_scales"), "free x scales", value = args$free_x_scales), - checkboxInput(ns("free_y_scales"), "free y scales", value = args$free_y_scales) - ) - ) - ) - }, - if (args$color_settings) { - # Put a grey border around the coloring settings - tags$div( - class = "data-extract-box", - tags$label("Color settings"), - bslib::input_switch( - id = ns("coloring"), - label = "Color settings", - value = TRUE - ), - conditionalPanel( - condition = paste0("input['", ns("coloring"), "']"), - tags$div( - teal.transform::data_extract_ui( - id = ns("color"), - label = "Outline color by variable", - data_extract_spec = args$color, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("fill"), - label = "Fill color by variable", - data_extract_spec = args$fill, - is_single_dataset = is_single_dataset_value - ), - tags$div( - id = ns("size_settings"), - teal.transform::data_extract_ui( - id = ns("size"), - label = "Size of points by variable (only if x and y are numeric)", - data_extract_spec = args$size, - is_single_dataset = is_single_dataset_value - ) - ) - ) - ) - ) - }, - bslib::accordion( - open = TRUE, - bslib::accordion_panel( - title = "Plot settings", - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), - checkboxInput(ns("swap_axes"), "Swap axes", value = args$swap_axes), - selectInput( - inputId = ns("ggtheme"), - label = "Theme (by ggplot):", - choices = ggplot_themes, - selected = args$ggtheme, - multiple = FALSE - ), - sliderInput( - ns("alpha"), "Opacity Scatterplot:", - min = 0, max = 1, - step = .05, value = .5, ticks = FALSE - ), - sliderInput( - ns("fixed_size"), "Scatterplot point size:", - min = 1, max = 8, - step = 1, value = 2, ticks = FALSE - ), - checkboxInput(ns("add_lines"), "Add lines"), - ) - ) - ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), - pre_output = args$pre_output, - post_output = args$post_output - ) -} - -# Server function for the bivariate module -srv_g_bivariate.default <- function(id, - data, - x, - y, - row_facet, - col_facet, - color_settings = FALSE, - color, - fill, - size, - plot_height, - plot_width, - ggplot2_args, - decorators) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - - ns <- session$ns - - data_extract <- list( - x = x, y = y, row_facet = row_facet, col_facet = col_facet, - color = color, fill = fill, size = size - ) - - rule_var <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()$select - if (length(value) == 0L && length(othervalue) == 0L) { - "Please select at least one of x-variable or y-variable" - } - } - } - rule_diff <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - x = rule_var("y"), - y = rule_var("x"), - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("row_facet") - ) - ) - ) - - iv_r <- reactive({ - iv_facet <- shinyvalidate::InputValidator$new() - iv_child <- teal.transform::compose_and_enable_validators(iv_facet, selector_list, - validator_names = c("row_facet", "col_facet") - ) - iv_child$condition(~ isTRUE(input$facetting)) - - iv <- shinyvalidate::InputValidator$new() - iv$add_validator(iv_child) - teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = c("x", "y")) - }) - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - - anl_merged_q <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Bivariate Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - obj %>% - teal.code::eval_code( - c( - 'library("ggplot2");library("dplyr")', # nolint: quotes - as.expression(anl_merged_input()$expr) - ) - ) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - output_q <- reactive({ - teal::validate_inputs(iv_r()) - - ANL <- merged$anl_q_r()[["ANL"]] - teal::validate_has_data(ANL, 3) - - x_col_vec <- as.vector(merged$anl_input_r()$columns_source$x) - x_name <- `if`(is.null(x_col_vec), character(0), x_col_vec) - y_col_vec <- as.vector(merged$anl_input_r()$columns_source$y) - y_name <- `if`(is.null(y_col_vec), character(0), y_col_vec) - - row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) - col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) - color_name <- if ("color" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$color) - } else { - character(0) - } - fill_name <- if ("fill" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$fill) - } else { - character(0) - } - size_name <- if ("size" %in% names(merged$anl_input_r()$columns_source)) { - as.vector(merged$anl_input_r()$columns_source$size) - } else { - character(0) - } - - use_density <- input$use_density == "density" - free_x_scales <- input$free_x_scales - free_y_scales <- input$free_y_scales - ggtheme <- input$ggtheme - rotate_xaxis_labels <- input$rotate_xaxis_labels - swap_axes <- input$swap_axes - - is_scatterplot <- all(vapply(ANL[c(x_name, y_name)], is.numeric, logical(1))) && - length(x_name) > 0 && length(y_name) > 0 - - if (is_scatterplot) { - shinyjs::show("alpha") - alpha <- input$alpha - shinyjs::show("add_lines") - - if (color_settings && input$coloring) { - shinyjs::hide("fixed_size") - shinyjs::show("size_settings") - size <- NULL - } else { - shinyjs::show("fixed_size") - size <- input$fixed_size - } - } else { - shinyjs::hide("add_lines") - updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE)) - shinyjs::hide("alpha") - shinyjs::hide("fixed_size") - shinyjs::hide("size_settings") - alpha <- 1 - size <- NULL - } - - teal::validate_has_data(ANL[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) - - cl <- bivariate_plot_call( - data_name = "ANL", - x = x_name, - y = y_name, - x_class = ifelse(!identical(x_name, character(0)), class(ANL[[x_name]]), "NULL"), - y_class = ifelse(!identical(y_name, character(0)), class(ANL[[y_name]]), "NULL"), - x_label = varname_w_label(x_name, ANL), - y_label = varname_w_label(y_name, ANL), - freq = !use_density, - theme = ggtheme, - rotate_xaxis_labels = rotate_xaxis_labels, - swap_axes = swap_axes, - alpha = alpha, - size = size, - ggplot2_args = ggplot2_args - ) - - facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) - - if (facetting) { - facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) - - if (!is.null(facet_cl)) { - cl <- call("+", cl, facet_cl) - } - } - - if (input$add_lines) { - cl <- call("+", cl, quote(geom_line(size = 1))) - } - - coloring_cl <- NULL - if (color_settings) { - if (input$coloring) { - coloring_cl <- coloring_ggplot_call( - colour = color_name, - fill = fill_name, - size = size_name, - is_point = any(grepl("geom_point", cl %>% deparse())) - ) - legend_lbls <- substitute( - expr = labs(color = color_name, fill = fill_name, size = size_name), - env = list( - color_name = varname_w_label(color_name, ANL), - fill_name = varname_w_label(fill_name, ANL), - size_name = varname_w_label(size_name, ANL) - ) - ) - } - if (!is.null(coloring_cl)) { - cl <- call("+", call("+", cl, coloring_cl), legend_lbls) - } - } - - obj <- merged$anl_q_r() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") - teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) - }) - - decorated_output_q_facets <- srv_decorate_teal_data( - "decorator", - data = output_q, - decorators = select_decorators(decorators, "plot"), - expr = reactive({ - ANL <- merged$anl_q_r()[["ANL"]] - row_facet_name <- as.vector(merged$anl_input_r()$columns_source$row_facet) - col_facet_name <- as.vector(merged$anl_input_r()$columns_source$col_facet) - - # Add labels to facets - nulled_row_facet_name <- varname_w_label(row_facet_name, ANL) - nulled_col_facet_name <- varname_w_label(col_facet_name, ANL) - facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) - without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting - - print_call <- if (without_facet) { - quote(plot) - } else { - substitute( - expr = { - teal.modules.general::add_facet_labels( - plot, - xfacet_label = nulled_col_facet_name, - yfacet_label = nulled_row_facet_name - ) - }, - env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) - ) - } - print_call - }) - ) - - plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) - - pws <- teal.widgets::plot_with_settings_srv( - id = "myplot", - plot_r = plot_r, - height = plot_height, - width = plot_width - ) - - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q_facets) - - # Render R code. - - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Bivariate Plot" - ) - decorated_output_dims_q - }) -} diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R new file mode 100644 index 000000000..215033135 --- /dev/null +++ b/R/tm_g_bivariate_picks.R @@ -0,0 +1,495 @@ +#' @export +tm_g_bivariate.picks <- function(label = "Bivariate Plots", + x = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1 + ), + values(selected = tidyselect::everything(), multiple = TRUE) + ), + y = picks( + datasets(), + variables( + choices = tidyselect::where(is.numeric) | + teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2 + ), + values(selected = tidyselect::everything(), multiple = TRUE) + ), + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + plot_height = c(600, 200, 2000), + plot_width = NULL, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_bivariate") + + # Start of assertions + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + if (isTRUE(attr(x$variables, "multiple"))) { + warning("`x`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + if (isTRUE(attr(y$variables, "multiple"))) { + warning("`y`-axis doesn't accept multiple variables. Changing automatically.") + attr(x$variables, "multiple") <- FALSE + } + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(color, "picks", null.ok = TRUE) + checkmate::assert_class(size, "picks", null.ok = TRUE) + checkmate::assert_string(label) + checkmate::assert_flag(use_density) + + # Determines color, fill & size if they are not explicitly set + checkmate::assert_flag(color_settings) + if (color_settings) { + if (is.null(color)) { + color <- x + color$selected <- NULL + } + if (is.null(fill)) { + fill <- x + fill$selected <- NULL + } + if (is.null(size)) { + size <- x + size$selected <- NULL + } + } else { + if (!is.null(c(color, fill, size))) { + stop("'color_settings' argument needs to be set to TRUE if 'color', 'fill', and/or 'size' is/are supplied.") + } + } + + checkmate::assert_flag(free_x_scales) + checkmate::assert_flag(free_y_scales) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(swap_axes) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, "plot") + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_g_bivariate.picks, + ui = ui_g_bivariate.picks, + ui_args = args[names(args) %in% names(formals(ui_g_bivariate.picks))], + server_args = args[names(args) %in% names(formals(srv_g_bivariate.picks))], + transformators = transformators, + datanames = { + datanames <- teal.transform::datanames(list(x, y, row_facet, col_facet, color, fill, size)) + if (length(datanames)) datanames else "all" + } + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the bivariate module +ui_g_bivariate.picks <- function(id, + x, + y, + row_facet = NULL, + col_facet = NULL, + facet = !is.null(row_facet) || !is.null(col_facet), + color = NULL, + fill = NULL, + size = NULL, + use_density = FALSE, + color_settings = FALSE, + free_x_scales = FALSE, + free_y_scales = FALSE, + rotate_xaxis_labels = FALSE, + swap_axes = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + decorators = list()) { + ns <- NS(id) + teal::standard_layout2( + output = bslib::card( + teal.widgets::plot_with_settings_ui(id = ns("myplot")), + full_screen = TRUE + ), + encoding = shiny::tagList( + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x) + ), + teal::teal_nav_item( + label = tags$strong("Y variable"), + teal.transform::module_input_ui(id = ns("y"), spec = y) + ), + conditionalPanel( + condition = + "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || + $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", + teal::teal_nav_item( + label = NULL, + shinyWidgets::radioGroupButtons( + inputId = ns("use_density"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(use_density, "density", "frequency"), + justified = TRUE + ) + ) + ), + if (!is.null(row_facet)) { + teal::teal_nav_item( + tags$div( + tags$strong("Row facetting variable"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet), + checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) + ) + ) + }, + if (!is.null(col_facet)) { + teal::teal_nav_item( + tags$div( + tags$strong("Column facetting variable"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet), + checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) + ) + ) + }, + if (color_settings) { + # Put a grey border around the coloring settings + teal::teal_nav_item( + label = tags$strong("Color settings"), + tags$div( + bslib::input_switch(id = ns("coloring"), label = "Color settings", value = TRUE), + conditionalPanel( + condition = paste0("input['", ns("coloring"), "']"), + tags$div( + teal.transform::module_input_ui(id = ns("color"), spec = color), # label = "Outline color by variable" + teal.transform::module_input_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" + tags$div( + id = ns("size_settings"), + teal.transform::module_input_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" + ) + ) + ) + ) + ) + }, + teal::teal_nav_item( + label = NULL, + teal:::.teal_navbar_menu( + id = ns("plot_settings"), + label = "Plot settings", + icon = "gear", + tags$div( + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + checkboxInput(ns("swap_axes"), "Swap axes", value = swap_axes), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ), + sliderInput( + ns("alpha"), "Opacity Scatterplot:", + min = 0, max = 1, + step = .05, value = .5, ticks = FALSE + ), + sliderInput( + ns("fixed_size"), "Scatterplot point size:", + min = 1, max = 8, + step = 1, value = 2, ticks = FALSE + ), + checkboxInput(ns("add_lines"), "Add lines") + ) + ) + ), + teal::teal_nav_item( + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the bivariate module +srv_g_bivariate.picks <- function(id, + data, + x, + y, + row_facet, + col_facet, + color_settings = FALSE, + color, + fill, + size, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + ns <- session$ns + selectors <- teal.transform::module_input_srv( + spec = list( + x = x, + y = y, + row_facet = row_facet, + col_facet = col_facet, + color = color, + fill = fill, + size = size + ), + data = data + ) + + validated_q <- reactive({ + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = length(selectors$x()$variables$selected) && length(selectors$y()$variables$selected), + message = "Please select at least one of x-variable or y-variable" + ) + if (!is.null(col_facet) && !is.null(row_facet)) { + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(selectors$row_facet()$variables$selected) || + is.null(selectors$col_facet()$variables$selected) || + !identical(selectors$row_facet()$variables$selected, selectors$col_facet()$variables$selected), + message = "Row and column facetting variables must be different." + ) + } + + obj <- req(data()) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Bivariate Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + output_q <- reactive(label = "make bivariateplot", { + req(merged$data()) + logger::log_debug("Plotting bivariate") + anl <- merged$data()[["anl"]] + teal::validate_has_data(anl, 3) + + + x_name <- merged$merge_vars()$x + y_name <- merged$merge_vars()$y + row_facet_name <- merged$merge_vars()$row_facet + col_facet_name <- merged$merge_vars()$col_facet + color_name <- merged$merge_vars()$color + fill_name <- merged$merge_vars()$fill + size_name <- merged$merge_vars()$size + + use_density <- input$use_density == "density" + free_x_scales <- input$free_x_scales + free_y_scales <- input$free_y_scales + ggtheme <- input$ggtheme + rotate_xaxis_labels <- input$rotate_xaxis_labels + swap_axes <- input$swap_axes + + + supported_types <- c("NULL", "numeric", "integer", "factor", "character", "logical", "ordered") + x_class <- class(anl[[x_name]])[1] + validate_input( + "x-variables-selected", + condition = x_class %in% supported_types, + message = paste0("Data type '", x_class, "' is not supported.") + ) + y_class <- class(anl[[y_name]])[[1]] + validate_input( + "x-variables-selected", + condition = y_class %in% supported_types, + message = paste0("Data type '", y_class, "' is not supported.") + ) + + is_scatterplot <- all(vapply(anl[c(x_name, y_name)], is.numeric, logical(1))) && + length(x_name) > 0 && length(y_name) > 0 + + if (is_scatterplot) { + shinyjs::show("alpha") + alpha <- input$alpha + shinyjs::show("add_lines") + + if (color_settings && input$coloring) { + shinyjs::hide("fixed_size") + shinyjs::show("size_settings") + size <- NULL + } else { + shinyjs::show("fixed_size") + size <- input$fixed_size + } + } else { + shinyjs::hide("add_lines") + updateCheckboxInput(session, "add_lines", value = restoreInput(ns("add_lines"), FALSE)) + shinyjs::hide("alpha") + shinyjs::hide("fixed_size") + shinyjs::hide("size_settings") + alpha <- 1 + size <- NULL + } + + teal::validate_has_data(anl[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) + + + + cl <- bivariate_plot_call( + data_name = "anl", + x = x_name, + y = y_name, + x_class = ifelse(length(x_name), class(anl[[x_name]]), "NULL"), + y_class = ifelse(length(y_name), class(anl[[y_name]]), "NULL"), + x_label = varname_w_label(x_name, anl), + y_label = varname_w_label(y_name, anl), + freq = !use_density, + theme = ggtheme, + rotate_xaxis_labels = rotate_xaxis_labels, + swap_axes = swap_axes, + alpha = alpha, + size = size, + ggplot2_args = ggplot2_args + ) + + if (!is.null(row_facet_name) || !is.null(col_facet_name)) { + facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name, free_x_scales, free_y_scales) + + if (!is.null(facet_cl)) { + cl <- call("+", cl, facet_cl) + } + } + + if (input$add_lines) { + cl <- call("+", cl, quote(geom_line(size = 1))) + } + + coloring_cl <- NULL + if (color_settings) { + if (input$coloring) { + coloring_cl <- coloring_ggplot_call( + colour = color_name, + fill = fill_name, + size = size_name, + is_point = any(grepl("geom_point", cl %>% deparse())) + ) + legend_lbls <- substitute( + expr = labs(color = color_name, fill = fill_name, size = size_name), + env = list( + color_name = varname_w_label(color_name, ANL), + fill_name = varname_w_label(fill_name, ANL), + size_name = varname_w_label(size_name, ANL) + ) + ) + } + if (!is.null(coloring_cl)) { + cl <- call("+", call("+", cl, coloring_cl), legend_lbls) + } + } + + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Plot") + teal.code::eval_code(obj, substitute(expr = plot <- cl, env = list(cl = cl))) + }) + + decorated_output_q_facets <- srv_decorate_teal_data( + "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = reactive({ + anl <- merged$data()[["anl"]] + row_facet_name <- merged$merge_vars()$row_facet + col_facet_name <- merged$merge_vars()$col_facet + + # Add labels to facets + nulled_row_facet_name <- varname_w_label(row_facet_name, anl) + nulled_col_facet_name <- varname_w_label(col_facet_name, anl) + facetting <- (isTRUE(input$facetting) && (!is.null(row_facet_name) || !is.null(col_facet_name))) + without_facet <- (is.null(nulled_row_facet_name) && is.null(nulled_col_facet_name)) || !facetting + + print_call <- if (without_facet) { + quote(plot) + } else { + substitute( + expr = { + teal.modules.general::add_facet_labels( + plot, + xfacet_label = nulled_col_facet_name, + yfacet_label = nulled_row_facet_name + ) + }, + env = list(nulled_col_facet_name = nulled_col_facet_name, nulled_row_facet_name = nulled_row_facet_name) + ) + } + print_call + }) + ) + + plot_r <- reactive(req(decorated_output_q_facets())[["plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q_facets) + + # Render R code. + + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Bivariate Plot" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index e4ced5b2f..0f2067f3f 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -141,43 +141,40 @@ tm_g_distribution <- function(label = "Distribution Module", } #' @export -tm_g_distribution.picks <- function(label = "Distribution Module", - dist_var = picks( - datasets(), - variables(where(is.numeric)), - values(selected = tidyselect::everything()) - ), - strata_var = NULL, - group_var = NULL, - freq = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - bins = c(30L, 1L, 100L), - plot_height = c(600, 200, 2000), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_g_distribution.default <- function(label = "Distribution Module", + dist_var, + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_distribution") + # Normalize the parameters + if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) + if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) + if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(dist_var, "picks") - if (isTRUE(attr(dist_var$variables, "multiple"))) { - warning("dist_var accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(dist_var$variables, "multiple") <- FALSE - } - checkmate::assert_class(strata_var, "picks", null.ok = TRUE) - checkmate::assert_class(group_var, "picks", null.ok = TRUE) + checkmate::assert_list(dist_var, "data_extract_spec") + checkmate::assert_false(dist_var[[1L]]$select$multiple) + checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) checkmate::assert_flag(freq) ggtheme <- match.arg(ggtheme) plot_choices <- c("Histogram", "QQplot") - - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) checkmate::assert_list(ggplot2_args, types = "ggplot2_args") checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) @@ -206,125 +203,179 @@ tm_g_distribution.picks <- function(label = "Distribution Module", # Make UI args args <- as.list(environment()) + data_extract_list <- list( + dist_var = dist_var, + strata_var = strata_var, + group_var = group_var + ) + ans <- module( label = label, - server = srv_g_distribution.picks, - ui = ui_g_distribution.picks, - ui_args = args[names(args) %in% names(formals(ui_g_distribution.picks))], - server_args = args[names(args) %in% names(formals(srv_g_distribution.picks))], , + ui = ui_g_distribution.default, + server = srv_g_distribution.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(dist_var, strata_var, group_var)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- TRUE ans } - # UI function for the distribution module -ui_g_distribution.picks <- function(id, - strata_var, - dist_var, - group_var, - freq, - bins, - ggtheme, - pre_output, - post_output, - decorators) { +ui_g_distribution.default <- function(id, ...) { + args <- list(...) ns <- NS(id) - - hist_elem <- .ui_hist( - ns("histogram_plot"), - bins = bins, - freq = freq, - decorators = select_decorators(decorators, "histogram_plot") - ) - qq_elem <- .ui_qq(ns("qq_plot"), decorators = select_decorators(decorators, "qq_plot")) - summary_table_elem <- .ui_summary_table(ns("summary_table"), select_decorators(decorators, "Statistics Table")) - test_table_elem <- .ui_test_table(ns("test_table"), - is_stratified = !is.null(strata_var), - decorators = select_decorators(decorators, "Test Table") - ) + is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) teal.widgets::standard_layout( output = teal.widgets::white_small_well( tabsetPanel( id = ns("tabs"), - tabPanel("Histogram", hist_elem$output), - tabPanel("QQplot", qq_elem$output) + tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))), + tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot"))) ), - bslib::card(summary_table_elem$output), - bslib::card(test_table_elem$output) + tags$h3("Statistics Table"), + DT::dataTableOutput(ns("summary_table")), + tags$h3("Tests"), + conditionalPanel( + sprintf("input['%s'].length === 0", ns("dist_tests")), + div( + id = ns("please_select_a_test"), + "Please select a test" + ) + ), + conditionalPanel( + sprintf("input['%s'].length > 0", ns("dist_tests")), + DT::dataTableOutput(ns("t_stats")) + ) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Variable"), - teal.transform::module_input_ui(id = ns("dist_var"), spec = dist_var) + teal.transform::datanames_input(args[c("dist_var", "strata_var")]), + teal.transform::data_extract_ui( + id = ns("dist_i"), + label = "Variable", + data_extract_spec = args$dist_var, + is_single_dataset = is_single_dataset_value ), - if (!is.null(group_var)) { + if (!is.null(args$group_var)) { tagList( - teal::teal_nav_item( - label = tags$strong("Group by:"), - teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) + teal.transform::data_extract_ui( + id = ns("group_i"), + label = "Group by", + data_extract_spec = args$group_var, + is_single_dataset = is_single_dataset_value ), uiOutput(ns("scales_types_ui")) ) }, - if (!is.null(strata_var)) { - tagList( - teal::teal_nav_item( - label = tags$strong("Stratify by:"), - teal.transform::module_input_ui(id = ns("strata_var"), spec = strata_var) - ) + if (!is.null(args$strata_var)) { + teal.transform::data_extract_ui( + id = ns("strata_i"), + label = "Stratify by", + data_extract_spec = args$strata_var, + is_single_dataset = is_single_dataset_value ) }, bslib::accordion( conditionalPanel( condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), - bslib::accordion_panel(title = "Histogram", hist_elem$encodings, collapsed = FALSE) + bslib::accordion_panel( + "Histogram", + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1), + shinyWidgets::prettyRadioButtons( + ns("main_type"), + label = "Plot Type:", + choices = c("Density", "Frequency"), + selected = if (!args$freq) "Density" else "Frequency", + bigger = FALSE, + inline = TRUE + ), + checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), + ui_decorate_teal_data( + ns("d_density"), + decorators = select_decorators(args$decorators, "histogram_plot") + ) + ) ), conditionalPanel( condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), - bslib::accordion_panel(title = "QQ Plot", qq_elem$encodings, collapsed = FALSE) + bslib::accordion_panel( + "QQ Plot", + checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), + ui_decorate_teal_data( + ns("d_qq"), + decorators = select_decorators(args$decorators, "qq_plot") + ), + collapsed = FALSE + ) ), - bslib::accordion_panel( # todo: hide ONLY when frequency is selected for histogram - "Theoretical Distribution", - teal.widgets::optionalSelectInput( - ns("t_dist"), - tags$div( - tagList( - "Distribution:", - bslib::tooltip( - icon("circle-info"), - tags$span("Default parameters are optimized with MASS::fitdistr function.") + conditionalPanel( + condition = paste0("input['", ns("main_type"), "'] == 'Density'"), + bslib::accordion_panel( + "Theoretical Distribution", + teal.widgets::optionalSelectInput( + ns("t_dist"), + tags$div( + tagList( + "Distribution:", + bslib::tooltip( + icon("circle-info"), + tags$span( + "Default parameters are optimized with MASS::fitdistr function." + ) + ) ) - ) + ), + choices = c("normal", "lognormal", "gamma", "unif"), + selected = NULL, + multiple = FALSE ), - choices = c("normal", "lognormal", "gamma", "unif"), - selected = NULL, - multiple = FALSE - ), - conditionalPanel( - condition = paste0("input['", ns("t_dist"), "'] != null && input['", ns("t_dist"), "'] != ''"), numericInput(ns("dist_param1"), label = "param1", value = NULL), numericInput(ns("dist_param2"), label = "param2", value = NULL), - tags$span(actionButton(ns("params_reset"), "Default params")) - ), - collapsed = FALSE + tags$span(actionButton(ns("params_reset"), "Default params")), + collapsed = FALSE + ) + ), + bslib::accordion_panel( + title = "Tests", + teal.widgets::optionalSelectInput( + ns("dist_tests"), + "Tests:", + choices = c( + "Shapiro-Wilk", + if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", + if (!is.null(args$strata_var)) "one-way ANOVA", + if (!is.null(args$strata_var)) "Fligner-Killeen", + if (!is.null(args$strata_var)) "F-test", + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)", + if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" + ), + selected = NULL + ) + ), + bslib::accordion_panel( + title = "Statistics Table", + sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2) ), - bslib::accordion_panel(title = "Tests", test_table_elem$encodings), - bslib::accordion_panel(title = "Statistics Table", summary_table_elem$encodings), bslib::accordion_panel( title = "Plot settings", selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = ggtheme, + selected = args$ggtheme, multiple = FALSE ) ) @@ -333,100 +384,166 @@ ui_g_distribution.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the distribution module -srv_g_distribution.picks <- function(id, - data, - dist_var, - strata_var, - group_var, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_distribution.default <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") setBookmarkExclude("params_reset") - ns <- session$ns + ns <- session$ns - selectors <- teal.transform::module_input_srv( - spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), - data = data - ) + rule_req <- function(value) { + if (isTRUE(input$dist_tests %in% c( + "Fligner-Killeen", + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)", + "one-way ANOVA" + ))) { + if (!shinyvalidate::input_provided(value)) { + "Please select stratify variable." + } + } + } + rule_dupl <- function(...) { + if (identical(input$dist_tests, "Fligner-Killeen")) { + strata <- selector_list()$strata_i()$select + group <- selector_list()$group_i()$select + if (isTRUE(strata == group)) { + "Please select different variables for strata and group." + } + } + } - qenv <- reactive({ - validate_input( - inputId = "dist_var-variables-selected", - condition = length(selectors$dist_var()$variables$selected) == 1, - message = "Distribution variable must be selected." + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list( + dist_i = dist_var, + strata_i = strata_var, + group_i = group_var + ), + data, + select_validation_rule = list( + dist_i = shinyvalidate::sv_required("Please select a variable") + ), + filter_validation_rule = list( + strata_i = shinyvalidate::compose_rules( + rule_req, + rule_dupl + ), + group_i = rule_dupl ) + ) - obj <- req(data()) - teal.reporter::teal_card(obj) <- c( - teal.reporter::teal_card("# Distribution Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") }) - merged <- teal.transform::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") - - validate_merged <- reactive({ - obj <- merged$data() - anl <- obj[["anl"]] - - validate_input( - inputId = "dist_var-variables-selected", - condition = is.numeric(anl[[merged$merge_vars()$dist_var]]), - message = "Distribution variable must be numeric." + iv_r_dist <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators( + iv, selector_list, + validator_names = c("strata_i", "group_i") ) - - if (length(merged$merge_vars()$group_var) > 0) { - validate_input( - "group_var-variables-selected", - condition = inherits(anl[[merged$merge_vars()$group_var]], c("integer", "factor", "character")), - message = "Group by variable must be `factor`, `character`, or `integer`" - ) - obj <- within(obj, library("forcats")) - obj <- within( - obj, - expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), - group_var = merged$merge_vars()$group_var + }) + rule_dist_1 <- function(value) { + if (!is.null(input$t_dist)) { + switch(input$t_dist, + "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", + "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", + "gamma" = { + if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" + }, + "unif" = NULL ) } - - if (length(merged$merge_vars()$strata_var) > 0) { - validate_input( - "strata_var-variables-selected", - condition = inherits(anl[[merged$merge_vars()$strata_var]], c("integer", "factor", "character")), - message = "Stratify by variable must be `factor`, `character`, or `integer`" + } + rule_dist_2 <- function(value) { + if (!is.null(input$t_dist)) { + switch(input$t_dist, + "normal" = { + if (!shinyvalidate::input_provided(value)) { + "sd is required" + } else if (value < 0) { + "sd must be non-negative" + } + }, + "lognormal" = { + if (!shinyvalidate::input_provided(value)) { + "sdlog is required" + } else if (value < 0) { + "sdlog must be non-negative" + } + }, + "gamma" = { + if (!shinyvalidate::input_provided(value)) { + "rate is required" + } else if (value <= 0) { + "rate must be positive" + } + }, + "unif" = NULL ) + } + } - obj <- within(obj, library("forcats")) - obj <- within( - obj, - expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), - strata_var = merged$merge_vars()$strata_var - ) + rule_dist <- function(value) { + if (isTRUE(input$tabs == "QQplot") || + isTRUE(input$dist_tests %in% c( + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)" + ))) { + if (!shinyvalidate::input_provided(value)) { + "Please select the theoretical distribution." + } } + } + + iv_dist <- shinyvalidate::InputValidator$new() + iv_dist$add_rule("t_dist", rule_dist) + iv_dist$add_rule("dist_param1", rule_dist_1) + iv_dist$add_rule("dist_param2", rule_dist_2) + iv_dist$enable() - teal::validate_has_data(anl, 1, complete = TRUE) + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) - obj + qenv <- reactive( + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + ) + + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) }) + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) + output$scales_types_ui <- renderUI({ - validate_merged() - if (length(merged$merge_vars()$group_var) > 0) { + if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) { shinyWidgets::prettyRadioButtons( ns("scales_type"), label = "Scales:", @@ -439,36 +556,53 @@ srv_g_distribution.picks <- function(id, }) observeEvent( - eventExpr = { - input$t_dist - input$params_reset - merged$merge_vars()$dist_var - }, + eventExpr = list( + input$t_dist, + input$params_reset, + selector_list()$dist_i()$select + ), handlerExpr = { - params <- if (length(input$t_dist)) { - validate_merged() - req(merged$data()) - anl <- merged$data()[["anl"]] - round( - .calc_dist_params( - x = as.numeric(stats::na.omit(anl[[merged$merge_vars()$dist_var]])), - dist = input$t_dist - ), - 2 - ) + params <- + if (length(input$t_dist) != 0) { + get_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) + } + + ANL <- merged$anl_q_r()[["ANL"]] + round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) + } else { + c("param1" = NA_real_, "param2" = NA_real_) + } + + params_vals <- unname(params) + map_distr_nams <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) + + if (!is.null(input$t_dist) && input$t_dist %in% names(map_distr_nams)) { + params_names <- map_distr_nams[[input$t_dist]] } else { - c("param1" = NA_real_, "param2" = NA_real_) + params_names <- names(params) } updateNumericInput( inputId = "dist_param1", - label = names(params)[1], - value = restoreInput(ns("dist_param1"), params[[1]]) + label = params_names[1], + value = restoreInput(ns("dist_param1"), params_vals[1]) ) updateNumericInput( inputId = "dist_param2", - label = names(params)[2], - value = restoreInput(ns("dist_param1"), params[[2]]) + label = params_names[2], + value = restoreInput(ns("dist_param1"), params_vals[2]) ) }, ignoreInit = TRUE @@ -478,290 +612,271 @@ srv_g_distribution.picks <- function(id, updateActionButton(inputId = "params_reset", label = "Reset params") }) - validate_dist <- reactive({ - # Validate dist_param1 - if (!is.null(input$t_dist) && input$t_dist == "normal") { - validate_input( - "dist_param1", - condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), - message = "mean is required" - ) - validate_input( - "dist_param2", - condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), - message = "sd is required" - ) - validate_input( - "dist_param2", - condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, - message = "sd must be non-negative" - ) - } - if (!is.null(input$t_dist) && input$t_dist == "lognormal") { - validate_input( - "dist_param1", - condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), - message = "meanlog is required" + merge_vars <- reactive({ + teal::validate_inputs(iv_r()) + + dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) + s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) + g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) + + dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL + s_var_name <- if (length(s_var)) as.name(s_var) else NULL + g_var_name <- if (length(g_var)) as.name(g_var) else NULL + + list( + dist_var = dist_var, + s_var = s_var, + g_var = g_var, + dist_var_name = dist_var_name, + s_var_name = s_var_name, + g_var_name = g_var_name + ) + }) + + # common qenv + common_q <- reactive({ + # Create a private stack for this function only. + + obj <- merged$anl_q_r() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Distribution Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") ) - validate_input( - "dist_param2", - condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), - message = "sdlog is required" + + ANL <- obj[["ANL"]] + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + + roundn <- input$roundn + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + # isolated as dist_param1/dist_param2 already triggered the reactivity + t_dist <- isolate(input$t_dist) + + qenv <- obj + + if (length(g_var) > 0) { + validate( + need( + inherits(ANL[[g_var]], c("integer", "factor", "character")), + "Group by variable must be `factor`, `character`, or `integer`" + ) ) - validate_input( - "dist_param2", - condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, - message = "sdlog must be non-negative" + qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), + env = list(g_var = g_var) + ) ) } - if (!is.null(input$t_dist) && input$t_dist == "gamma") { - validate_input( - "dist_param1", - condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), - message = "shape is required" - ) - validate_input( - "dist_param1", - condition = is.null(input$dist_param1) || is.na(input$dist_param1) || input$dist_param1 > 0, - message = "shape must be positive" - ) - validate_input( - "dist_param2", - condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), - message = "rate is required" + + if (length(s_var) > 0) { + validate( + need( + inherits(ANL[[s_var]], c("integer", "factor", "character")), + "Stratify by variable must be `factor`, `character`, or `integer`" + ) ) - validate_input( - "dist_param2", - condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 > 0, - message = "rate must be positive" + + qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), + env = list(s_var = s_var) + ) ) } - }) - # outputs ---- - hist_output <- .srv_hist( - "histogram_plot", - data = reactive({ - validate_merged() - validate_dist() - merged$data() - }), - merge_vars = merged$merge_vars, - t_dist = reactive(input$t_dist), - dist_param1 = reactive(input$dist_param1), - dist_param2 = reactive(input$dist_param2), - scales_type = reactive(input$scales_type), - ggtheme = reactive(input$ggtheme), - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["Histogram"]], - user_default = ggplot2_args$default, - module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) - ), - decorators = select_decorators(decorators, "histogram_plot") - ) + validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) + teal::validate_has_data(ANL, 1, complete = TRUE) - qq_output <- .srv_qq( - "qq_plot", - data = reactive({ - validate_merged() - validate_input( - "t_dist", - condition = !is.null(input$t_dist), - message = "QQ Plot requires Theoretical Distribution to be selected" + if (length(t_dist) != 0) { + map_distr_nams <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") ) - validate_dist() - merged$data() - }), - merge_vars = merged$merge_vars, - t_dist = reactive(input$t_dist), - dist_param1 = reactive(input$dist_param1), - dist_param2 = reactive(input$dist_param2), - scales_type = reactive(input$scales_type), - ggtheme = reactive(input$ggtheme), - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["QQplot"]], - user_default = ggplot2_args$default, - module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) - ), - decorators = select_decorators(decorators, "qq_plot") - ) - - summary_table_output <- .srv_summary_table( - "summary_table", - data = reactive({ - validate_merged() - merged$data() - }), - merge_vars = merged$merge_vars, - decorators = select_decorators(decorators, "Statistics Table") - ) + params_names_raw <- map_distr_nams[[t_dist]] - test_q <- reactive({ - validate_merged() - obj <- merged$data() - anl <- obj[["anl"]] - s_var <- merged$merge_vars()$strata_var - g_var <- merged$merge_vars()$group_var - dist_test <- input$`test_table-dist_test` - - if (identical(dist_test, "Fligner-Killeen")) { - validate_input( - "strata_var-variables-selected", - condition = !isTRUE(s_var == g_var), - message = "Please select different variables for strata and group." + qenv <- teal.code::eval_code( + qenv, + substitute( + expr = { + params <- as.list(c(dist_param1, dist_param2)) + names(params) <- params_names_raw + }, + env = list( + dist_param1 = dist_param1, + dist_param2 = dist_param2, + params_names_raw = params_names_raw + ) + ) ) } - if (!is.null(dist_test) && dist_test %in% c( - "Fligner-Killeen", - "t-test (two-samples, not paired)", - "F-test", - "Kolmogorov-Smirnov (two-samples)", - "one-way ANOVA" - )) { - if (length(g_var) == 0 && length(s_var) > 0) { - validate_input( - "strata_var-variables-selected", - condition = length(unique(anl[[s_var]])) == 2, - message = "Please select stratify variable with 2 levels." + if (length(s_var) == 0 && length(g_var) == 0) { + teal.code::eval_code( + qenv, + substitute( + expr = { + summary_table_data <- ANL %>% + dplyr::summarise( + min = round(min(dist_var_name, na.rm = TRUE), roundn), + median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), + mean = round(mean(dist_var_name, na.rm = TRUE), roundn), + max = round(max(dist_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + env = list( + dist_var_name = as.name(dist_var), + roundn = roundn + ) ) - } else if (length(g_var) > 0 && length(s_var) > 0) { - validate_input( - "strata_var-variables-selected", - condition = all(stats::na.omit(as.vector( - tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 - ))), - message = "Please select stratify variable with 2 levels, per each group." + ) + } else { + teal.code::eval_code( + qenv, + substitute( + expr = { + strata_vars <- strata_vars_raw + summary_table_data <- ANL %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(dist_var_name, na.rm = TRUE), roundn), + median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), + mean = round(mean(dist_var_name, na.rm = TRUE), roundn), + max = round(max(dist_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + env = list( + dist_var_name = dist_var_name, + strata_vars_raw = c(g_var, s_var), + roundn = roundn + ) ) - } + ) } - validate_dist() - obj }) - test_output <- .srv_test_table( - "test_table", - data = test_q, - merge_vars = merged$merge_vars, - t_dist = reactive(input$t_dist), - decorators = select_decorators(decorators, "Test Table") - ) - - # decorated_output_q <- reactive({ - # req(input$tabs, hist_output(), qq_output(), summary_table_output(), output_test_q()) - # test_q_out <- output_test_q() - - # # return everything except switch - # out_q <- switch(input$tabs, - # Histogram = hist_output(), - # QQplot = qq_output() - # ) - # out_q - # }) - # Render R code. - # source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - - # teal.widgets::verbatim_popup_srv( - # id = "rcode", - # verbatim_content = source_code_r, - # title = "R Code for distribution" - # ) - NULL - }) -} - - -.ui_hist <- function(id, bins, freq, decorators) { - ns <- NS(id) - tagList( - encodings = tagList( - teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), - shinyWidgets::prettyRadioButtons( - ns("statistic"), - label = "Plot Type:", - choices = c("Density", "Frequency"), - selected = if (!freq) "Density" else "Frequency", - bigger = FALSE, - inline = TRUE - ), - checkboxInput(ns("add_density"), label = "Overlay Density", value = TRUE), - ui_decorate_teal_data(ns("decorators"), decorators = decorators) - ), - output = teal.widgets::plot_with_settings_ui(id = ns("plot")) - ) -} + # distplot qenv ---- + dist_q <- eventReactive( + eventExpr = { + common_q() + input$scales_type + input$main_type + input$bins + input$add_dens + is.null(input$ggtheme) + }, + valueExpr = { + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + t_dist <- input$t_dist + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + + scales_type <- input$scales_type -.srv_hist <- function(id, - data, - merge_vars, - ggtheme, - scales_type, - t_dist, - dist_param1, - dist_param2, - plot_height, - plot_width, - ggplot2_args, - decorators) { - moduleServer(id, function(input, output, session) { - output_q <- eventReactive( - list( - data(), - input$bins, - input$statistic, - input$add_density, - dist_param1(), # don't observe t_dist as dist_param1 is changed by t_dist - dist_param2(), # don't observe t_dist as dist_param2 is changed by t_dist - scales_type() - ), - { - obj <- req(data()) - bins <- req(input$bins) - statistic <- if (req(input$statistic) == "Density") "density" else "count" - logger::log_debug(".srv_hist@1 Recalculating Histogram") - add_density <- input$add_density - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var ndensity <- 512 + main_type_var <- input$main_type + bins_var <- input$bins + add_dens_var <- input$add_dens + ggtheme <- input$ggtheme - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Histogram Plot") + teal::validate_inputs(iv_dist) - plot_call <- substitute( - expr = ggplot2::ggplot(anl, mapping = ggplot2::aes(d_var_name)) + - ggplot2::geom_histogram( - ggplot2::aes(y = ggplot2::after_stat(stat)), - position = "identity", bins = bins, alpha = 0.3 - ), - env = list(stat = as.name(statistic), bins = bins, d_var_name = as.name(d_var)) - ) + qenv <- common_q() - if (length(s_var)) { - plot_call[[2]]$mapping$col <- as.name(s_var) - plot_call[[2]]$mapping$fill <- as.name(s_var) - } + m_type <- if (main_type_var == "Density") "density" else "count" - if (length(g_var)) { - req(scales_type()) - plot_call <- call( - "+", - plot_call, - substitute( - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales), - list(g_var_name = as.name(g_var), scales = tolower(scales_type())) + plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 + ), + env = list( + m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) + ) + ) + } else if (length(s_var) != 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name, col = s_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), + bins = bins_var, alpha = 0.3 + ), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + s_var = as.name(s_var), + s_var_name = s_var_name + ) + ) + } else if (length(s_var) == 0 && length(g_var) != 0) { + req(scales_type) + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name)) + + ggplot2::geom_histogram( + position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 + ) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + g_var = g_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) + ) + ) + } else { + req(scales_type) + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name, col = s_var_name)) + + ggplot2::geom_histogram( + position = "identity", + ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 + ) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + m_type = as.name(m_type), + bins_var = bins_var, + dist_var_name = dist_var_name, + g_var = g_var, + s_var = as.name(s_var), + g_var_name = g_var_name, + s_var_name = s_var_name, + scales_raw = tolower(scales_type) ) ) } - if (add_density) { + if (add_dens_var) { plot_call <- substitute( expr = plot_call + ggplot2::stat_density( - ggplot2::aes(y = ggplot2::after_stat(const * stat)), + ggplot2::aes(y = ggplot2::after_stat(const * m_type2)), geom = "line", position = "identity", alpha = 0.5, @@ -770,61 +885,83 @@ srv_g_distribution.picks <- function(id, ), env = list( plot_call = plot_call, - const = if (statistic == "density") { + const = if (main_type_var == "Density") { 1 } else { - diff(range(obj[["anl"]][[d_var]], na.rm = TRUE)) / bins + diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var }, - stat = as.name(statistic), + m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"), ndensity = ndensity ) ) } - if (length(s_var) == 0 && length(g_var) == 0 && statistic == "density" && length(t_dist()) != 0) { - req(dist_param1(), dist_param2()) - obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes - param_list <- .dist_param_list(t_dist(), dist_param1(), dist_param2()) - map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + df_params <- as.data.frame(append(params, list(name = t_dist))), + env = list(t_dist = t_dist) + ) + ) + datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) + label <- quote(tb) plot_call <- substitute( - expr = plot_call + - ggpp::geom_table_npc( - data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), - ggplot2::aes(npcx = x, npcy = y, label = tb), - hjust = 0, vjust = 1, size = 4 - ) + - stat_function( - data = data.frame(x = range(anl[[d_var]]), color = density_dist), - ggplot2::aes(x, color = color), - fun = density_dist_name, - n = ndensity, - size = 2, - args = param_list - ) + - ggplot2::scale_color_manual(values = stats::setNames("blue", density_dist), aesthetics = "color"), + expr = plot_call + ggpp::geom_table_npc( + data = data, + ggplot2::aes(npcx = x, npcy = y, label = label), + hjust = 0, vjust = 1, size = 4 + ), + env = list(plot_call = plot_call, data = datas, label = label) + ) + } + + if ( + length(s_var) == 0 && + length(g_var) == 0 && + main_type_var == "Density" && + length(t_dist) != 0 && + main_type_var == "Density" + ) { + map_dist <- stats::setNames( + c("dnorm", "dlnorm", "dgamma", "dunif"), + c("normal", "lognormal", "gamma", "unif") + ) + plot_call <- substitute( + expr = plot_call + stat_function( + data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), + ggplot2::aes(x, color = color), + fun = mapped_dist_name, + n = ndensity, + size = 2, + args = params + ) + + ggplot2::scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"), env = list( plot_call = plot_call, - d_var = d_var, - density_dist = unname(map_dist[t_dist()]), - density_dist_name = as.name(unname(map_dist[t_dist()])), + dist_var = dist_var, ndensity = ndensity, - nested_df = as.call( - c( - as.name("data.frame"), - param_list, - list(distribution = t_dist()) - ) - ), - param_list = param_list + mapped_dist = unname(map_dist[t_dist]), + mapped_dist_name = as.name(unname(map_dist[t_dist])) ) ) } - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Histogram"]], + user_default = ggplot2_args$default + ) + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Histogram Plot") teal.code::eval_code( - obj, + qenv, substitute( expr = histogram_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) @@ -833,141 +970,129 @@ srv_g_distribution.picks <- function(id, } ) - decorated_output_q <- srv_decorate_teal_data( - "decorators", - data = output_q, - decorators = decorators, - expr = quote(histogram_plot) - ) - - output_r <- reactive(req(decorated_output_q())[["histogram_plot"]]) - - pws <- teal.widgets::plot_with_settings_srv( - id = "plot", - plot_r = output_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) - - set_chunk_dims(pws, decorated_output_q) - }) -} - -.ui_qq <- function(id, decorators) { - ns <- NS(id) - tagList( - encodings = tagList( - checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), - ui_decorate_teal_data(ns("decorators"), decorators = decorators) - ), - output = teal.widgets::plot_with_settings_ui(id = ns("plot")) - ) -} - -.srv_qq <- function(id, - data, - merge_vars, - t_dist, - dist_param1, - dist_param2, - scales_type, - ggtheme, - plot_height, - plot_width, - ggplot2_args, - decorators) { - moduleServer(id, function(input, output, session) { - output_q <- eventReactive( - { - data() - t_dist() - dist_param1() - dist_param2() + # qqplot qenv ---- + qq_q <- eventReactive( + eventExpr = { + common_q() + input$scales_type input$qq_line - ggtheme() + is.null(input$ggtheme) + input$tabs }, - { - req(data(), merge_vars(), ggtheme(), t_dist()) - logger::log_debug(".srv_qq@1 Recalculating QQ Plot...") - obj <- data() - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var - - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## QQ Plot") - - plot_call <- substitute( - expr = ggplot2::ggplot(dataname, mapping = ggplot2::aes(sample = d_var_name)), - env = list( - dataname = if (length(g_var)) { - bquote(anl[anl[[.(g_var)]] != "NA", ]) - } else { - quote(anl) - }, - d_var_name = as.name(d_var) + valueExpr = { + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + + scales_type <- input$scales_type + ggtheme <- input$ggtheme + + teal::validate_inputs(iv_r_dist(), iv_dist) + t_dist <- req(input$t_dist) # Not validated when tab is not selected + qenv <- common_q() + + plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var)), + env = list(dist_var = dist_var) ) - ) - if (length(s_var)) plot_call$mapping$color <- as.name(s_var) - if (length(g_var)) { - plot_call <- substitute( - plot_call + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - list( - plot_call = plot_call, - g_var_name = as.name(g_var), - scales_raw = tolower(scales_type()) + } else if (length(s_var) != 0 && length(g_var) == 0) { + substitute( + expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var, color = s_var)), + env = list(dist_var = dist_var, s_var = s_var) + ) + } else if (length(s_var) == 0 && length(g_var) != 0) { + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var)) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + dist_var = dist_var, + g_var = g_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) + ) + ) + } else { + substitute( + expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var, color = s_var)) + + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + env = list( + dist_var = dist_var, + g_var = g_var, + s_var = s_var, + g_var_name = g_var_name, + scales_raw = tolower(scales_type) ) ) } - map_quantile_fun <- c(normal = "qnorm", lognormal = "qlnorm", gamma = "qgamma", unif = "qunif") + map_dist <- stats::setNames( + c("qnorm", "qlnorm", "qgamma", "qunif"), + c("normal", "lognormal", "gamma", "unif") + ) plot_call <- substitute( - expr = plot_call + ggplot2::stat_qq(distribution = quantile_fun, dparams = dparams), - env = list( - plot_call = plot_call, - quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), - dparams = list(dist_param1(), dist_param2()) - ) + expr = plot_call + + ggplot2::stat_qq(distribution = mapped_dist, dparams = params), + env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) ) - if (isTRUE(input$qq_line)) { - plot_call <- substitute( - expr = plot_call + ggplot2::stat_qq_line(distribution = quantile_fun, dparams = dparams), - env = list( - plot_call = plot_call, - quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), - dparams = list(dist_param1(), dist_param2()) + if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, + substitute( + df_params <- as.data.frame(append(params, list(name = t_dist))), + env = list(t_dist = t_dist) ) ) - } + datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) + label <- quote(tb) - if (length(s_var) == 0 && length(g_var) == 0) { - req(dist_param1(), dist_param2()) - obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes plot_call <- substitute( expr = plot_call + ggpp::geom_table_npc( - data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), - ggplot2::aes(npcx = x, npcy = y, label = tb), - hjust = 0, vjust = 1, size = 4 + data = data, + ggplot2::aes(npcx = x, npcy = y, label = label), + hjust = 0, + vjust = 1, + size = 4 ), env = list( plot_call = plot_call, - nested_df = as.call( - c( - as.name("data.frame"), - .dist_param_list(t_dist(), dist_param1(), dist_param2()), - list(distribution = t_dist()) - ) - ) + data = datas, + label = label ) ) } - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + if (isTRUE(input$qq_line)) { + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_qq_line(distribution = mapped_dist, dparams = params), + env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) + ) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["QQplot"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## QQ Plot") teal.code::eval_code( - obj, + qenv, substitute( expr = qq_plot <- plot_call, env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) @@ -976,234 +1101,117 @@ srv_g_distribution.picks <- function(id, } ) - decorated_output_q <- srv_decorate_teal_data( - "decorators", - decorators = decorators, - data = output_q, - expr = quote(qq_plot) - ) - - output_r <- reactive(req(decorated_output_q())[["qq_plot"]]) - - - pws <- teal.widgets::plot_with_settings_srv( - id = "plot", - plot_r = output_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) - - # set_chunk_dims(pws, decorated_output_q) - }) -} - -.ui_summary_table <- function(id, decorators) { - ns <- NS(id) - tagList( - encodings = tagList( - sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2), - ui_decorate_teal_data(ns("decorators"), decorators = decorators) - ), - output = tags$div( - tags$h3("Statistics Table"), - DT::dataTableOutput(ns("summary_table")) - ) - ) -} - -.srv_summary_table <- function(id, data, merge_vars, decorators) { - moduleServer(id, function(input, output, session) { - output_q <- reactive({ - obj <- req(data()) - roundn <- input$roundn - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Statistics table") - - obj <- if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { - within( - obj, - expr = { - summary_table_data <- anl %>% - dplyr::summarise( - min = round(min(d_var_name, na.rm = TRUE), roundn), - median = round(stats::median(d_var_name, na.rm = TRUE), roundn), - mean = round(mean(d_var_name, na.rm = TRUE), roundn), - max = round(max(d_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - d_var_name = as.name(merge_vars()$dist_var), - roundn = roundn - ) - } else { - within( - obj, - expr = { - summary_table_data <- anl %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% - dplyr::summarise( - min = round(min(d_var_name, na.rm = TRUE), roundn), - median = round(stats::median(d_var_name, na.rm = TRUE), roundn), - mean = round(mean(d_var_name, na.rm = TRUE), roundn), - max = round(max(d_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - d_var_name = as.name(merge_vars()$dist_var), - strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), - roundn = roundn - ) - } - - within(obj, summary_table <- rtables::df_to_tt(summary_table_data)) - # if (iv_r()$is_valid()) { - - # } else { - # within( - # q_common, - # summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) - # ) - # } - }) - - decorated_output_q <- srv_decorate_teal_data( - "decorators", - data = output_q, - decorators = decorators, - expr = quote(summary_table) - ) - - output_r <- reactive({ - obj <- req(decorated_output_q()) + # test qenv ---- + test_q <- eventReactive( + ignoreNULL = FALSE, + eventExpr = { + common_q() + input$dist_param1 + input$dist_param2 + input$dist_tests + }, + valueExpr = { + # Create a private stack for this function only. + ANL <- common_q()[["ANL"]] - # todo: why summary_table_data is returned while summary_table is printed in a code? - DT::datatable( - obj[["summary_table_data"]], - options = list( - autoWidth = TRUE, - columnDefs = list(list(width = "200px", targets = "_all")) - ), - rownames = FALSE - ) - }) + dist_var <- merge_vars()$dist_var + s_var <- merge_vars()$s_var + g_var <- merge_vars()$g_var - output$summary_table <- DT::renderDataTable(output_r()) + dist_var_name <- merge_vars()$dist_var_name + s_var_name <- merge_vars()$s_var_name + g_var_name <- merge_vars()$g_var_name - decorated_output_q - }) -} + dist_param1 <- input$dist_param1 + dist_param2 <- input$dist_param2 + dist_tests <- input$dist_tests + t_dist <- input$t_dist -.ui_test_table <- function(id, is_stratified, decorators) { - ns <- NS(id) - tagList( - encodings = tagList( - shinyWidgets::pickerInput( - ns("dist_test"), - "Tests:", - choices = c( - "Shapiro-Wilk", - if (is_stratified) "Kolmogorov-Smirnov (two-samples)", - if (is_stratified) "one-way ANOVA", - if (is_stratified) "Fligner-Killeen", - if (is_stratified) "F-test", - "Kolmogorov-Smirnov (one-sample)", - "Anderson-Darling (one-sample)", - "Cramer-von Mises (one-sample)", - if (is_stratified) "t-test (two-samples, not paired)" - ), - selected = NULL, - options = list( - `allow-clear` = TRUE, - "none-selected-text" = "- Nothing selected -" - ) - ), - ui_decorate_teal_data(ns("decorators"), decorators = decorators) - ), - output = tagList( - tags$h3("Tests"), - DT::dataTableOutput(ns("table")) - ) - ) -} + req(dist_tests) -.srv_test_table <- function(id, data, merge_vars, t_dist, decorators) { - moduleServer(id, function(input, output, session) { - output_q <- eventReactive( - ignoreNULL = FALSE, - eventExpr = { - data() - input$dist_test - }, - valueExpr = { - obj <- data() - anl <- obj[["anl"]] - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var - d_var_name <- as.name(d_var) - s_var_name <- if (!is.null(s_var)) as.name(s_var) - g_var_name <- if (!is.null(g_var)) as.name(g_var) - - dist_test <- input$dist_test - validate(need(length(dist_test) > 0, "Please select a test")) + teal::validate_inputs(iv_dist) if (length(s_var) > 0 || length(g_var) > 0) { - counts <- anl %>% + counts <- ANL %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% dplyr::summarise(n = dplyr::n()) + validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) } - map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + + if (dist_tests %in% c( + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)" + )) { + if (length(g_var) == 0 && length(s_var) > 0) { + validate(need( + length(unique(ANL[[s_var]])) == 2, + "Please select stratify variable with 2 levels." + )) + } + if (length(g_var) > 0 && length(s_var) > 0) { + validate(need( + all(stats::na.omit(as.vector( + tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 + ))), + "Please select stratify variable with 2 levels, per each group." + )) + } + } + + map_dist <- stats::setNames( + c("pnorm", "plnorm", "pgamma", "punif"), + c("normal", "lognormal", "gamma", "unif") + ) sks_args <- list( test = quote(stats::ks.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) ssw_args <- list( test = quote(stats::shapiro.test), - args = bquote(list(.[[.(d_var)]])), + args = bquote(list(.[[.(dist_var)]])), groups = c(g_var, s_var) ) mfil_args <- list( test = quote(stats::fligner.test), - args = bquote(list(.[[.(d_var)]], .[[.(s_var)]])), + args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), groups = c(g_var) ) sad_args <- list( test = quote(goftest::ad.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) scvm_args <- list( test = quote(goftest::cvm.test), - args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), groups = c(g_var, s_var) ) manov_args <- list( test = quote(stats::aov), - args = bquote(list(stats::formula(.(d_var_name) ~ .(s_var_name)), .)), + args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), groups = c(g_var) ) mt_args <- list( test = quote(stats::t.test), - args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) mv_args <- list( test = quote(stats::var.test), - args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) mks_args <- list( test = quote(stats::ks.test), - args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), groups = c(g_var) ) - tests_base <- switch(dist_test, + tests_base <- switch(dist_tests, "Kolmogorov-Smirnov (one-sample)" = sks_args, "Shapiro-Wilk" = ssw_args, "Fligner-Killeen" = mfil_args, @@ -1216,29 +1224,28 @@ srv_g_distribution.picks <- function(id, ) env <- list( - t_test = t_dist(), - d_var = d_var, + t_test = t_dist, + dist_var = dist_var, g_var = g_var, s_var = s_var, args = tests_base$args, groups = tests_base$groups, test = tests_base$test, - d_var_name = d_var_name, + dist_var_name = dist_var_name, g_var_name = g_var_name, s_var_name = s_var_name ) + qenv <- common_q() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Distribution Tests table") - - obj <- if (length(s_var) == 0 && length(g_var) == 0) { - obj <- teal.code::eval_code(obj, 'library("generics")') # nolint quotes - teal.code::eval_code( - obj, + if (length(s_var) == 0 && length(g_var) == 0) { + qenv <- teal.code::eval_code(qenv, 'library("generics")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, substitute( expr = { - test_table_data <- anl %>% - dplyr::select(d_var) %>% + test_table_data <- ANL %>% + dplyr::select(dist_var) %>% with(., generics::glance(do.call(test, args))) %>% dplyr::mutate_if(is.numeric, round, 3) }, @@ -1246,14 +1253,13 @@ srv_g_distribution.picks <- function(id, ) ) } else { - # todo: why there is a `library` call when `tidyr::unnest` is prefixed, same for `generics` - obj <- teal.code::eval_code(obj, 'library("tidyr")') # nolint quotes - teal.code::eval_code( - obj, + qenv <- teal.code::eval_code(qenv, 'library("tidyr")') # nolint quotes + qenv <- teal.code::eval_code( + qenv, substitute( expr = { - test_table_data <- anl %>% - dplyr::select(d_var, s_var, g_var) %>% + test_table_data <- ANL %>% + dplyr::select(dist_var, s_var, g_var) %>% dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% dplyr::do(tests = generics::glance(do.call(test, args))) %>% tidyr::unnest(tests) %>% @@ -1263,50 +1269,151 @@ srv_g_distribution.picks <- function(id, ) ) } + } + ) + + # outputs ---- + output_dist_q <- reactive(c(common_q(), req(dist_q()))) + output_qq_q <- reactive(c(common_q(), req(qq_q()))) + + # Summary table listing has to be created separately to allow for qenv join + q_common <- common_q() + teal.reporter::teal_card(q_common) <- c( + teal.reporter::teal_card(q_common), + "## Statistics table" + ) + output_summary_q <- reactive({ + if (iv_r()$is_valid()) { + within(q_common, { + summary_table <- rtables::df_to_tt(summary_table_data) + }) + } else { + within( + q_common, + summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) + ) + } + }) - within(obj, { + output_test_q <- reactive({ + # wrapped in if since could lead into validate error - we do want to continue + test_q_out <- try(test_q(), silent = TRUE) + q_common <- common_q() + teal.reporter::teal_card(q_common) <- c( + teal.reporter::teal_card(q_common), + "## Distribution Tests table" + ) + if (inherits(test_q_out, c("try-error", "error"))) { + within( + q_common, + test_table <- rtables::rtable(header = rtables::rheader("No data available in table"), rtables::rrow()) + ) + } else { + within(c(q_common, test_q_out), { test_table <- rtables::df_to_tt(test_table_data) }) } + }) + + decorated_output_dist_q <- srv_decorate_teal_data( + "d_density", + data = output_dist_q, + decorators = select_decorators(decorators, "histogram_plot"), + expr = quote(histogram_plot) + ) + + decorated_output_qq_q <- srv_decorate_teal_data( + "d_qq", + data = output_qq_q, + decorators = select_decorators(decorators, "qq_plot"), + expr = quote(qq_plot) + ) + + decorated_output_summary_q <- srv_decorate_teal_data( + "d_summary", + data = output_summary_q, + decorators = select_decorators(decorators, "summary_table"), + expr = quote(summary_table) ) - decorated_output_q <- srv_decorate_teal_data( - "decorators", - data = output_q, - decorators = decorators, + decorated_output_test_q <- srv_decorate_teal_data( + "d_test", + data = output_test_q, + decorators = select_decorators(decorators, "test_table"), expr = quote(test_table) ) - output_r <- reactive({ - obj <- req(decorated_output_q()) - DT::datatable(obj[["test_table_data"]]) + dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]]) + qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]]) + + summary_r <- reactive({ + q <- req(output_summary_q()) + + DT::datatable( + q[["summary_table_data"]], + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) }) - output$table <- DT::renderDataTable(output_r()) + output$summary_table <- DT::renderDataTable(summary_r()) - decorated_output_q - }) -} + tests_r <- reactive({ + q <- req(output_test_q()) + DT::datatable(q[["test_table_data"]]) + }) -.calc_dist_params <- function(x, dist) { - if (dist == "unif") { - return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) - } - tryCatch( - MASS::fitdistr(x, densfun = dist)$estimate, - error = function(e) c(param1 = NA_real_, param2 = NA_real_) - ) -} + pws1 <- teal.widgets::plot_with_settings_srv( + id = "hist_plot", + plot_r = dist_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) -.dist_param_list <- function(dist, param1, param2) { - dist_param_names <- list( - normal = c("mean", "sd"), - lognormal = c("meanlog", "sdlog"), - gamma = c("shape", "rate"), - unif = c("min", "max") - ) + pws2 <- teal.widgets::plot_with_settings_srv( + id = "qq_plot", + plot_r = qq_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + decorated_output_dist_dims_q <- set_chunk_dims(pws1, decorated_output_dist_q) - params <- list(param1, param2) - names(params) <- dist_param_names[[dist]] - params + decorated_output_qq_dims_q <- set_chunk_dims(pws2, decorated_output_qq_q) + + decorated_output_q <- reactive({ + tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement + test_q_out <- output_test_q() + + out_q <- switch(tab, + Histogram = decorated_output_dist_dims_q(), + QQplot = decorated_output_qq_dims_q() + ) + withCallingHandlers( + c(out_q, output_summary_q(), test_q_out), + warning = function(w) { + if (grepl("Restoring original content and adding only", conditionMessage(w))) { + invokeRestart("muffleWarning") + } + } + ) + }) + + output$t_stats <- DT::renderDataTable(tests_r()) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "R Code for distribution" + ) + decorated_output_q + }) } diff --git a/R/tm_g_distribution_old.R b/R/tm_g_distribution_old.R deleted file mode 100644 index a8997e1ec..000000000 --- a/R/tm_g_distribution_old.R +++ /dev/null @@ -1,1277 +0,0 @@ -#' @export -tm_g_distribution.default <- function(label = "Distribution Module", - dist_var, - strata_var = NULL, - group_var = NULL, - freq = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - bins = c(30L, 1L, 100L), - plot_height = c(600, 200, 2000), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { - message("Initializing tm_g_distribution") - - # Normalize the parameters - if (inherits(dist_var, "data_extract_spec")) dist_var <- list(dist_var) - if (inherits(strata_var, "data_extract_spec")) strata_var <- list(strata_var) - if (inherits(group_var, "data_extract_spec")) group_var <- list(group_var) - if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) - - # Start of assertions - checkmate::assert_string(label) - - checkmate::assert_list(dist_var, "data_extract_spec") - checkmate::assert_false(dist_var[[1L]]$select$multiple) - - checkmate::assert_list(strata_var, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(group_var, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_flag(freq) - ggtheme <- match.arg(ggtheme) - - plot_choices <- c("Histogram", "QQplot") - checkmate::assert_list(ggplot2_args, types = "ggplot2_args") - checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) - - if (length(bins) == 1) { - checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) - } else { - checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) - checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") - } - - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) - checkmate::assert_numeric( - plot_width[1], - lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" - ) - - checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - - assert_decorators(decorators, names = c("histogram_plot", "qq_plot")) - - # End of assertions - - # Make UI args - args <- as.list(environment()) - - data_extract_list <- list( - dist_var = dist_var, - strata_var = strata_var, - group_var = group_var - ) - - ans <- module( - label = label, - ui = ui_g_distribution.default, - server = srv_g_distribution.default, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), - transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) - ) - attr(ans, "teal_bookmarkable") <- TRUE - ans -} - -# UI function for the distribution module -ui_g_distribution.default <- function(id, ...) { - args <- list(...) - ns <- NS(id) - is_single_dataset_value <- teal.transform::is_single_dataset(args$dist_var, args$strata_var, args$group_var) - - teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - tabsetPanel( - id = ns("tabs"), - tabPanel("Histogram", teal.widgets::plot_with_settings_ui(id = ns("hist_plot"))), - tabPanel("QQplot", teal.widgets::plot_with_settings_ui(id = ns("qq_plot"))) - ), - tags$h3("Statistics Table"), - DT::dataTableOutput(ns("summary_table")), - tags$h3("Tests"), - conditionalPanel( - sprintf("input['%s'].length === 0", ns("dist_tests")), - div( - id = ns("please_select_a_test"), - "Please select a test" - ) - ), - conditionalPanel( - sprintf("input['%s'].length > 0", ns("dist_tests")), - DT::dataTableOutput(ns("t_stats")) - ) - ), - encoding = tags$div( - tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("dist_var", "strata_var")]), - teal.transform::data_extract_ui( - id = ns("dist_i"), - label = "Variable", - data_extract_spec = args$dist_var, - is_single_dataset = is_single_dataset_value - ), - if (!is.null(args$group_var)) { - tagList( - teal.transform::data_extract_ui( - id = ns("group_i"), - label = "Group by", - data_extract_spec = args$group_var, - is_single_dataset = is_single_dataset_value - ), - uiOutput(ns("scales_types_ui")) - ) - }, - if (!is.null(args$strata_var)) { - teal.transform::data_extract_ui( - id = ns("strata_i"), - label = "Stratify by", - data_extract_spec = args$strata_var, - is_single_dataset = is_single_dataset_value - ) - }, - bslib::accordion( - conditionalPanel( - condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), - bslib::accordion_panel( - "Histogram", - teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", args$bins, ticks = FALSE, step = 1), - shinyWidgets::prettyRadioButtons( - ns("main_type"), - label = "Plot Type:", - choices = c("Density", "Frequency"), - selected = if (!args$freq) "Density" else "Frequency", - bigger = FALSE, - inline = TRUE - ), - checkboxInput(ns("add_dens"), label = "Overlay Density", value = TRUE), - ui_decorate_teal_data( - ns("d_density"), - decorators = select_decorators(args$decorators, "histogram_plot") - ) - ) - ), - conditionalPanel( - condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), - bslib::accordion_panel( - "QQ Plot", - checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), - ui_decorate_teal_data( - ns("d_qq"), - decorators = select_decorators(args$decorators, "qq_plot") - ), - collapsed = FALSE - ) - ), - conditionalPanel( - condition = paste0("input['", ns("main_type"), "'] == 'Density'"), - bslib::accordion_panel( - "Theoretical Distribution", - teal.widgets::optionalSelectInput( - ns("t_dist"), - tags$div( - tagList( - "Distribution:", - bslib::tooltip( - icon("circle-info"), - tags$span( - "Default parameters are optimized with MASS::fitdistr function." - ) - ) - ) - ), - choices = c("normal", "lognormal", "gamma", "unif"), - selected = NULL, - multiple = FALSE - ), - numericInput(ns("dist_param1"), label = "param1", value = NULL), - numericInput(ns("dist_param2"), label = "param2", value = NULL), - tags$span(actionButton(ns("params_reset"), "Default params")), - collapsed = FALSE - ) - ), - bslib::accordion_panel( - title = "Tests", - teal.widgets::optionalSelectInput( - ns("dist_tests"), - "Tests:", - choices = c( - "Shapiro-Wilk", - if (!is.null(args$strata_var)) "t-test (two-samples, not paired)", - if (!is.null(args$strata_var)) "one-way ANOVA", - if (!is.null(args$strata_var)) "Fligner-Killeen", - if (!is.null(args$strata_var)) "F-test", - "Kolmogorov-Smirnov (one-sample)", - "Anderson-Darling (one-sample)", - "Cramer-von Mises (one-sample)", - if (!is.null(args$strata_var)) "Kolmogorov-Smirnov (two-samples)" - ), - selected = NULL - ) - ), - bslib::accordion_panel( - title = "Statistics Table", - sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2) - ), - bslib::accordion_panel( - title = "Plot settings", - selectInput( - inputId = ns("ggtheme"), - label = "Theme (by ggplot):", - choices = ggplot_themes, - selected = args$ggtheme, - multiple = FALSE - ) - ) - ) - ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), - pre_output = args$pre_output, - post_output = args$post_output - ) -} - -# Server function for the distribution module -srv_g_distribution.default <- function(id, - data, - dist_var, - strata_var, - group_var, - plot_height, - plot_width, - ggplot2_args, - decorators) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - - setBookmarkExclude("params_reset") - - ns <- session$ns - - rule_req <- function(value) { - if (isTRUE(input$dist_tests %in% c( - "Fligner-Killeen", - "t-test (two-samples, not paired)", - "F-test", - "Kolmogorov-Smirnov (two-samples)", - "one-way ANOVA" - ))) { - if (!shinyvalidate::input_provided(value)) { - "Please select stratify variable." - } - } - } - rule_dupl <- function(...) { - if (identical(input$dist_tests, "Fligner-Killeen")) { - strata <- selector_list()$strata_i()$select - group <- selector_list()$group_i()$select - if (isTRUE(strata == group)) { - "Please select different variables for strata and group." - } - } - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list( - dist_i = dist_var, - strata_i = strata_var, - group_i = group_var - ), - data, - select_validation_rule = list( - dist_i = shinyvalidate::sv_required("Please select a variable") - ), - filter_validation_rule = list( - strata_i = shinyvalidate::compose_rules( - rule_req, - rule_dupl - ), - group_i = rule_dupl - ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list, validator_names = "dist_i") - }) - - iv_r_dist <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators( - iv, selector_list, - validator_names = c("strata_i", "group_i") - ) - }) - rule_dist_1 <- function(value) { - if (!is.null(input$t_dist)) { - switch(input$t_dist, - "normal" = if (!shinyvalidate::input_provided(value)) "mean is required", - "lognormal" = if (!shinyvalidate::input_provided(value)) "meanlog is required", - "gamma" = { - if (!shinyvalidate::input_provided(value)) "shape is required" else if (value <= 0) "shape must be positive" - }, - "unif" = NULL - ) - } - } - rule_dist_2 <- function(value) { - if (!is.null(input$t_dist)) { - switch(input$t_dist, - "normal" = { - if (!shinyvalidate::input_provided(value)) { - "sd is required" - } else if (value < 0) { - "sd must be non-negative" - } - }, - "lognormal" = { - if (!shinyvalidate::input_provided(value)) { - "sdlog is required" - } else if (value < 0) { - "sdlog must be non-negative" - } - }, - "gamma" = { - if (!shinyvalidate::input_provided(value)) { - "rate is required" - } else if (value <= 0) { - "rate must be positive" - } - }, - "unif" = NULL - ) - } - } - - rule_dist <- function(value) { - if (isTRUE(input$tabs == "QQplot") || - isTRUE(input$dist_tests %in% c( - "Kolmogorov-Smirnov (one-sample)", - "Anderson-Darling (one-sample)", - "Cramer-von Mises (one-sample)" - ))) { - if (!shinyvalidate::input_provided(value)) { - "Please select the theoretical distribution." - } - } - } - - iv_dist <- shinyvalidate::InputValidator$new() - iv_dist$add_rule("t_dist", rule_dist) - iv_dist$add_rule("dist_param1", rule_dist_1) - iv_dist$add_rule("dist_param2", rule_dist_2) - iv_dist$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - - qenv <- reactive( - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes - ) - - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - output$scales_types_ui <- renderUI({ - if ("group_i" %in% names(selector_list()) && length(selector_list()$group_i()$filters[[1]]$selected) > 0) { - shinyWidgets::prettyRadioButtons( - ns("scales_type"), - label = "Scales:", - choices = c("Fixed", "Free"), - selected = "Fixed", - bigger = FALSE, - inline = TRUE - ) - } - }) - - observeEvent( - eventExpr = list( - input$t_dist, - input$params_reset, - selector_list()$dist_i()$select - ), - handlerExpr = { - params <- - if (length(input$t_dist) != 0) { - get_dist_params <- function(x, dist) { - if (dist == "unif") { - return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) - } - tryCatch( - MASS::fitdistr(x, densfun = dist)$estimate, - error = function(e) c(param1 = NA_real_, param2 = NA_real_) - ) - } - - ANL <- merged$anl_q_r()[["ANL"]] - round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) - } else { - c("param1" = NA_real_, "param2" = NA_real_) - } - - params_vals <- unname(params) - map_distr_nams <- list( - normal = c("mean", "sd"), - lognormal = c("meanlog", "sdlog"), - gamma = c("shape", "rate"), - unif = c("min", "max") - ) - - if (!is.null(input$t_dist) && input$t_dist %in% names(map_distr_nams)) { - params_names <- map_distr_nams[[input$t_dist]] - } else { - params_names <- names(params) - } - - updateNumericInput( - inputId = "dist_param1", - label = params_names[1], - value = restoreInput(ns("dist_param1"), params_vals[1]) - ) - updateNumericInput( - inputId = "dist_param2", - label = params_names[2], - value = restoreInput(ns("dist_param1"), params_vals[2]) - ) - }, - ignoreInit = TRUE - ) - - observeEvent(input$params_reset, { - updateActionButton(inputId = "params_reset", label = "Reset params") - }) - - merge_vars <- reactive({ - teal::validate_inputs(iv_r()) - - dist_var <- as.vector(merged$anl_input_r()$columns_source$dist_i) - s_var <- as.vector(merged$anl_input_r()$columns_source$strata_i) - g_var <- as.vector(merged$anl_input_r()$columns_source$group_i) - - dist_var_name <- if (length(dist_var)) as.name(dist_var) else NULL - s_var_name <- if (length(s_var)) as.name(s_var) else NULL - g_var_name <- if (length(g_var)) as.name(g_var) else NULL - - list( - dist_var = dist_var, - s_var = s_var, - g_var = g_var, - dist_var_name = dist_var_name, - s_var_name = s_var_name, - g_var_name = g_var_name - ) - }) - - # common qenv - common_q <- reactive({ - # Create a private stack for this function only. - - obj <- merged$anl_q_r() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Distribution Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - - ANL <- obj[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name - - roundn <- input$roundn - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - # isolated as dist_param1/dist_param2 already triggered the reactivity - t_dist <- isolate(input$t_dist) - - qenv <- obj - - if (length(g_var) > 0) { - validate( - need( - inherits(ANL[[g_var]], c("integer", "factor", "character")), - "Group by variable must be `factor`, `character`, or `integer`" - ) - ) - qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = ANL[[g_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[g_var]]), "NA"), - env = list(g_var = g_var) - ) - ) - } - - if (length(s_var) > 0) { - validate( - need( - inherits(ANL[[s_var]], c("integer", "factor", "character")), - "Stratify by variable must be `factor`, `character`, or `integer`" - ) - ) - - qenv <- teal.code::eval_code(qenv, 'library("forcats")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = ANL[[s_var]] <- forcats::fct_na_value_to_level(as.factor(ANL[[s_var]]), "NA"), - env = list(s_var = s_var) - ) - ) - } - - validate(need(is.numeric(ANL[[dist_var]]), "Please select a numeric variable.")) - teal::validate_has_data(ANL, 1, complete = TRUE) - - if (length(t_dist) != 0) { - map_distr_nams <- list( - normal = c("mean", "sd"), - lognormal = c("meanlog", "sdlog"), - gamma = c("shape", "rate"), - unif = c("min", "max") - ) - params_names_raw <- map_distr_nams[[t_dist]] - - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = { - params <- as.list(c(dist_param1, dist_param2)) - names(params) <- params_names_raw - }, - env = list( - dist_param1 = dist_param1, - dist_param2 = dist_param2, - params_names_raw = params_names_raw - ) - ) - ) - } - - if (length(s_var) == 0 && length(g_var) == 0) { - teal.code::eval_code( - qenv, - substitute( - expr = { - summary_table_data <- ANL %>% - dplyr::summarise( - min = round(min(dist_var_name, na.rm = TRUE), roundn), - median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), - mean = round(mean(dist_var_name, na.rm = TRUE), roundn), - max = round(max(dist_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - env = list( - dist_var_name = as.name(dist_var), - roundn = roundn - ) - ) - ) - } else { - teal.code::eval_code( - qenv, - substitute( - expr = { - strata_vars <- strata_vars_raw - summary_table_data <- ANL %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% - dplyr::summarise( - min = round(min(dist_var_name, na.rm = TRUE), roundn), - median = round(stats::median(dist_var_name, na.rm = TRUE), roundn), - mean = round(mean(dist_var_name, na.rm = TRUE), roundn), - max = round(max(dist_var_name, na.rm = TRUE), roundn), - sd = round(stats::sd(dist_var_name, na.rm = TRUE), roundn), - count = dplyr::n() - ) - }, - env = list( - dist_var_name = dist_var_name, - strata_vars_raw = c(g_var, s_var), - roundn = roundn - ) - ) - ) - } - }) - - # distplot qenv ---- - dist_q <- eventReactive( - eventExpr = { - common_q() - input$scales_type - input$main_type - input$bins - input$add_dens - is.null(input$ggtheme) - }, - valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name - t_dist <- input$t_dist - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - - scales_type <- input$scales_type - - ndensity <- 512 - main_type_var <- input$main_type - bins_var <- input$bins - add_dens_var <- input$add_dens - ggtheme <- input$ggtheme - - teal::validate_inputs(iv_dist) - - qenv <- common_q() - - m_type <- if (main_type_var == "Density") "density" else "count" - - plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 - ), - env = list( - m_type = as.name(m_type), bins_var = bins_var, dist_var_name = as.name(dist_var) - ) - ) - } else if (length(s_var) != 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes(dist_var_name, col = s_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), - bins = bins_var, alpha = 0.3 - ), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - dist_var_name = dist_var_name, - s_var = as.name(s_var), - s_var_name = s_var_name - ) - ) - } else if (length(s_var) == 0 && length(g_var) != 0) { - req(scales_type) - substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name)) + - ggplot2::geom_histogram( - position = "identity", ggplot2::aes(y = ggplot2::after_stat(m_type)), bins = bins_var, alpha = 0.3 - ) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - dist_var_name = dist_var_name, - g_var = g_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) - ) - ) - } else { - req(scales_type) - substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes(dist_var_name, col = s_var_name)) + - ggplot2::geom_histogram( - position = "identity", - ggplot2::aes(y = ggplot2::after_stat(m_type), fill = s_var), bins = bins_var, alpha = 0.3 - ) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - m_type = as.name(m_type), - bins_var = bins_var, - dist_var_name = dist_var_name, - g_var = g_var, - s_var = as.name(s_var), - g_var_name = g_var_name, - s_var_name = s_var_name, - scales_raw = tolower(scales_type) - ) - ) - } - - if (add_dens_var) { - plot_call <- substitute( - expr = plot_call + - ggplot2::stat_density( - ggplot2::aes(y = ggplot2::after_stat(const * m_type2)), - geom = "line", - position = "identity", - alpha = 0.5, - size = 2, - n = ndensity - ), - env = list( - plot_call = plot_call, - const = if (main_type_var == "Density") { - 1 - } else { - diff(range(qenv[["ANL"]][[dist_var]], na.rm = TRUE)) / bins_var - }, - m_type2 = if (main_type_var == "Density") as.name("density") else as.name("count"), - ndensity = ndensity - ) - ) - } - - if (length(t_dist) != 0 && main_type_var == "Density" && length(g_var) == 0 && length(s_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - df_params <- as.data.frame(append(params, list(name = t_dist))), - env = list(t_dist = t_dist) - ) - ) - datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) - label <- quote(tb) - - plot_call <- substitute( - expr = plot_call + ggpp::geom_table_npc( - data = data, - ggplot2::aes(npcx = x, npcy = y, label = label), - hjust = 0, vjust = 1, size = 4 - ), - env = list(plot_call = plot_call, data = datas, label = label) - ) - } - - if ( - length(s_var) == 0 && - length(g_var) == 0 && - main_type_var == "Density" && - length(t_dist) != 0 && - main_type_var == "Density" - ) { - map_dist <- stats::setNames( - c("dnorm", "dlnorm", "dgamma", "dunif"), - c("normal", "lognormal", "gamma", "unif") - ) - plot_call <- substitute( - expr = plot_call + stat_function( - data = data.frame(x = range(ANL[[dist_var]]), color = mapped_dist), - ggplot2::aes(x, color = color), - fun = mapped_dist_name, - n = ndensity, - size = 2, - args = params - ) + - ggplot2::scale_color_manual(values = stats::setNames("blue", mapped_dist), aesthetics = "color"), - env = list( - plot_call = plot_call, - dist_var = dist_var, - ndensity = ndensity, - mapped_dist = unname(map_dist[t_dist]), - mapped_dist_name = as.name(unname(map_dist[t_dist])) - ) - ) - } - - all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["Histogram"]], - user_default = ggplot2_args$default - ) - - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( - all_ggplot2_args, - ggtheme = ggtheme - ) - - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Histogram Plot") - teal.code::eval_code( - qenv, - substitute( - expr = histogram_plot <- plot_call, - env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) - ) - ) - } - ) - - # qqplot qenv ---- - qq_q <- eventReactive( - eventExpr = { - common_q() - input$scales_type - input$qq_line - is.null(input$ggtheme) - input$tabs - }, - valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - - scales_type <- input$scales_type - ggtheme <- input$ggtheme - - teal::validate_inputs(iv_r_dist(), iv_dist) - t_dist <- req(input$t_dist) # Not validated when tab is not selected - qenv <- common_q() - - plot_call <- if (length(s_var) == 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var)), - env = list(dist_var = dist_var) - ) - } else if (length(s_var) != 0 && length(g_var) == 0) { - substitute( - expr = ggplot2::ggplot(ANL, ggplot2::aes_string(sample = dist_var, color = s_var)), - env = list(dist_var = dist_var, s_var = s_var) - ) - } else if (length(s_var) == 0 && length(g_var) != 0) { - substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var)) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - dist_var = dist_var, - g_var = g_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) - ) - ) - } else { - substitute( - expr = ggplot2::ggplot(ANL[ANL[[g_var]] != "NA", ], ggplot2::aes_string(sample = dist_var, color = s_var)) + - ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), - env = list( - dist_var = dist_var, - g_var = g_var, - s_var = s_var, - g_var_name = g_var_name, - scales_raw = tolower(scales_type) - ) - ) - } - - map_dist <- stats::setNames( - c("qnorm", "qlnorm", "qgamma", "qunif"), - c("normal", "lognormal", "gamma", "unif") - ) - - plot_call <- substitute( - expr = plot_call + - ggplot2::stat_qq(distribution = mapped_dist, dparams = params), - env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) - ) - - if (length(t_dist) != 0 && length(g_var) == 0 && length(s_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("ggpp")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - df_params <- as.data.frame(append(params, list(name = t_dist))), - env = list(t_dist = t_dist) - ) - ) - datas <- quote(data.frame(x = 0.7, y = 1, tb = I(list(df_params = df_params)))) - label <- quote(tb) - - plot_call <- substitute( - expr = plot_call + - ggpp::geom_table_npc( - data = data, - ggplot2::aes(npcx = x, npcy = y, label = label), - hjust = 0, - vjust = 1, - size = 4 - ), - env = list( - plot_call = plot_call, - data = datas, - label = label - ) - ) - } - - if (isTRUE(input$qq_line)) { - plot_call <- substitute( - expr = plot_call + - ggplot2::stat_qq_line(distribution = mapped_dist, dparams = params), - env = list(plot_call = plot_call, mapped_dist = as.name(unname(map_dist[t_dist]))) - ) - } - - all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args[["QQplot"]], - user_default = ggplot2_args$default, - module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) - ) - - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( - all_ggplot2_args, - ggtheme = ggtheme - ) - - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## QQ Plot") - teal.code::eval_code( - qenv, - substitute( - expr = qq_plot <- plot_call, - env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) - ) - ) - } - ) - - # test qenv ---- - test_q <- eventReactive( - ignoreNULL = FALSE, - eventExpr = { - common_q() - input$dist_param1 - input$dist_param2 - input$dist_tests - }, - valueExpr = { - # Create a private stack for this function only. - ANL <- common_q()[["ANL"]] - - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name - - dist_param1 <- input$dist_param1 - dist_param2 <- input$dist_param2 - dist_tests <- input$dist_tests - t_dist <- input$t_dist - - req(dist_tests) - - teal::validate_inputs(iv_dist) - - if (length(s_var) > 0 || length(g_var) > 0) { - counts <- ANL %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% - dplyr::summarise(n = dplyr::n()) - - validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) - } - - - if (dist_tests %in% c( - "t-test (two-samples, not paired)", - "F-test", - "Kolmogorov-Smirnov (two-samples)" - )) { - if (length(g_var) == 0 && length(s_var) > 0) { - validate(need( - length(unique(ANL[[s_var]])) == 2, - "Please select stratify variable with 2 levels." - )) - } - if (length(g_var) > 0 && length(s_var) > 0) { - validate(need( - all(stats::na.omit(as.vector( - tapply(ANL[[s_var]], list(ANL[[g_var]]), function(x) length(unique(x))) == 2 - ))), - "Please select stratify variable with 2 levels, per each group." - )) - } - } - - map_dist <- stats::setNames( - c("pnorm", "plnorm", "pgamma", "punif"), - c("normal", "lognormal", "gamma", "unif") - ) - sks_args <- list( - test = quote(stats::ks.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), - groups = c(g_var, s_var) - ) - ssw_args <- list( - test = quote(stats::shapiro.test), - args = bquote(list(.[[.(dist_var)]])), - groups = c(g_var, s_var) - ) - mfil_args <- list( - test = quote(stats::fligner.test), - args = bquote(list(.[[.(dist_var)]], .[[.(s_var)]])), - groups = c(g_var) - ) - sad_args <- list( - test = quote(goftest::ad.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), - groups = c(g_var, s_var) - ) - scvm_args <- list( - test = quote(goftest::cvm.test), - args = bquote(append(list(.[[.(dist_var)]], .(map_dist[t_dist])), params)), - groups = c(g_var, s_var) - ) - manov_args <- list( - test = quote(stats::aov), - args = bquote(list(stats::formula(.(dist_var_name) ~ .(s_var_name)), .)), - groups = c(g_var) - ) - mt_args <- list( - test = quote(stats::t.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), - groups = c(g_var) - ) - mv_args <- list( - test = quote(stats::var.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), - groups = c(g_var) - ) - mks_args <- list( - test = quote(stats::ks.test), - args = bquote(unname(split(.[[.(dist_var)]], .[[.(s_var)]], drop = TRUE))), - groups = c(g_var) - ) - - tests_base <- switch(dist_tests, - "Kolmogorov-Smirnov (one-sample)" = sks_args, - "Shapiro-Wilk" = ssw_args, - "Fligner-Killeen" = mfil_args, - "one-way ANOVA" = manov_args, - "t-test (two-samples, not paired)" = mt_args, - "F-test" = mv_args, - "Kolmogorov-Smirnov (two-samples)" = mks_args, - "Anderson-Darling (one-sample)" = sad_args, - "Cramer-von Mises (one-sample)" = scvm_args - ) - - env <- list( - t_test = t_dist, - dist_var = dist_var, - g_var = g_var, - s_var = s_var, - args = tests_base$args, - groups = tests_base$groups, - test = tests_base$test, - dist_var_name = dist_var_name, - g_var_name = g_var_name, - s_var_name = s_var_name - ) - - qenv <- common_q() - - if (length(s_var) == 0 && length(g_var) == 0) { - qenv <- teal.code::eval_code(qenv, 'library("generics")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = { - test_table_data <- ANL %>% - dplyr::select(dist_var) %>% - with(., generics::glance(do.call(test, args))) %>% - dplyr::mutate_if(is.numeric, round, 3) - }, - env = env - ) - ) - } else { - qenv <- teal.code::eval_code(qenv, 'library("tidyr")') # nolint quotes - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = { - test_table_data <- ANL %>% - dplyr::select(dist_var, s_var, g_var) %>% - dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% - dplyr::do(tests = generics::glance(do.call(test, args))) %>% - tidyr::unnest(tests) %>% - dplyr::mutate_if(is.numeric, round, 3) - }, - env = env - ) - ) - } - } - ) - - # outputs ---- - output_dist_q <- reactive(c(common_q(), req(dist_q()))) - output_qq_q <- reactive(c(common_q(), req(qq_q()))) - - # Summary table listing has to be created separately to allow for qenv join - q_common <- common_q() - teal.reporter::teal_card(q_common) <- c( - teal.reporter::teal_card(q_common), - "## Statistics table" - ) - output_summary_q <- reactive({ - if (iv_r()$is_valid()) { - within(q_common, { - summary_table <- rtables::df_to_tt(summary_table_data) - }) - } else { - within( - q_common, - summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) - ) - } - }) - - output_test_q <- reactive({ - # wrapped in if since could lead into validate error - we do want to continue - test_q_out <- try(test_q(), silent = TRUE) - q_common <- common_q() - teal.reporter::teal_card(q_common) <- c( - teal.reporter::teal_card(q_common), - "## Distribution Tests table" - ) - if (inherits(test_q_out, c("try-error", "error"))) { - within( - q_common, - test_table <- rtables::rtable(header = rtables::rheader("No data available in table"), rtables::rrow()) - ) - } else { - within(c(q_common, test_q_out), { - test_table <- rtables::df_to_tt(test_table_data) - }) - } - }) - - decorated_output_dist_q <- srv_decorate_teal_data( - "d_density", - data = output_dist_q, - decorators = select_decorators(decorators, "histogram_plot"), - expr = quote(histogram_plot) - ) - - decorated_output_qq_q <- srv_decorate_teal_data( - "d_qq", - data = output_qq_q, - decorators = select_decorators(decorators, "qq_plot"), - expr = quote(qq_plot) - ) - - decorated_output_summary_q <- srv_decorate_teal_data( - "d_summary", - data = output_summary_q, - decorators = select_decorators(decorators, "summary_table"), - expr = quote(summary_table) - ) - - decorated_output_test_q <- srv_decorate_teal_data( - "d_test", - data = output_test_q, - decorators = select_decorators(decorators, "test_table"), - expr = quote(test_table) - ) - - dist_r <- reactive(req(decorated_output_dist_q())[["histogram_plot"]]) - qq_r <- reactive(req(decorated_output_qq_q())[["qq_plot"]]) - - summary_r <- reactive({ - q <- req(output_summary_q()) - - DT::datatable( - q[["summary_table_data"]], - options = list( - autoWidth = TRUE, - columnDefs = list(list(width = "200px", targets = "_all")) - ), - rownames = FALSE - ) - }) - - output$summary_table <- DT::renderDataTable(summary_r()) - - tests_r <- reactive({ - q <- req(output_test_q()) - DT::datatable(q[["test_table_data"]]) - }) - - pws1 <- teal.widgets::plot_with_settings_srv( - id = "hist_plot", - plot_r = dist_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) - - pws2 <- teal.widgets::plot_with_settings_srv( - id = "qq_plot", - plot_r = qq_r, - height = plot_height, - width = plot_width, - brushing = FALSE - ) - - decorated_output_dist_dims_q <- set_chunk_dims(pws1, decorated_output_dist_q) - - decorated_output_qq_dims_q <- set_chunk_dims(pws2, decorated_output_qq_q) - - decorated_output_q <- reactive({ - tab <- req(input$tabs) # tab is NULL upon app launch, hence will crash without this statement - test_q_out <- output_test_q() - - out_q <- switch(tab, - Histogram = decorated_output_dist_dims_q(), - QQplot = decorated_output_qq_dims_q() - ) - withCallingHandlers( - c(out_q, output_summary_q(), test_q_out), - warning = function(w) { - if (grepl("Restoring original content and adding only", conditionMessage(w))) { - invokeRestart("muffleWarning") - } - } - ) - }) - - output$t_stats <- DT::renderDataTable(tests_r()) - - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "R Code for distribution" - ) - decorated_output_q - }) -} diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R new file mode 100644 index 000000000..baff37348 --- /dev/null +++ b/R/tm_g_distribution_picks.R @@ -0,0 +1,1170 @@ +#' @export +tm_g_distribution.picks <- function(label = "Distribution Module", + dist_var = picks( + datasets(), + variables(where(is.numeric)), + values(selected = tidyselect::everything()) + ), + strata_var = NULL, + group_var = NULL, + freq = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + bins = c(30L, 1L, 100L), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_distribution") + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_class(dist_var, "picks") + if (isTRUE(attr(dist_var$variables, "multiple"))) { + warning("dist_var accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(dist_var$variables, "multiple") <- FALSE + } + checkmate::assert_class(strata_var, "picks", null.ok = TRUE) + checkmate::assert_class(group_var, "picks", null.ok = TRUE) + + checkmate::assert_flag(freq) + ggtheme <- match.arg(ggtheme) + + plot_choices <- c("Histogram", "QQplot") + + if (inherits(ggplot2_args, "ggplot2_args")) ggplot2_args <- list(default = ggplot2_args) + checkmate::assert_list(ggplot2_args, types = "ggplot2_args") + checkmate::assert_subset(names(ggplot2_args), c("default", plot_choices)) + + if (length(bins) == 1) { + checkmate::assert_numeric(bins, any.missing = FALSE, lower = 1) + } else { + checkmate::assert_numeric(bins, len = 3, any.missing = FALSE, lower = 1) + checkmate::assert_numeric(bins[1], lower = bins[2], upper = bins[3], .var.name = "bins") + } + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, names = c("histogram_plot", "qq_plot")) + + # End of assertions + + # Make UI args + args <- as.list(environment()) + + ans <- module( + label = label, + server = srv_g_distribution.picks, + ui = ui_g_distribution.picks, + ui_args = args[names(args) %in% names(formals(ui_g_distribution.picks))], + server_args = args[names(args) %in% names(formals(srv_g_distribution.picks))], , + transformators = transformators, + datanames = { + datanames <- datanames(list(dist_var, strata_var, group_var)) + if (length(datanames)) datanames else "all" + } + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + + +# UI function for the distribution module +ui_g_distribution.picks <- function(id, + strata_var, + dist_var, + group_var, + freq, + bins, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + + hist_elem <- .ui_hist( + ns("histogram_plot"), + bins = bins, + freq = freq, + decorators = select_decorators(decorators, "histogram_plot") + ) + qq_elem <- .ui_qq(ns("qq_plot"), decorators = select_decorators(decorators, "qq_plot")) + summary_table_elem <- .ui_summary_table(ns("summary_table"), select_decorators(decorators, "Statistics Table")) + test_table_elem <- .ui_test_table(ns("test_table"), + is_stratified = !is.null(strata_var), + decorators = select_decorators(decorators, "Test Table") + ) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + tabsetPanel( + id = ns("tabs"), + tabPanel("Histogram", hist_elem$output), + tabPanel("QQplot", qq_elem$output) + ), + bslib::card(summary_table_elem$output), + bslib::card(test_table_elem$output) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal::teal_nav_item( + label = tags$strong("Variable"), + teal.transform::module_input_ui(id = ns("dist_var"), spec = dist_var) + ), + if (!is.null(group_var)) { + tagList( + teal::teal_nav_item( + label = tags$strong("Group by:"), + teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) + ), + uiOutput(ns("scales_types_ui")) + ) + }, + if (!is.null(strata_var)) { + tagList( + teal::teal_nav_item( + label = tags$strong("Stratify by:"), + teal.transform::module_input_ui(id = ns("strata_var"), spec = strata_var) + ) + ) + }, + bslib::accordion( + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'Histogram'"), + bslib::accordion_panel(title = "Histogram", hist_elem$encodings, collapsed = FALSE) + ), + conditionalPanel( + condition = paste0("input['", ns("tabs"), "'] == 'QQplot'"), + bslib::accordion_panel(title = "QQ Plot", qq_elem$encodings, collapsed = FALSE) + ), + bslib::accordion_panel( # todo: hide ONLY when frequency is selected for histogram + "Theoretical Distribution", + teal.widgets::optionalSelectInput( + ns("t_dist"), + tags$div( + tagList( + "Distribution:", + bslib::tooltip( + icon("circle-info"), + tags$span("Default parameters are optimized with MASS::fitdistr function.") + ) + ) + ), + choices = c("normal", "lognormal", "gamma", "unif"), + selected = NULL, + multiple = FALSE + ), + conditionalPanel( + condition = paste0("input['", ns("t_dist"), "'] != null && input['", ns("t_dist"), "'] != ''"), + numericInput(ns("dist_param1"), label = "param1", value = NULL), + numericInput(ns("dist_param2"), label = "param2", value = NULL), + tags$span(actionButton(ns("params_reset"), "Default params")) + ), + collapsed = FALSE + ), + bslib::accordion_panel(title = "Tests", test_table_elem$encodings), + bslib::accordion_panel(title = "Statistics Table", summary_table_elem$encodings), + bslib::accordion_panel( + title = "Plot settings", + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the distribution module +srv_g_distribution.picks <- function(id, + data, + dist_var, + strata_var, + group_var, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + setBookmarkExclude("params_reset") + ns <- session$ns + + + selectors <- teal.transform::module_input_srv( + spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), + data = data + ) + + qenv <- reactive({ + validate_input( + inputId = "dist_var-variables-selected", + condition = length(selectors$dist_var()$variables$selected) == 1, + message = "Distribution variable must be selected." + ) + + obj <- req(data()) + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Distribution Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') + }) + + merged <- teal.transform::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + + validate_merged <- reactive({ + obj <- merged$data() + anl <- obj[["anl"]] + + validate_input( + inputId = "dist_var-variables-selected", + condition = is.numeric(anl[[merged$merge_vars()$dist_var]]), + message = "Distribution variable must be numeric." + ) + + if (length(merged$merge_vars()$group_var) > 0) { + validate_input( + "group_var-variables-selected", + condition = inherits(anl[[merged$merge_vars()$group_var]], c("integer", "factor", "character")), + message = "Group by variable must be `factor`, `character`, or `integer`" + ) + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), + group_var = merged$merge_vars()$group_var + ) + } + + if (length(merged$merge_vars()$strata_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = inherits(anl[[merged$merge_vars()$strata_var]], c("integer", "factor", "character")), + message = "Stratify by variable must be `factor`, `character`, or `integer`" + ) + + obj <- within(obj, library("forcats")) + obj <- within( + obj, + expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), + strata_var = merged$merge_vars()$strata_var + ) + } + + teal::validate_has_data(anl, 1, complete = TRUE) + + obj + }) + + output$scales_types_ui <- renderUI({ + validate_merged() + if (length(merged$merge_vars()$group_var) > 0) { + shinyWidgets::prettyRadioButtons( + ns("scales_type"), + label = "Scales:", + choices = c("Fixed", "Free"), + selected = "Fixed", + bigger = FALSE, + inline = TRUE + ) + } + }) + + observeEvent( + eventExpr = { + input$t_dist + input$params_reset + merged$merge_vars()$dist_var + }, + handlerExpr = { + params <- if (length(input$t_dist)) { + validate_merged() + req(merged$data()) + anl <- merged$data()[["anl"]] + round( + .calc_dist_params( + x = as.numeric(stats::na.omit(anl[[merged$merge_vars()$dist_var]])), + dist = input$t_dist + ), + 2 + ) + } else { + c("param1" = NA_real_, "param2" = NA_real_) + } + + updateNumericInput( + inputId = "dist_param1", + label = names(params)[1], + value = restoreInput(ns("dist_param1"), params[[1]]) + ) + updateNumericInput( + inputId = "dist_param2", + label = names(params)[2], + value = restoreInput(ns("dist_param1"), params[[2]]) + ) + }, + ignoreInit = TRUE + ) + + observeEvent(input$params_reset, { + updateActionButton(inputId = "params_reset", label = "Reset params") + }) + + validate_dist <- reactive({ + # Validate dist_param1 + if (!is.null(input$t_dist) && input$t_dist == "normal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "mean is required" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sd is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sd must be non-negative" + ) + } + if (!is.null(input$t_dist) && input$t_dist == "lognormal") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "meanlog is required" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "sdlog is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 >= 0, + message = "sdlog must be non-negative" + ) + } + if (!is.null(input$t_dist) && input$t_dist == "gamma") { + validate_input( + "dist_param1", + condition = !is.null(input$dist_param1) && !is.na(input$dist_param1), + message = "shape is required" + ) + validate_input( + "dist_param1", + condition = is.null(input$dist_param1) || is.na(input$dist_param1) || input$dist_param1 > 0, + message = "shape must be positive" + ) + validate_input( + "dist_param2", + condition = !is.null(input$dist_param2) && !is.na(input$dist_param2), + message = "rate is required" + ) + validate_input( + "dist_param2", + condition = is.null(input$dist_param2) || is.na(input$dist_param2) || input$dist_param2 > 0, + message = "rate must be positive" + ) + } + }) + + # outputs ---- + hist_output <- .srv_hist( + "histogram_plot", + data = reactive({ + validate_merged() + validate_dist() + merged$data() + }), + merge_vars = merged$merge_vars, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["Histogram"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "histogram_plot") + ) + + qq_output <- .srv_qq( + "qq_plot", + data = reactive({ + validate_merged() + validate_input( + "t_dist", + condition = !is.null(input$t_dist), + message = "QQ Plot requires Theoretical Distribution to be selected" + ) + validate_dist() + merged$data() + }), + merge_vars = merged$merge_vars, + t_dist = reactive(input$t_dist), + dist_param1 = reactive(input$dist_param1), + dist_param2 = reactive(input$dist_param2), + scales_type = reactive(input$scales_type), + ggtheme = reactive(input$ggtheme), + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args[["QQplot"]], + user_default = ggplot2_args$default, + module_plot = teal.widgets::ggplot2_args(labs = list(x = "theoretical", y = "sample")) + ), + decorators = select_decorators(decorators, "qq_plot") + ) + + summary_table_output <- .srv_summary_table( + "summary_table", + data = reactive({ + validate_merged() + merged$data() + }), + merge_vars = merged$merge_vars, + decorators = select_decorators(decorators, "Statistics Table") + ) + + test_q <- reactive({ + validate_merged() + obj <- merged$data() + anl <- obj[["anl"]] + s_var <- merged$merge_vars()$strata_var + g_var <- merged$merge_vars()$group_var + dist_test <- input$`test_table-dist_test` + + if (identical(dist_test, "Fligner-Killeen")) { + validate_input( + "strata_var-variables-selected", + condition = !isTRUE(s_var == g_var), + message = "Please select different variables for strata and group." + ) + } + + if (!is.null(dist_test) && dist_test %in% c( + "Fligner-Killeen", + "t-test (two-samples, not paired)", + "F-test", + "Kolmogorov-Smirnov (two-samples)", + "one-way ANOVA" + )) { + if (length(g_var) == 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = length(unique(anl[[s_var]])) == 2, + message = "Please select stratify variable with 2 levels." + ) + } else if (length(g_var) > 0 && length(s_var) > 0) { + validate_input( + "strata_var-variables-selected", + condition = all(stats::na.omit(as.vector( + tapply(anl[[s_var]], list(anl[[g_var]]), function(x) length(unique(x))) == 2 + ))), + message = "Please select stratify variable with 2 levels, per each group." + ) + } + } + validate_dist() + obj + }) + test_output <- .srv_test_table( + "test_table", + data = test_q, + merge_vars = merged$merge_vars, + t_dist = reactive(input$t_dist), + decorators = select_decorators(decorators, "Test Table") + ) + + # decorated_output_q <- reactive({ + # req(input$tabs, hist_output(), qq_output(), summary_table_output(), output_test_q()) + # test_q_out <- output_test_q() + + # # return everything except switch + # out_q <- switch(input$tabs, + # Histogram = hist_output(), + # QQplot = qq_output() + # ) + # out_q + # }) + + # Render R code. + # source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + # teal.widgets::verbatim_popup_srv( + # id = "rcode", + # verbatim_content = source_code_r, + # title = "R Code for distribution" + # ) + NULL + }) +} + + +.ui_hist <- function(id, bins, freq, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + teal.widgets::optionalSliderInputValMinMax(ns("bins"), "Bins", bins, ticks = FALSE, step = 1), + shinyWidgets::prettyRadioButtons( + ns("statistic"), + label = "Plot Type:", + choices = c("Density", "Frequency"), + selected = if (!freq) "Density" else "Frequency", + bigger = FALSE, + inline = TRUE + ), + checkboxInput(ns("add_density"), label = "Overlay Density", value = TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_hist <- function(id, + data, + merge_vars, + ggtheme, + scales_type, + t_dist, + dist_param1, + dist_param2, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + list( + data(), + input$bins, + input$statistic, + input$add_density, + dist_param1(), # don't observe t_dist as dist_param1 is changed by t_dist + dist_param2(), # don't observe t_dist as dist_param2 is changed by t_dist + scales_type() + ), + { + obj <- req(data()) + bins <- req(input$bins) + statistic <- if (req(input$statistic) == "Density") "density" else "count" + logger::log_debug(".srv_hist@1 Recalculating Histogram") + add_density <- input$add_density + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + ndensity <- 512 + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Histogram Plot") + + plot_call <- substitute( + expr = ggplot2::ggplot(anl, mapping = ggplot2::aes(d_var_name)) + + ggplot2::geom_histogram( + ggplot2::aes(y = ggplot2::after_stat(stat)), + position = "identity", bins = bins, alpha = 0.3 + ), + env = list(stat = as.name(statistic), bins = bins, d_var_name = as.name(d_var)) + ) + + if (length(s_var)) { + plot_call[[2]]$mapping$col <- as.name(s_var) + plot_call[[2]]$mapping$fill <- as.name(s_var) + } + + if (length(g_var)) { + req(scales_type()) + plot_call <- call( + "+", + plot_call, + substitute( + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales), + list(g_var_name = as.name(g_var), scales = tolower(scales_type())) + ) + ) + } + + if (add_density) { + plot_call <- substitute( + expr = plot_call + + ggplot2::stat_density( + ggplot2::aes(y = ggplot2::after_stat(const * stat)), + geom = "line", + position = "identity", + alpha = 0.5, + size = 2, + n = ndensity + ), + env = list( + plot_call = plot_call, + const = if (statistic == "density") { + 1 + } else { + diff(range(obj[["anl"]][[d_var]], na.rm = TRUE)) / bins + }, + stat = as.name(statistic), + ndensity = ndensity + ) + ) + } + + if (length(s_var) == 0 && length(g_var) == 0 && statistic == "density" && length(t_dist()) != 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes + param_list <- .dist_param_list(t_dist(), dist_param1(), dist_param2()) + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + + plot_call <- substitute( + expr = plot_call + + ggpp::geom_table_npc( + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 + ) + + stat_function( + data = data.frame(x = range(anl[[d_var]]), color = density_dist), + ggplot2::aes(x, color = color), + fun = density_dist_name, + n = ndensity, + size = 2, + args = param_list + ) + + ggplot2::scale_color_manual(values = stats::setNames("blue", density_dist), aesthetics = "color"), + env = list( + plot_call = plot_call, + d_var = d_var, + density_dist = unname(map_dist[t_dist()]), + density_dist_name = as.name(unname(map_dist[t_dist()])), + ndensity = ndensity, + nested_df = as.call( + c( + as.name("data.frame"), + param_list, + list(distribution = t_dist()) + ) + ), + param_list = param_list + ) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + + teal.code::eval_code( + obj, + substitute( + expr = histogram_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(histogram_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["histogram_plot"]]) + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_qq <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + checkboxInput(ns("qq_line"), label = "Add diagonal line(s)", TRUE), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = teal.widgets::plot_with_settings_ui(id = ns("plot")) + ) +} + +.srv_qq <- function(id, + data, + merge_vars, + t_dist, + dist_param1, + dist_param2, + scales_type, + ggtheme, + plot_height, + plot_width, + ggplot2_args, + decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + { + data() + t_dist() + dist_param1() + dist_param2() + input$qq_line + ggtheme() + }, + { + req(data(), merge_vars(), ggtheme(), t_dist()) + logger::log_debug(".srv_qq@1 Recalculating QQ Plot...") + obj <- data() + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## QQ Plot") + + plot_call <- substitute( + expr = ggplot2::ggplot(dataname, mapping = ggplot2::aes(sample = d_var_name)), + env = list( + dataname = if (length(g_var)) { + bquote(anl[anl[[.(g_var)]] != "NA", ]) + } else { + quote(anl) + }, + d_var_name = as.name(d_var) + ) + ) + if (length(s_var)) plot_call$mapping$color <- as.name(s_var) + if (length(g_var)) { + plot_call <- substitute( + plot_call + ggplot2::facet_wrap(~g_var_name, ncol = 1, scales = scales_raw), + list( + plot_call = plot_call, + g_var_name = as.name(g_var), + scales_raw = tolower(scales_type()) + ) + ) + } + + map_quantile_fun <- c(normal = "qnorm", lognormal = "qlnorm", gamma = "qgamma", unif = "qunif") + + plot_call <- substitute( + expr = plot_call + ggplot2::stat_qq(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) + ) + ) + + if (isTRUE(input$qq_line)) { + plot_call <- substitute( + expr = plot_call + ggplot2::stat_qq_line(distribution = quantile_fun, dparams = dparams), + env = list( + plot_call = plot_call, + quantile_fun = as.name(unname(map_quantile_fun[t_dist()])), + dparams = list(dist_param1(), dist_param2()) + ) + ) + } + + if (length(s_var) == 0 && length(g_var) == 0) { + req(dist_param1(), dist_param2()) + obj <- teal.code::eval_code(obj, 'library("ggpp")') # nolint quotes + plot_call <- substitute( + expr = plot_call + + ggpp::geom_table_npc( + data = data.frame(x = .7, y = 1, tb = I(list(nested_df))), + ggplot2::aes(npcx = x, npcy = y, label = tb), + hjust = 0, vjust = 1, size = 4 + ), + env = list( + plot_call = plot_call, + nested_df = as.call( + c( + as.name("data.frame"), + .dist_param_list(t_dist(), dist_param1(), dist_param2()), + list(distribution = t_dist()) + ) + ) + ) + ) + } + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args(ggplot2_args, ggtheme = ggtheme()) + teal.code::eval_code( + obj, + substitute( + expr = qq_plot <- plot_call, + env = list(plot_call = Reduce(function(x, y) call("+", x, y), c(plot_call, parsed_ggplot2_args))) + ) + ) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + decorators = decorators, + data = output_q, + expr = quote(qq_plot) + ) + + output_r <- reactive(req(decorated_output_q())[["qq_plot"]]) + + + pws <- teal.widgets::plot_with_settings_srv( + id = "plot", + plot_r = output_r, + height = plot_height, + width = plot_width, + brushing = FALSE + ) + + # set_chunk_dims(pws, decorated_output_q) + }) +} + +.ui_summary_table <- function(id, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + sliderInput(ns("roundn"), "Round to n digits", min = 0, max = 10, value = 2), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tags$div( + tags$h3("Statistics Table"), + DT::dataTableOutput(ns("summary_table")) + ) + ) +} + +.srv_summary_table <- function(id, data, merge_vars, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- reactive({ + obj <- req(data()) + roundn <- input$roundn + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Statistics table") + + obj <- if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + roundn = roundn + ) + } else { + within( + obj, + expr = { + summary_table_data <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(strata_vars))) %>% + dplyr::summarise( + min = round(min(d_var_name, na.rm = TRUE), roundn), + median = round(stats::median(d_var_name, na.rm = TRUE), roundn), + mean = round(mean(d_var_name, na.rm = TRUE), roundn), + max = round(max(d_var_name, na.rm = TRUE), roundn), + sd = round(stats::sd(d_var_name, na.rm = TRUE), roundn), + count = dplyr::n() + ) + }, + d_var_name = as.name(merge_vars()$dist_var), + strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), + roundn = roundn + ) + } + + within(obj, summary_table <- rtables::df_to_tt(summary_table_data)) + # if (iv_r()$is_valid()) { + + # } else { + # within( + # q_common, + # summary_table <- rtables::rtable(header = rtables::rheader(colnames(summary_table_data))) + # ) + # } + }) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(summary_table) + ) + + output_r <- reactive({ + obj <- req(decorated_output_q()) + + # todo: why summary_table_data is returned while summary_table is printed in a code? + DT::datatable( + obj[["summary_table_data"]], + options = list( + autoWidth = TRUE, + columnDefs = list(list(width = "200px", targets = "_all")) + ), + rownames = FALSE + ) + }) + + output$summary_table <- DT::renderDataTable(output_r()) + + decorated_output_q + }) +} + +.ui_test_table <- function(id, is_stratified, decorators) { + ns <- NS(id) + tagList( + encodings = tagList( + shinyWidgets::pickerInput( + ns("dist_test"), + "Tests:", + choices = c( + "Shapiro-Wilk", + if (is_stratified) "Kolmogorov-Smirnov (two-samples)", + if (is_stratified) "one-way ANOVA", + if (is_stratified) "Fligner-Killeen", + if (is_stratified) "F-test", + "Kolmogorov-Smirnov (one-sample)", + "Anderson-Darling (one-sample)", + "Cramer-von Mises (one-sample)", + if (is_stratified) "t-test (two-samples, not paired)" + ), + selected = NULL, + options = list( + `allow-clear` = TRUE, + "none-selected-text" = "- Nothing selected -" + ) + ), + ui_decorate_teal_data(ns("decorators"), decorators = decorators) + ), + output = tagList( + tags$h3("Tests"), + DT::dataTableOutput(ns("table")) + ) + ) +} + +.srv_test_table <- function(id, data, merge_vars, t_dist, decorators) { + moduleServer(id, function(input, output, session) { + output_q <- eventReactive( + ignoreNULL = FALSE, + eventExpr = { + data() + input$dist_test + }, + valueExpr = { + obj <- data() + anl <- obj[["anl"]] + d_var <- merge_vars()$dist_var + s_var <- merge_vars()$strata_var + g_var <- merge_vars()$group_var + d_var_name <- as.name(d_var) + s_var_name <- if (!is.null(s_var)) as.name(s_var) + g_var_name <- if (!is.null(g_var)) as.name(g_var) + + dist_test <- input$dist_test + validate(need(length(dist_test) > 0, "Please select a test")) + + if (length(s_var) > 0 || length(g_var) > 0) { + counts <- anl %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(c(s_var, g_var)))) %>% + dplyr::summarise(n = dplyr::n()) + validate(need(all(counts$n > 5), "Please select strata*group with at least 5 observation each.")) + } + + map_dist <- c(normal = "dnorm", lognormal = "dlnorm", gamma = "dgamma", unif = "dunif") + sks_args <- list( + test = quote(stats::ks.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + ssw_args <- list( + test = quote(stats::shapiro.test), + args = bquote(list(.[[.(d_var)]])), + groups = c(g_var, s_var) + ) + mfil_args <- list( + test = quote(stats::fligner.test), + args = bquote(list(.[[.(d_var)]], .[[.(s_var)]])), + groups = c(g_var) + ) + sad_args <- list( + test = quote(goftest::ad.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + scvm_args <- list( + test = quote(goftest::cvm.test), + args = bquote(append(list(.[[.(d_var)]], .(map_dist[t_dist()])), params)), + groups = c(g_var, s_var) + ) + manov_args <- list( + test = quote(stats::aov), + args = bquote(list(stats::formula(.(d_var_name) ~ .(s_var_name)), .)), + groups = c(g_var) + ) + mt_args <- list( + test = quote(stats::t.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mv_args <- list( + test = quote(stats::var.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + mks_args <- list( + test = quote(stats::ks.test), + args = bquote(unname(split(.[[.(d_var)]], .[[.(s_var)]], drop = TRUE))), + groups = c(g_var) + ) + + tests_base <- switch(dist_test, + "Kolmogorov-Smirnov (one-sample)" = sks_args, + "Shapiro-Wilk" = ssw_args, + "Fligner-Killeen" = mfil_args, + "one-way ANOVA" = manov_args, + "t-test (two-samples, not paired)" = mt_args, + "F-test" = mv_args, + "Kolmogorov-Smirnov (two-samples)" = mks_args, + "Anderson-Darling (one-sample)" = sad_args, + "Cramer-von Mises (one-sample)" = scvm_args + ) + + env <- list( + t_test = t_dist(), + d_var = d_var, + g_var = g_var, + s_var = s_var, + args = tests_base$args, + groups = tests_base$groups, + test = tests_base$test, + d_var_name = d_var_name, + g_var_name = g_var_name, + s_var_name = s_var_name + ) + + + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Distribution Tests table") + + obj <- if (length(s_var) == 0 && length(g_var) == 0) { + obj <- teal.code::eval_code(obj, 'library("generics")') # nolint quotes + teal.code::eval_code( + obj, + substitute( + expr = { + test_table_data <- anl %>% + dplyr::select(d_var) %>% + with(., generics::glance(do.call(test, args))) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } else { + # todo: why there is a `library` call when `tidyr::unnest` is prefixed, same for `generics` + obj <- teal.code::eval_code(obj, 'library("tidyr")') # nolint quotes + teal.code::eval_code( + obj, + substitute( + expr = { + test_table_data <- anl %>% + dplyr::select(d_var, s_var, g_var) %>% + dplyr::group_by_at(dplyr::vars(dplyr::any_of(groups))) %>% + dplyr::do(tests = generics::glance(do.call(test, args))) %>% + tidyr::unnest(tests) %>% + dplyr::mutate_if(is.numeric, round, 3) + }, + env = env + ) + ) + } + + within(obj, { + test_table <- rtables::df_to_tt(test_table_data) + }) + } + ) + + decorated_output_q <- srv_decorate_teal_data( + "decorators", + data = output_q, + decorators = decorators, + expr = quote(test_table) + ) + + output_r <- reactive({ + obj <- req(decorated_output_q()) + DT::datatable(obj[["test_table_data"]]) + }) + + output$table <- DT::renderDataTable(output_r()) + + decorated_output_q + }) +} + +.calc_dist_params <- function(x, dist) { + if (dist == "unif") { + return(stats::setNames(range(x, na.rm = TRUE), c("min", "max"))) + } + tryCatch( + MASS::fitdistr(x, densfun = dist)$estimate, + error = function(e) c(param1 = NA_real_, param2 = NA_real_) + ) +} + +.dist_param_list <- function(dist, param1, param2) { + dist_param_names <- list( + normal = c("mean", "sd"), + lognormal = c("meanlog", "sdlog"), + gamma = c("shape", "rate"), + unif = c("min", "max") + ) + + params <- list(param1, param2) + names(params) <- dist_param_names[[dist]] + params +} diff --git a/R/tm_g_response.R b/R/tm_g_response.R index 6d98b4714..5516cacf2 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -183,42 +183,48 @@ tm_g_response <- function(label = "Response Plot", } #' @export -tm_g_response.picks <- function(label = "Response Plot", - response, - x, - row_facet = NULL, - col_facet = NULL, - coord_flip = FALSE, - count_labels = TRUE, - rotate_xaxis_labels = FALSE, - freq = FALSE, - plot_height = c(600, 400, 5000), - plot_width = NULL, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_g_response.default <- function(label = "Response Plot", + response, + x, + row_facet = NULL, + col_facet = NULL, + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_response") + # Normalize the parameters + if (inherits(response, "data_extract_spec")) response <- list(response) + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(response, "picks") - if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(response$variables, "multiple") <- FALSE + checkmate::assert_list(response, types = "data_extract_spec") + if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) { + stop("'response' should not allow empty values") } + assert_single_selection(response) - checkmate::assert_class(x, "picks") - if (isTRUE(attr(x$variables, "multiple"))) { - warning("`x` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(x$variables, "multiple") <- FALSE + checkmate::assert_list(x, types = "data_extract_spec") + if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) { + stop("'x' should not allow empty values") } + assert_single_selection(x) - checkmate::assert_class(row_facet, "picks", null.ok = TRUE) - checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) checkmate::assert_flag(coord_flip) checkmate::assert_flag(count_labels) checkmate::assert_flag(rotate_xaxis_labels) @@ -241,85 +247,98 @@ tm_g_response.picks <- function(label = "Response Plot", assert_decorators(decorators, "plot") # End of assertions - + # Make UI args args <- as.list(environment()) + + data_extract_list <- list( + response = response, + x = x, + row_facet = row_facet, + col_facet = col_facet + ) + ans <- module( label = label, - ui = ui_g_response.picks, - server = srv_g_response.picks, - ui_args = args[names(args) %in% names(formals(ui_g_response.picks))], - server_args = args[names(args) %in% names(formals(srv_g_response.picks))], + server = srv_g_response.default, + ui = ui_g_response.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(response, x, row_facet, col_facet)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the response module -ui_g_response.picks <- function(id, - response, - x, - row_facet, - col_facet, - freq, - count_labels, - rotate_xaxis_labels, - coord_flip, - ggtheme, - pre_output, - post_output, - decorators) { +ui_g_response.default <- function(id, ...) { ns <- NS(id) + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) + teal.widgets::standard_layout( output = teal.widgets::white_small_well( teal.widgets::plot_with_settings_ui(id = ns("myplot")) ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Response variable"), - teal.transform::module_input_ui(id = ns("response"), spec = response) + teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]), + teal.transform::data_extract_ui( + id = ns("response"), + label = "Response variable", + data_extract_spec = args$response, + is_single_dataset = is_single_dataset_value ), - teal::teal_nav_item( - label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x) + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value ), - if (!is.null(row_facet)) { - teal::teal_nav_item( - label = tags$strong("Row facetting"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value ) }, - if (!is.null(col_facet)) { - teal::teal_nav_item( - label = tags$strong("Column facetting"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value ) }, shinyWidgets::radioGroupButtons( inputId = ns("freq"), label = NULL, choices = c("frequency", "density"), - selected = ifelse(freq, "frequency", "density"), + selected = ifelse(args$freq, "frequency", "density"), justified = TRUE ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - checkboxInput(ns("count_labels"), "Add count labels", value = count_labels), - checkboxInput(ns("coord_flip"), "Swap axes", value = coord_flip), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels), + checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = ggtheme, + selected = args$ggtheme, multiple = FALSE ) ) @@ -328,102 +347,116 @@ ui_g_response.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the response module -srv_g_response.picks <- function(id, - data, - response, - x, - row_facet, - col_facet, - plot_height, - plot_width, - ggplot2_args, - decorators) { +srv_g_response.default <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv( - spec = list( - response = response, - x = x, - row_facet = row_facet, - col_facet = col_facet - ), - data = data - ) + data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) + + rule_diff <- function(other) { + function(value) { + if (other %in% names(selector_list())) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } + } - validated_q <- reactive({ - validate_input( - inputId = "response-variables-selected", - condition = !is.null(selectors$response()$variables$selected), - message = "A `response` variable needs to be selected." - ) - validate_input( - inputId = "x-variables-selected", - condition = !is.null(selectors$x()$variables$selected), - message = "A `x` variable needs to be selected." - ) - validate_input( - inputId = c("response-variables-selected", "x-variables-selected"), - condition = !any(selectors$response()$variables$selected %in% selectors$x()$variables$selected), - message = "Response and X variables must be different." - ) - validate_input( - inputId = "row_facet-variables-selected", - condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, - message = "Only single Row Facetting variable is allowed." - ) - validate_input( - inputId = "col_facet-variables-selected", - condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, - message = "Only single Column Facetting variable is allowed." - ) - validate_input( - inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), - condition = is.null(row_facet) || is.null(col_facet) || - !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), - message = "Row and Column Facetting variables must be different." + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + response = shinyvalidate::sv_required("Please define a column for the response variable"), + x = shinyvalidate::sv_required("Please define a column for X variable"), + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", + rule_diff("col_facet") + ), + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", + rule_diff("row_facet") + ) ) + ) - obj <- req(data()) - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Response Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme")) + teal.transform::compose_and_enable_validators(iv, selector_list) }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data + ) + qenv <- reactive( + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + ) - output_q <- reactive({ - validate_input( - inputId = "ggtheme", - condition = length(input$ggtheme) > 0, - message = "Row and Col Facetting variables must be different." - ) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) - qenv <- merged$data() - anl <- qenv[["anl"]] - response_var <- merged$merge_vars()$response - x_var <- merged$merge_vars()$x + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) - validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) - validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) - teal::validate_has_data(anl, 10) - teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) + output_q <- reactive({ + teal::validate_inputs(iv_r()) - row_facet_var <- merged$merge_vars()$row_facet - col_facet_var <- merged$merge_vars()$col_facet + qenv <- merged$anl_q_r() + teal.reporter::teal_card(qenv) <- + c( + teal.reporter::teal_card("# Response Plot"), + teal.reporter::teal_card(qenv), + teal.reporter::teal_card("## Module's code") + ) + ANL <- qenv[["ANL"]] + resp_var <- as.vector(merged$anl_input_r()$columns_source$response) + x <- as.vector(merged$anl_input_r()$columns_source$x) + + validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) + validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) + teal::validate_has_data(ANL, 10) + teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) + + row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$row_facet) + } + col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$col_facet) + } freq <- input$freq == "frequency" swap_axes <- input$coord_flip @@ -433,43 +466,54 @@ srv_g_response.picks <- function(id, arg_position <- if (freq) "stack" else "fill" + rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) + colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) + resp_cl <- as.name(resp_var) + x_cl <- as.name(x) + if (swap_axes) { - qenv <- within( + qenv <- teal.code::eval_code( qenv, - expr = anl[[x_var]] <- with(anl, forcats::fct_rev(x_cl)), - x_var = x_var, - x_cl = as.name(x_var) + substitute( + expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), + env = list(x = x, x_cl = x_cl) + ) ) } - qenv <- within( + qenv <- teal.code::eval_code( qenv, - expr = { - anl[[response_var]] <- factor(anl[[response_var]]) - - anl2 <- anl %>% - dplyr::group_by_at(dplyr::vars(x_cl, response_cl, row_facet_cl, col_facet_cl)) %>% - dplyr::summarise(ns = dplyr::n()) %>% - dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% - dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)) - - anl3 <- anl %>% - dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% - dplyr::summarise(ns = dplyr::n()) - }, - response_var = response_var, - response_cl = as.name(response_var), - x_cl = as.name(x_var), - row_facet_cl = if (length(row_facet_var)) as.name(row_facet_var), - col_facet_cl = if (length(col_facet_var)) as.name(col_facet_var) - ) + substitute( + expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), + env = list(resp_var = resp_var) + ) + ) %>% + # rowf and colf will be a NULL if not set by a user + teal.code::eval_code( + substitute( + expr = ANL2 <- ANL %>% + dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% + dplyr::summarise(ns = dplyr::n()) %>% + dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% + dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), + env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = ANL3 <- ANL %>% + dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% + dplyr::summarise(ns = dplyr::n()), + env = list(x_cl = x_cl, rowf = rowf, colf = colf) + ) + ) plot_call <- substitute( - expr = ggplot2::ggplot(anl2, ggplot2::aes(x = x_cl, y = ns)) + - ggplot2::geom_bar(ggplot2::aes(fill = response_cl), stat = "identity", position = arg_position), + expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) + + ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position), env = list( - x_cl = as.name(x_var), - response_cl = as.name(response_var), + x_cl = x_cl, + resp_cl = resp_cl, arg_position = arg_position ) ) @@ -485,23 +529,23 @@ srv_g_response.picks <- function(id, plot_call <- substitute( expr = plot_call + ggplot2::geom_text( - data = anl2, - ggplot2::aes(label = ns, x = x_cl, y = ns, group = response_cl), + data = ANL2, + ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl), col = "white", vjust = "middle", hjust = "middle", position = position_anl2_value ) + ggplot2::geom_text( - data = anl3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), + data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), hjust = hjust_value, vjust = vjust_value, position = position_anl3_value ), env = list( plot_call = plot_call, - x_cl = as.name(x_var), - response_cl = as.name(response_var), + x_cl = x_cl, + resp_cl = resp_cl, hjust_value = if (swap_axes) "left" else "middle", vjust_value = if (swap_axes) "middle" else -1, position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. @@ -515,7 +559,7 @@ srv_g_response.picks <- function(id, plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) } - facet_cl <- facet_ggplot_call(row_facet_var, col_facet_var) + facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) if (!is.null(facet_cl)) { plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) @@ -523,9 +567,9 @@ srv_g_response.picks <- function(id, dev_ggplot2_args <- teal.widgets::ggplot2_args( labs = list( - x = varname_w_label(x_var, anl), - y = varname_w_label(response_var, anl, prefix = "Proportion of "), - fill = varname_w_label(response_var, anl) + x = varname_w_label(x, ANL), + y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), + fill = varname_w_label(resp_var, ANL) ), theme = list(legend.position = "bottom") ) diff --git a/R/tm_g_response_old.R b/R/tm_g_response_old.R deleted file mode 100644 index ae92f0b39..000000000 --- a/R/tm_g_response_old.R +++ /dev/null @@ -1,449 +0,0 @@ -#' @export -tm_g_response.default <- function(label = "Response Plot", - response, - x, - row_facet = NULL, - col_facet = NULL, - coord_flip = FALSE, - count_labels = TRUE, - rotate_xaxis_labels = FALSE, - freq = FALSE, - plot_height = c(600, 400, 5000), - plot_width = NULL, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - ggplot2_args = teal.widgets::ggplot2_args(), - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { - message("Initializing tm_g_response") - - # Normalize the parameters - if (inherits(response, "data_extract_spec")) response <- list(response) - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) - - # Start of assertions - checkmate::assert_string(label) - - checkmate::assert_list(response, types = "data_extract_spec") - if (!all(vapply(response, function(x) !("" %in% x$select$choices), logical(1)))) { - stop("'response' should not allow empty values") - } - assert_single_selection(response) - - checkmate::assert_list(x, types = "data_extract_spec") - if (!all(vapply(x, function(x) !("" %in% x$select$choices), logical(1)))) { - stop("'x' should not allow empty values") - } - assert_single_selection(x) - - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_flag(coord_flip) - checkmate::assert_flag(count_labels) - checkmate::assert_flag(rotate_xaxis_labels) - checkmate::assert_flag(freq) - - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) - checkmate::assert_numeric( - plot_width[1], - lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" - ) - - ggtheme <- match.arg(ggtheme) - checkmate::assert_class(ggplot2_args, "ggplot2_args") - - checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - - assert_decorators(decorators, "plot") - # End of assertions - - # Make UI args - args <- as.list(environment()) - - data_extract_list <- list( - response = response, - x = x, - row_facet = row_facet, - col_facet = col_facet - ) - - ans <- module( - label = label, - server = srv_g_response.default, - ui = ui_g_response.default, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), - transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) - ) - attr(ans, "teal_bookmarkable") <- TRUE - ans -} - -# UI function for the response module -ui_g_response.default <- function(id, ...) { - ns <- NS(id) - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$response, args$x, args$row_facet, args$col_facet) - - teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - teal.widgets::plot_with_settings_ui(id = ns("myplot")) - ), - encoding = tags$div( - tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("response", "x", "row_facet", "col_facet")]), - teal.transform::data_extract_ui( - id = ns("response"), - label = "Response variable", - data_extract_spec = args$response, - is_single_dataset = is_single_dataset_value - ), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value - ), - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value - ) - }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value - ) - }, - shinyWidgets::radioGroupButtons( - inputId = ns("freq"), - label = NULL, - choices = c("frequency", "density"), - selected = ifelse(args$freq, "frequency", "density"), - justified = TRUE - ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), - bslib::accordion( - open = TRUE, - bslib::accordion_panel( - title = "Plot settings", - checkboxInput(ns("count_labels"), "Add count labels", value = args$count_labels), - checkboxInput(ns("coord_flip"), "Swap axes", value = args$coord_flip), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), - selectInput( - inputId = ns("ggtheme"), - label = "Theme (by ggplot):", - choices = ggplot_themes, - selected = args$ggtheme, - multiple = FALSE - ) - ) - ) - ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), - pre_output = args$pre_output, - post_output = args$post_output - ) -} - -# Server function for the response module -srv_g_response.default <- function(id, - data, - response, - x, - row_facet, - col_facet, - plot_height, - plot_width, - ggplot2_args, - decorators) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - - data_extract <- list(response = response, x = x, row_facet = row_facet, col_facet = col_facet) - - rule_diff <- function(other) { - function(value) { - if (other %in% names(selector_list())) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - } - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - response = shinyvalidate::sv_required("Please define a column for the response variable"), - x = shinyvalidate::sv_required("Please define a column for X variable"), - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (length(.) > 1) "There must be 1 or no row facetting variable.", - rule_diff("col_facet") - ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - ~ if (length(.) > 1) "There must be 1 or no column facetting variable.", - rule_diff("row_facet") - ) - ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("ggtheme", shinyvalidate::sv_required("Please select a theme")) - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data - ) - - qenv <- reactive( - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes - ) - - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - output_q <- reactive({ - teal::validate_inputs(iv_r()) - - qenv <- merged$anl_q_r() - teal.reporter::teal_card(qenv) <- - c( - teal.reporter::teal_card("# Response Plot"), - teal.reporter::teal_card(qenv), - teal.reporter::teal_card("## Module's code") - ) - ANL <- qenv[["ANL"]] - resp_var <- as.vector(merged$anl_input_r()$columns_source$response) - x <- as.vector(merged$anl_input_r()$columns_source$x) - - validate(need(is.factor(ANL[[resp_var]]), "Please select a factor variable as the response.")) - validate(need(is.factor(ANL[[x]]), "Please select a factor variable as the X-Variable.")) - teal::validate_has_data(ANL, 10) - teal::validate_has_data(ANL[, c(resp_var, x)], 10, complete = TRUE, allow_inf = FALSE) - - row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$row_facet) - } - col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$col_facet) - } - - freq <- input$freq == "frequency" - swap_axes <- input$coord_flip - counts <- input$count_labels - rotate_xaxis_labels <- input$rotate_xaxis_labels - ggtheme <- input$ggtheme - - arg_position <- if (freq) "stack" else "fill" - - rowf <- if (length(row_facet_name) != 0) as.name(row_facet_name) - colf <- if (length(col_facet_name) != 0) as.name(col_facet_name) - resp_cl <- as.name(resp_var) - x_cl <- as.name(x) - - if (swap_axes) { - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = ANL[[x]] <- with(ANL, forcats::fct_rev(x_cl)), - env = list(x = x, x_cl = x_cl) - ) - ) - } - - qenv <- teal.code::eval_code( - qenv, - substitute( - expr = ANL[[resp_var]] <- factor(ANL[[resp_var]]), - env = list(resp_var = resp_var) - ) - ) %>% - # rowf and colf will be a NULL if not set by a user - teal.code::eval_code( - substitute( - expr = ANL2 <- ANL %>% - dplyr::group_by_at(dplyr::vars(x_cl, resp_cl, rowf, colf)) %>% - dplyr::summarise(ns = dplyr::n()) %>% - dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% - dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)), - env = list(x_cl = x_cl, resp_cl = resp_cl, rowf = rowf, colf = colf) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = ANL3 <- ANL %>% - dplyr::group_by_at(dplyr::vars(x_cl, rowf, colf)) %>% - dplyr::summarise(ns = dplyr::n()), - env = list(x_cl = x_cl, rowf = rowf, colf = colf) - ) - ) - - plot_call <- substitute( - expr = ggplot2::ggplot(ANL2, ggplot2::aes(x = x_cl, y = ns)) + - ggplot2::geom_bar(ggplot2::aes(fill = resp_cl), stat = "identity", position = arg_position), - env = list( - x_cl = x_cl, - resp_cl = resp_cl, - arg_position = arg_position - ) - ) - - if (!freq) { - plot_call <- substitute( - plot_call + ggplot2::expand_limits(y = c(0, 1.1)), - env = list(plot_call = plot_call) - ) - } - - if (counts) { - plot_call <- substitute( - expr = plot_call + - ggplot2::geom_text( - data = ANL2, - ggplot2::aes(label = ns, x = x_cl, y = ns, group = resp_cl), - col = "white", - vjust = "middle", - hjust = "middle", - position = position_anl2_value - ) + - ggplot2::geom_text( - data = ANL3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), - hjust = hjust_value, - vjust = vjust_value, - position = position_anl3_value - ), - env = list( - plot_call = plot_call, - x_cl = x_cl, - resp_cl = resp_cl, - hjust_value = if (swap_axes) "left" else "middle", - vjust_value = if (swap_axes) "middle" else -1, - position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. - anl3_y = if (!freq) 1.1 else as.name("ns"), - position_anl3_value = if (!freq) "fill" else "stack" - ) - ) - } - - if (swap_axes) { - plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) - } - - facet_cl <- facet_ggplot_call(row_facet_name, col_facet_name) - - if (!is.null(facet_cl)) { - plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) - } - - dev_ggplot2_args <- teal.widgets::ggplot2_args( - labs = list( - x = varname_w_label(x, ANL), - y = varname_w_label(resp_var, ANL, prefix = "Proportion of "), - fill = varname_w_label(resp_var, ANL) - ), - theme = list(legend.position = "bottom") - ) - - if (rotate_xaxis_labels) { - dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) - } - - all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( - user_plot = ggplot2_args, - module_plot = dev_ggplot2_args - ) - - parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( - all_ggplot2_args, - ggtheme = ggtheme - ) - - plot_call <- substitute(expr = { - plot <- plot_call + labs + ggthemes + themes - }, env = list( - plot_call = plot_call, - labs = parsed_ggplot2_args$labs, - themes = parsed_ggplot2_args$theme, - ggthemes = parsed_ggplot2_args$ggtheme - )) - - teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") - teal.code::eval_code(qenv, plot_call) - }) - - decorated_output_plot_q <- srv_decorate_teal_data( - id = "decorator", - data = output_q, - decorators = select_decorators(decorators, "plot"), - expr = quote(plot) - ) - - plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) - - # Insert the plot into a plot_with_settings module from teal.widgets - pws <- teal.widgets::plot_with_settings_srv( - id = "myplot", - plot_r = plot_r, - height = plot_height, - width = plot_width - ) - - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) - - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Show R Code for Response" - ) - decorated_output_dims_q - }) -} diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R new file mode 100644 index 000000000..90c0823b6 --- /dev/null +++ b/R/tm_g_response_picks.R @@ -0,0 +1,405 @@ +#' @export +tm_g_response.picks <- function(label = "Response Plot", + response, + x, + row_facet = NULL, + col_facet = NULL, + coord_flip = FALSE, + count_labels = TRUE, + rotate_xaxis_labels = FALSE, + freq = FALSE, + plot_height = c(600, 400, 5000), + plot_width = NULL, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + ggplot2_args = teal.widgets::ggplot2_args(), + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { + message("Initializing tm_g_response") + + # Start of assertions + checkmate::assert_string(label) + + checkmate::assert_class(response, "picks") + if (isTRUE(attr(response$variables, "multiple"))) { + warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(response$variables, "multiple") <- FALSE + } + + checkmate::assert_class(x, "picks") + if (isTRUE(attr(x$variables, "multiple"))) { + warning("`x` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(x$variables, "multiple") <- FALSE + } + + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + checkmate::assert_flag(coord_flip) + checkmate::assert_flag(count_labels) + checkmate::assert_flag(rotate_xaxis_labels) + checkmate::assert_flag(freq) + + checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) + checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") + checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) + checkmate::assert_numeric( + plot_width[1], + lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" + ) + + ggtheme <- match.arg(ggtheme) + checkmate::assert_class(ggplot2_args, "ggplot2_args") + + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + + assert_decorators(decorators, "plot") + # End of assertions + + + args <- as.list(environment()) + ans <- module( + label = label, + ui = ui_g_response.picks, + server = srv_g_response.picks, + ui_args = args[names(args) %in% names(formals(ui_g_response.picks))], + server_args = args[names(args) %in% names(formals(srv_g_response.picks))], + transformators = transformators, + datanames = { + datanames <- datanames(list(response, x, row_facet, col_facet)) + if (length(datanames)) datanames else "all" + } + ) + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the response module +ui_g_response.picks <- function(id, + response, + x, + row_facet, + col_facet, + freq, + count_labels, + rotate_xaxis_labels, + coord_flip, + ggtheme, + pre_output, + post_output, + decorators) { + ns <- NS(id) + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + teal.widgets::plot_with_settings_ui(id = ns("myplot")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal::teal_nav_item( + label = tags$strong("Response variable"), + teal.transform::module_input_ui(id = ns("response"), spec = response) + ), + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x) + ), + if (!is.null(row_facet)) { + teal::teal_nav_item( + label = tags$strong("Row facetting"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) + ) + }, + if (!is.null(col_facet)) { + teal::teal_nav_item( + label = tags$strong("Column facetting"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) + ) + }, + shinyWidgets::radioGroupButtons( + inputId = ns("freq"), + label = NULL, + choices = c("frequency", "density"), + selected = ifelse(freq, "frequency", "density"), + justified = TRUE + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Plot settings", + checkboxInput(ns("count_labels"), "Add count labels", value = count_labels), + checkboxInput(ns("coord_flip"), "Swap axes", value = coord_flip), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + selectInput( + inputId = ns("ggtheme"), + label = "Theme (by ggplot):", + choices = ggplot_themes, + selected = ggtheme, + multiple = FALSE + ) + ) + ) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the response module +srv_g_response.picks <- function(id, + data, + response, + x, + row_facet, + col_facet, + plot_height, + plot_width, + ggplot2_args, + decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::module_input_srv( + spec = list( + response = response, + x = x, + row_facet = row_facet, + col_facet = col_facet + ), + data = data + ) + + validated_q <- reactive({ + validate_input( + inputId = "response-variables-selected", + condition = !is.null(selectors$response()$variables$selected), + message = "A `response` variable needs to be selected." + ) + validate_input( + inputId = "x-variables-selected", + condition = !is.null(selectors$x()$variables$selected), + message = "A `x` variable needs to be selected." + ) + validate_input( + inputId = c("response-variables-selected", "x-variables-selected"), + condition = !any(selectors$response()$variables$selected %in% selectors$x()$variables$selected), + message = "Response and X variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." + ) + + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Response Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + }) + + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + + + output_q <- reactive({ + validate_input( + inputId = "ggtheme", + condition = length(input$ggtheme) > 0, + message = "Row and Col Facetting variables must be different." + ) + + qenv <- merged$data() + anl <- qenv[["anl"]] + response_var <- merged$merge_vars()$response + x_var <- merged$merge_vars()$x + + validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) + validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) + + row_facet_var <- merged$merge_vars()$row_facet + col_facet_var <- merged$merge_vars()$col_facet + + freq <- input$freq == "frequency" + swap_axes <- input$coord_flip + counts <- input$count_labels + rotate_xaxis_labels <- input$rotate_xaxis_labels + ggtheme <- input$ggtheme + + arg_position <- if (freq) "stack" else "fill" + + if (swap_axes) { + qenv <- within( + qenv, + expr = anl[[x_var]] <- with(anl, forcats::fct_rev(x_cl)), + x_var = x_var, + x_cl = as.name(x_var) + ) + } + + qenv <- within( + qenv, + expr = { + anl[[response_var]] <- factor(anl[[response_var]]) + + anl2 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, response_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::mutate(sums = sum(ns), percent = round(ns / sums * 100, 1)) + + anl3 <- anl %>% + dplyr::group_by_at(dplyr::vars(x_cl, row_facet_cl, col_facet_cl)) %>% + dplyr::summarise(ns = dplyr::n()) + }, + response_var = response_var, + response_cl = as.name(response_var), + x_cl = as.name(x_var), + row_facet_cl = if (length(row_facet_var)) as.name(row_facet_var), + col_facet_cl = if (length(col_facet_var)) as.name(col_facet_var) + ) + + plot_call <- substitute( + expr = ggplot2::ggplot(anl2, ggplot2::aes(x = x_cl, y = ns)) + + ggplot2::geom_bar(ggplot2::aes(fill = response_cl), stat = "identity", position = arg_position), + env = list( + x_cl = as.name(x_var), + response_cl = as.name(response_var), + arg_position = arg_position + ) + ) + + if (!freq) { + plot_call <- substitute( + plot_call + ggplot2::expand_limits(y = c(0, 1.1)), + env = list(plot_call = plot_call) + ) + } + + if (counts) { + plot_call <- substitute( + expr = plot_call + + ggplot2::geom_text( + data = anl2, + ggplot2::aes(label = ns, x = x_cl, y = ns, group = response_cl), + col = "white", + vjust = "middle", + hjust = "middle", + position = position_anl2_value + ) + + ggplot2::geom_text( + data = anl3, ggplot2::aes(label = ns, x = x_cl, y = anl3_y), + hjust = hjust_value, + vjust = vjust_value, + position = position_anl3_value + ), + env = list( + plot_call = plot_call, + x_cl = as.name(x_var), + response_cl = as.name(response_var), + hjust_value = if (swap_axes) "left" else "middle", + vjust_value = if (swap_axes) "middle" else -1, + position_anl2_value = if (!freq) quote(position_fill(0.5)) else quote(position_stack(0.5)), # nolint: line_length. + anl3_y = if (!freq) 1.1 else as.name("ns"), + position_anl3_value = if (!freq) "fill" else "stack" + ) + ) + } + + if (swap_axes) { + plot_call <- substitute(plot_call + coord_flip(), env = list(plot_call = plot_call)) + } + + facet_cl <- facet_ggplot_call(row_facet_var, col_facet_var) + + if (!is.null(facet_cl)) { + plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) + } + + dev_ggplot2_args <- teal.widgets::ggplot2_args( + labs = list( + x = varname_w_label(x_var, anl), + y = varname_w_label(response_var, anl, prefix = "Proportion of "), + fill = varname_w_label(response_var, anl) + ), + theme = list(legend.position = "bottom") + ) + + if (rotate_xaxis_labels) { + dev_ggplot2_args$theme[["axis.text.x"]] <- quote(ggplot2::element_text(angle = 45, hjust = 1)) + } + + all_ggplot2_args <- teal.widgets::resolve_ggplot2_args( + user_plot = ggplot2_args, + module_plot = dev_ggplot2_args + ) + + parsed_ggplot2_args <- teal.widgets::parse_ggplot2_args( + all_ggplot2_args, + ggtheme = ggtheme + ) + + plot_call <- substitute(expr = { + plot <- plot_call + labs + ggthemes + themes + }, env = list( + plot_call = plot_call, + labs = parsed_ggplot2_args$labs, + themes = parsed_ggplot2_args$theme, + ggthemes = parsed_ggplot2_args$ggtheme + )) + + teal.reporter::teal_card(qenv) <- c(teal.reporter::teal_card(qenv), "## Plot") + teal.code::eval_code(qenv, plot_call) + }) + + decorated_output_plot_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "plot"), + expr = quote(plot) + ) + + plot_r <- reactive(req(decorated_output_plot_q())[["plot"]]) + + # Insert the plot into a plot_with_settings module from teal.widgets + pws <- teal.widgets::plot_with_settings_srv( + id = "myplot", + plot_r = plot_r, + height = plot_height, + width = plot_width + ) + + decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Show R Code for Response" + ) + decorated_output_dims_q + }) +} diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index d78e4e3ae..cba882138 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -208,55 +208,50 @@ tm_g_scatterplot <- function(label = "Scatterplot", } #' @export -tm_g_scatterplot.picks <- function(label = "Scatterplot", - x = picks( - datasets(), - variables(tidyselect::where(is.numeric)), - values() - ), - y = picks( - datasets(), - variables(tidyselect::where(is.numeric), selected = 2), - values() - ), - color_by = NULL, - size_by = NULL, - row_facet = NULL, - col_facet = NULL, - plot_height = c(600, 200, 2000), - plot_width = NULL, - alpha = c(1, 0, 1), - shape = shape_names, - size = c(5, 1, 15), - max_deg = 5L, - rotate_xaxis_labels = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - pre_output = NULL, - post_output = NULL, - table_dec = 4, - ggplot2_args = teal.widgets::ggplot2_args(), - transformators = list(), - decorators = list()) { +tm_g_scatterplot.default <- function(label = "Scatterplot", + x, + y, + color_by = NULL, + size_by = NULL, + row_facet = NULL, + col_facet = NULL, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplot") + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) + if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) + if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) + if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) + if (is.double(max_deg)) max_deg <- as.integer(max_deg) + # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(x, "picks") - checkmate::assert_class(y, "picks") - checkmate::assert_class(color_by, "picks", null.ok = TRUE) - checkmate::assert_class(size_by, "picks", null.ok = TRUE) - - checkmate::assert_class(row_facet, "picks", null.ok = TRUE) - if (isTRUE(attr(row_facet$variables, "multiple"))) { - warning("`row_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(row_facet$variables, "multiple") <- FALSE - } + checkmate::assert_list(x, types = "data_extract_spec") + checkmate::assert_list(y, types = "data_extract_spec") + checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) + checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_class(col_facet, "picks", null.ok = TRUE) - if (isTRUE(attr(col_facet$variables, "multiple"))) { - warning("`col_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(col_facet$variables, "multiple") <- FALSE - } + checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(row_facet) + + checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) + assert_single_selection(col_facet) checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -298,41 +293,46 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", # Make UI args args <- as.list(environment()) + + data_extract_list <- list( + x = x, + y = y, + color_by = color_by, + size_by = size_by, + row_facet = row_facet, + col_facet = col_facet + ) + ans <- module( label = label, - server = srv_g_scatterplot.picks, - ui = ui_g_scatterplot.picks, - ui_args = args[names(args) %in% names(formals(ui_g_scatterplot.picks))], - server_args = args[names(args) %in% names(formals(srv_g_scatterplot.picks))], + server = srv_g_scatterplot.default, + ui = ui_g_scatterplot.default, + ui_args = args, + server_args = c( + data_extract_list, + list( + plot_height = plot_height, + plot_width = plot_width, + table_dec = table_dec, + ggplot2_args = ggplot2_args, + decorators = decorators + ) + ), transformators = transformators, - datanames = { - datanames <- datanames(list(x, y, color_by, size_by, row_facet, col_facet)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(data_extract_list) ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot module -ui_g_scatterplot.picks <- function(id, - x, - y, - color_by, - size_by, - row_facet, - col_facet, - alpha, - shape, - color, - size, - rotate_xaxis_labels, - max_deg, - ggtheme, - pre_output, - post_output, - decorators) { +ui_g_scatterplot.default <- function(id, ...) { + args <- list(...) ns <- NS(id) + is_single_dataset_value <- teal.transform::is_single_dataset( + args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet + ) + tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -344,79 +344,92 @@ ui_g_scatterplot.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x), - checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_x"), "'] == true"), - radioButtons( - ns("log_x_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") - ) + teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]), + teal.transform::data_extract_ui( + id = ns("x"), + label = "X variable", + data_extract_spec = args$x, + is_single_dataset = is_single_dataset_value + ), + checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_x"), "'] == true"), + radioButtons( + ns("log_x_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") ) ), - teal::teal_nav_item( - label = tags$strong("Y variable"), - teal.transform::module_input_ui(id = ns("y"), spec = y), - checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_y"), "'] == true"), - radioButtons( - ns("log_y_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") - ) + teal.transform::data_extract_ui( + id = ns("y"), + label = "Y variable", + data_extract_spec = args$y, + is_single_dataset = is_single_dataset_value + ), + checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_y"), "'] == true"), + radioButtons( + ns("log_y_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") ) ), - if (!is.null(color_by)) { - teal::teal_nav_item( - label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_by"), spec = color_by) + if (!is.null(args$color_by)) { + teal.transform::data_extract_ui( + id = ns("color_by"), + label = "Color by variable", + data_extract_spec = args$color_by, + is_single_dataset = is_single_dataset_value ) }, - if (!is.null(size_by)) { - teal::teal_nav_item( - label = tags$strong("Size by:"), - teal.transform::module_input_ui(id = ns("size_by"), spec = size_by) + if (!is.null(args$size_by)) { + teal.transform::data_extract_ui( + id = ns("size_by"), + label = "Size by variable", + data_extract_spec = args$size_by, + is_single_dataset = is_single_dataset_value ) }, - if (!is.null(row_facet)) { - teal::teal_nav_item( - label = tags$strong("Row facetting"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) + if (!is.null(args$row_facet)) { + teal.transform::data_extract_ui( + id = ns("row_facet"), + label = "Row facetting", + data_extract_spec = args$row_facet, + is_single_dataset = is_single_dataset_value ) }, - if (!is.null(col_facet)) { - teal::teal_nav_item( - label = tags$strong("Column facetting"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) + if (!is.null(args$col_facet)) { + teal.transform::data_extract_ui( + id = ns("col_facet"), + label = "Column facetting", + data_extract_spec = args$col_facet, + is_single_dataset = is_single_dataset_value ) }, - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), teal.widgets::optionalSelectInput( inputId = ns("shape"), label = "Points shape:", - choices = shape, - selected = shape[1], + choices = args$shape, + selected = args$shape[1], multiple = FALSE ), colourpicker::colourInput(ns("color"), "Points color:", "black"), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE, step = .1), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), checkboxInput(ns("add_density"), "Add marginal density", value = FALSE), checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE), shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")), - teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(max_deg)), + teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)), shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)), teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE), shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)), @@ -440,14 +453,14 @@ ui_g_scatterplot.picks <- function(id, ns("label_size"), "Stats font size", min = 3, max = 10, value = 5, ticks = FALSE, step = .1 ), - if (!is.null(row_facet) || !is.null(col_facet)) { + if (!is.null(args$row_facet) || !is.null(args$col_facet)) { checkboxInput(ns("free_scales"), "Free scales", value = FALSE) }, selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = ggtheme, + selected = args$ggtheme, multiple = FALSE ) ) @@ -456,94 +469,118 @@ ui_g_scatterplot.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) ) } # Server function for the scatterplot module -srv_g_scatterplot.picks <- function(id, - data, - x, - y, - color_by, - size_by, - row_facet, - col_facet, - plot_height, - plot_width, - table_dec, - ggplot2_args, - decorators) { +srv_g_scatterplot.default <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - - selectors <- teal.transform::module_input_srv( - spec = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), - data = data + data_extract <- list( + x = x, + y = y, + color_by = color_by, + size_by = size_by, + row_facet = row_facet, + col_facet = col_facet ) + rule_diff <- function(other) { + function(value) { + othervalue <- selector_list()[[other]]()[["select"]] + if (!is.null(othervalue)) { + if (identical(value, othervalue)) { + "Row and column facetting variables must be different." + } + } + } + } - validated_q <- reactive({ - validate_input( - inputId = "x-variables-selected", - condition = length(selectors$x()$variables$selected) == 1, - message = "Please select exactly one x var." - ) - validate_input( - inputId = "y-variables-selected", - condition = length(selectors$y()$variables$selected) == 1, - message = "Please select exactly one y var." - ) - validate_input( - inputId = c("x-variables-selected", "y-variables-selected"), - condition = !any(selectors$x()$variables$selected %in% selectors$y()$variables$selected), - message = "X and Y variables must be different." - ) - validate_input( - inputId = "row_facet-variables-selected", - condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, - message = "Only single Row Facetting variable is allowed." - ) - validate_input( - inputId = "col_facet-variables-selected", - condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, - message = "Only single Column Facetting variable is allowed." - ) - validate_input( - inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), - condition = is.null(row_facet) || !is.null(col_facet) || - !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), - message = "Row and Column Facetting variables must be different." - ) - validate_input( - "add_density", - condition = !(is.null(input$add_density) && - (length(selectors$row_facet()$variables$selected) || length(selectors$col_facet()$variables$selected)) + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = data_extract, + datasets = data, + select_validation_rule = list( + x = ~ if (length(.) != 1) "Please select exactly one x var.", + y = ~ if (length(.) != 1) "Please select exactly one y var.", + color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", + size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", + row_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("col_facet") ), - message = "Cannot add marginal density when Row or Column facetting has been selected" + col_facet = shinyvalidate::compose_rules( + shinyvalidate::sv_optional(), + rule_diff("row_facet") + ) ) - obj <- req(data()) - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Scatter Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") + ) + + iv_r <- reactive({ + iv_facet <- shinyvalidate::InputValidator$new() + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) + iv_facet <- shinyvalidate::InputValidator$new() + iv_facet$add_rule("add_density", ~ if ( + isTRUE(.) && + ( + length(selector_list()$row_facet()$select) > 0L || + length(selector_list()$col_facet()$select) > 0L ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + ) { + "Cannot add marginal density when Row or Column facetting has been selected" + }) + iv_facet$enable() + + anl_merged_input <- teal.transform::merge_expression_srv( + selector_list = selector_list, + datasets = data, + merge_function = "dplyr::inner_join" + ) + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- c( + teal.reporter::teal_card("# Scatter Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) trend_line_is_applicable <- reactive({ - anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y - length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) + ANL <- merged$anl_q_r()[["ANL"]] + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) }) add_trend_line <- reactive({ @@ -553,9 +590,9 @@ srv_g_scatterplot.picks <- function(id, if (!is.null(color_by)) { observeEvent( - eventExpr = selectors$color_by(), + eventExpr = merged$anl_input_r()$columns_source$color_by, handlerExpr = { - color_by_var <- merged$merge_vars()$color_by + color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) if (length(color_by_var) > 0) { shinyjs::hide("color") } else { @@ -567,21 +604,21 @@ srv_g_scatterplot.picks <- function(id, output$num_na_removed <- renderUI({ if (add_trend_line()) { - anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y - if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { + ANL <- merged$anl_q_r()[["ANL"]] + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) { tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) } } }) observeEvent( - eventExpr = list(selectors$row_facet(), selectors$col_facet()), + eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")], handlerExpr = { if ( - length(merged$merge_vars()$row_facet) == 0 && - length(merged$merge_vars()$col_facet) == 0 + length(merged$anl_input_r()$columns_source$col_facet) == 0 && + length(merged$anl_input_r()$columns_source$row_facet) == 0 ) { shinyjs::hide("free_scales") } else { @@ -591,14 +628,24 @@ srv_g_scatterplot.picks <- function(id, ) output_q <- reactive({ - req(merged$data()) - anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y - color_by_var <- merged$merge_vars()$color_by - size_by_var <- merged$merge_vars()$size_by - row_facet_var <- merged$merge_vars()$row_facet - col_facet_var <- merged$merge_vars()$col_facet + teal::validate_inputs(iv_r(), iv_facet) + + ANL <- merged$anl_q_r()[["ANL"]] + + x_var <- as.vector(merged$anl_input_r()$columns_source$x) + y_var <- as.vector(merged$anl_input_r()$columns_source$y) + color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) + size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) + row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$row_facet) + } + col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { + character(0) + } else { + as.vector(merged$anl_input_r()$columns_source$col_facet) + } alpha <- input$alpha size <- input$size rotate_xaxis_labels <- input$rotate_xaxis_labels @@ -613,85 +660,80 @@ srv_g_scatterplot.picks <- function(id, log_x <- input$log_x log_y <- input$log_y - validate_input( - inputId = "row_facet-variables-selected", - condition = length(col_facet_var) == 0 || - inherits(anl[[row_facet_var]], c("character", "factor", "Date", "integer")), - message = "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - ) - validate_input( - inputId = "col_facet-variables-selected", - condition = length(col_facet_var) == 0 || - inherits(anl[[col_facet_var]], c("character", "factor", "Date", "integer")), - message = "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - ) - + validate(need( + length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")), + "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + )) + validate(need( + length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")), + "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + )) if (add_density && length(color_by_var) > 0) { - validate_input( - inputId = "col_facet-variables-selected", - condition = !is.numeric(anl[[color_by_var]]), - message = paste0( - "Marginal plots cannot be produced when the points are colored by numeric variables.", - "\nUncheck the 'Add marginal density' checkbox to display the plot." - ) - ) - validate_input( - "color_by-variables-selected", - condition = !( - inherits(anl[[color_by_var]], "Date") || - inherits(anl[[color_by_var]], "POSIXct") || - inherits(anl[[color_by_var]], "POSIXlt") + validate(need( + !is.numeric(ANL[[color_by_var]]), + "Marginal plots cannot be produced when the points are colored by numeric variables. + \n Uncheck the 'Add marginal density' checkbox to display the plot." + )) + validate(need( + !( + inherits(ANL[[color_by_var]], "Date") || + inherits(ANL[[color_by_var]], "POSIXct") || + inherits(ANL[[color_by_var]], "POSIXlt") ), - message = paste0( - "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.", - "\n Uncheck the 'Add marginal density' checkbox to display the plot." - ) - ) + "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. + \n Uncheck the 'Add marginal density' checkbox to display the plot." + )) } - teal::validate_has_data(anl[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(ANL[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) if (log_x) { - validate_input( - "x-variables-selected", - condition = is.numeric(anl[[x_var]]) && all(anl[[x_var]] > 0 | is.na(anl[[x_var]])), - nessage = "X variable can only be log transformed if variable is numeric and all values are positive." + validate( + need( + is.numeric(ANL[[x_var]]) && all( + ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) + ), + "X variable can only be log transformed if variable is numeric and all values are positive." + ) ) } if (log_y) { - validate_input( - "y-variables-selected", - condition = is.numeric(anl[[y_var]]) && all(anl[[y_var]] > 0 | is.na(anl[[y_var]])), - message = "Y variable can only be log transformed if variable is numeric and all values are positive." + validate( + need( + is.numeric(ANL[[y_var]]) && all( + ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) + ), + "Y variable can only be log transformed if variable is numeric and all values are positive." + ) ) } facet_cl <- facet_ggplot_call( - row_facet_var, - col_facet_var, + row_facet_name, + col_facet_name, free_x_scales = isTRUE(input$free_scales), free_y_scales = isTRUE(input$free_scales) ) point_sizes <- if (length(size_by_var) > 0) { - validate(need(is.numeric(anl[[size_by_var]]), "Variable to size by must be numeric")) + validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) substitute( - expr = size * anl[[size_by_var]] / max(anl[[size_by_var]], na.rm = TRUE), + expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), env = list(size = size, size_by_var = size_by_var) ) } else { size } - plot_q <- merged$data() + plot_q <- merged$anl_q_r() if (log_x) { log_x_fn <- input$log_x_base plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = anl[, log_x_var] <- log_x_fn(anl[, x_var]), + expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), env = list( x_var = x_var, log_x_fn = as.name(log_x_fn), @@ -706,7 +748,7 @@ srv_g_scatterplot.picks <- function(id, plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = anl[, log_y_var] <- log_y_fn(anl[, y_var]), + expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), env = list( y_var = y_var, log_y_fn = as.name(log_y_fn), @@ -718,19 +760,19 @@ srv_g_scatterplot.picks <- function(id, pre_pro_anl <- if (input$show_count) { paste0( - "anl %>% dplyr::group_by(", + "ANL %>% dplyr::group_by(", paste( c( - if (length(color_by_var) > 0 && inherits(anl[[color_by_var]], c("factor", "character"))) color_by_var, - row_facet_var, - col_facet_var + if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var, + row_facet_name, + col_facet_name ), collapse = ", " ), ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" ) } else { - "anl" + "ANL" } plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) @@ -835,11 +877,11 @@ srv_g_scatterplot.picks <- function(id, shinyjs::show("ci") shinyjs::show("show_form") shinyjs::show("show_r2") - if (nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)])) > 0) { + if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) { plot_q <- teal.code::eval_code( plot_q, substitute( - expr = anl <- dplyr::filter(anl, !is.na(x_var) & !is.na(y_var)), + expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), env = list(x_var = as.name(x_var), y_var = as.name(y_var)) ) ) @@ -884,13 +926,13 @@ srv_g_scatterplot.picks <- function(id, y_label <- varname_w_label( y_var, - anl, + ANL, prefix = if (log_y) paste(log_y_fn, "(") else NULL, suffix = if (log_y) ")" else NULL ) x_label <- varname_w_label( x_var, - anl, + ANL, prefix = if (log_x) paste(log_x_fn, "(") else NULL, suffix = if (log_x) ")" else NULL ) @@ -976,7 +1018,7 @@ srv_g_scatterplot.picks <- function(id, validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) } - merged_data <- isolate(output_q()[["anl"]]) + merged_data <- isolate(output_q()[["ANL"]]) brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) numeric_cols <- names(brushed_df)[ diff --git a/R/tm_g_scatterplot_old.R b/R/tm_g_scatterplot_picks.R similarity index 57% rename from R/tm_g_scatterplot_old.R rename to R/tm_g_scatterplot_picks.R index 08ffd952b..f7b509348 100644 --- a/R/tm_g_scatterplot_old.R +++ b/R/tm_g_scatterplot_picks.R @@ -1,48 +1,53 @@ #' @export -tm_g_scatterplot.default <- function(label = "Scatterplot", - x, - y, - color_by = NULL, - size_by = NULL, - row_facet = NULL, - col_facet = NULL, - plot_height = c(600, 200, 2000), - plot_width = NULL, - alpha = c(1, 0, 1), - shape = shape_names, - size = c(5, 1, 15), - max_deg = 5L, - rotate_xaxis_labels = FALSE, - ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), - pre_output = NULL, - post_output = NULL, - table_dec = 4, - ggplot2_args = teal.widgets::ggplot2_args(), - transformators = list(), - decorators = list()) { +tm_g_scatterplot.picks <- function(label = "Scatterplot", + x = picks( + datasets(), + variables(tidyselect::where(is.numeric)), + values() + ), + y = picks( + datasets(), + variables(tidyselect::where(is.numeric), selected = 2), + values() + ), + color_by = NULL, + size_by = NULL, + row_facet = NULL, + col_facet = NULL, + plot_height = c(600, 200, 2000), + plot_width = NULL, + alpha = c(1, 0, 1), + shape = shape_names, + size = c(5, 1, 15), + max_deg = 5L, + rotate_xaxis_labels = FALSE, + ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), + pre_output = NULL, + post_output = NULL, + table_dec = 4, + ggplot2_args = teal.widgets::ggplot2_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplot") - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - if (inherits(color_by, "data_extract_spec")) color_by <- list(color_by) - if (inherits(size_by, "data_extract_spec")) size_by <- list(size_by) - if (inherits(row_facet, "data_extract_spec")) row_facet <- list(row_facet) - if (inherits(col_facet, "data_extract_spec")) col_facet <- list(col_facet) - if (is.double(max_deg)) max_deg <- as.integer(max_deg) - # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(x, types = "data_extract_spec") - checkmate::assert_list(y, types = "data_extract_spec") - checkmate::assert_list(color_by, types = "data_extract_spec", null.ok = TRUE) - checkmate::assert_list(size_by, types = "data_extract_spec", null.ok = TRUE) - - checkmate::assert_list(row_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(row_facet) + checkmate::assert_class(x, "picks") + checkmate::assert_class(y, "picks") + checkmate::assert_class(color_by, "picks", null.ok = TRUE) + checkmate::assert_class(size_by, "picks", null.ok = TRUE) + + checkmate::assert_class(row_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(row_facet$variables, "multiple"))) { + warning("`row_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(row_facet$variables, "multiple") <- FALSE + } - checkmate::assert_list(col_facet, types = "data_extract_spec", null.ok = TRUE) - assert_single_selection(col_facet) + checkmate::assert_class(col_facet, "picks", null.ok = TRUE) + if (isTRUE(attr(col_facet$variables, "multiple"))) { + warning("`col_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(col_facet$variables, "multiple") <- FALSE + } checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -84,46 +89,41 @@ tm_g_scatterplot.default <- function(label = "Scatterplot", # Make UI args args <- as.list(environment()) - - data_extract_list <- list( - x = x, - y = y, - color_by = color_by, - size_by = size_by, - row_facet = row_facet, - col_facet = col_facet - ) - ans <- module( label = label, - server = srv_g_scatterplot.default, - ui = ui_g_scatterplot.default, - ui_args = args, - server_args = c( - data_extract_list, - list( - plot_height = plot_height, - plot_width = plot_width, - table_dec = table_dec, - ggplot2_args = ggplot2_args, - decorators = decorators - ) - ), + server = srv_g_scatterplot.picks, + ui = ui_g_scatterplot.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplot.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplot.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(data_extract_list) + datanames = { + datanames <- datanames(list(x, y, color_by, size_by, row_facet, col_facet)) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot module -ui_g_scatterplot.default <- function(id, ...) { - args <- list(...) +ui_g_scatterplot.picks <- function(id, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + alpha, + shape, + color, + size, + rotate_xaxis_labels, + max_deg, + ggtheme, + pre_output, + post_output, + decorators) { ns <- NS(id) - is_single_dataset_value <- teal.transform::is_single_dataset( - args$x, args$y, args$color_by, args$size_by, args$row_facet, args$col_facet - ) - tagList( teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -135,92 +135,79 @@ ui_g_scatterplot.default <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args[c("x", "y", "color_by", "size_by", "row_facet", "col_facet")]), - teal.transform::data_extract_ui( - id = ns("x"), - label = "X variable", - data_extract_spec = args$x, - is_single_dataset = is_single_dataset_value - ), - checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_x"), "'] == true"), - radioButtons( - ns("log_x_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + teal::teal_nav_item( + label = tags$strong("X variable"), + teal.transform::module_input_ui(id = ns("x"), spec = x), + checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_x"), "'] == true"), + radioButtons( + ns("log_x_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) ) ), - teal.transform::data_extract_ui( - id = ns("y"), - label = "Y variable", - data_extract_spec = args$y, - is_single_dataset = is_single_dataset_value - ), - checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), - conditionalPanel( - condition = paste0("input['", ns("log_y"), "'] == true"), - radioButtons( - ns("log_y_base"), - label = NULL, - inline = TRUE, - choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + teal::teal_nav_item( + label = tags$strong("Y variable"), + teal.transform::module_input_ui(id = ns("y"), spec = y), + checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), + conditionalPanel( + condition = paste0("input['", ns("log_y"), "'] == true"), + radioButtons( + ns("log_y_base"), + label = NULL, + inline = TRUE, + choices = c("Natural" = "log", "Base 10" = "log10", "Base 2" = "log2") + ) ) ), - if (!is.null(args$color_by)) { - teal.transform::data_extract_ui( - id = ns("color_by"), - label = "Color by variable", - data_extract_spec = args$color_by, - is_single_dataset = is_single_dataset_value + if (!is.null(color_by)) { + teal::teal_nav_item( + label = tags$strong("Color by:"), + teal.transform::module_input_ui(id = ns("color_by"), spec = color_by) ) }, - if (!is.null(args$size_by)) { - teal.transform::data_extract_ui( - id = ns("size_by"), - label = "Size by variable", - data_extract_spec = args$size_by, - is_single_dataset = is_single_dataset_value + if (!is.null(size_by)) { + teal::teal_nav_item( + label = tags$strong("Size by:"), + teal.transform::module_input_ui(id = ns("size_by"), spec = size_by) ) }, - if (!is.null(args$row_facet)) { - teal.transform::data_extract_ui( - id = ns("row_facet"), - label = "Row facetting", - data_extract_spec = args$row_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(row_facet)) { + teal::teal_nav_item( + label = tags$strong("Row facetting"), + teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) ) }, - if (!is.null(args$col_facet)) { - teal.transform::data_extract_ui( - id = ns("col_facet"), - label = "Column facetting", - data_extract_spec = args$col_facet, - is_single_dataset = is_single_dataset_value + if (!is.null(col_facet)) { + teal::teal_nav_item( + label = tags$strong("Column facetting"), + teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) ) }, - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( title = "Plot settings", - teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", args$alpha, ticks = FALSE), + teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Opacity:", alpha, ticks = FALSE), teal.widgets::optionalSelectInput( inputId = ns("shape"), label = "Points shape:", - choices = args$shape, - selected = args$shape[1], + choices = shape, + selected = shape[1], multiple = FALSE ), colourpicker::colourInput(ns("color"), "Points color:", "black"), - teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", args$size, ticks = FALSE, step = .1), - checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = args$rotate_xaxis_labels), + teal.widgets::optionalSliderInputValMinMax(ns("size"), "Points size:", size, ticks = FALSE, step = .1), + checkboxInput(ns("rotate_xaxis_labels"), "Rotate X axis labels", value = rotate_xaxis_labels), checkboxInput(ns("add_density"), "Add marginal density", value = FALSE), checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), checkboxInput(ns("show_count"), "Show N (number of observations)", value = FALSE), shinyjs::hidden(helpText(id = ns("line_msg"), "Trendline needs numeric X and Y variables")), - teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(args$max_deg)), + teal.widgets::optionalSelectInput(ns("smoothing_degree"), "Smoothing degree", seq_len(max_deg)), shinyjs::hidden(teal.widgets::optionalSelectInput(ns("color_sub"), label = "", multiple = TRUE)), teal.widgets::optionalSliderInputValMinMax(ns("ci"), "Confidence", c(.95, .8, .99), ticks = FALSE), shinyjs::hidden(checkboxInput(ns("show_form"), "Show formula", value = TRUE)), @@ -244,14 +231,14 @@ ui_g_scatterplot.default <- function(id, ...) { ns("label_size"), "Stats font size", min = 3, max = 10, value = 5, ticks = FALSE, step = .1 ), - if (!is.null(args$row_facet) || !is.null(args$col_facet)) { + if (!is.null(row_facet) || !is.null(col_facet)) { checkboxInput(ns("free_scales"), "Free scales", value = FALSE) }, selectInput( inputId = ns("ggtheme"), label = "Theme (by ggplot):", choices = ggplot_themes, - selected = args$ggtheme, + selected = ggtheme, multiple = FALSE ) ) @@ -260,118 +247,94 @@ ui_g_scatterplot.default <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) ) } # Server function for the scatterplot module -srv_g_scatterplot.default <- function(id, - data, - x, - y, - color_by, - size_by, - row_facet, - col_facet, - plot_height, - plot_width, - table_dec, - ggplot2_args, - decorators) { +srv_g_scatterplot.picks <- function(id, + data, + x, + y, + color_by, + size_by, + row_facet, + col_facet, + plot_height, + plot_width, + table_dec, + ggplot2_args, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - data_extract <- list( - x = x, - y = y, - color_by = color_by, - size_by = size_by, - row_facet = row_facet, - col_facet = col_facet + + selectors <- teal.transform::module_input_srv( + spec = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), + data = data ) - rule_diff <- function(other) { - function(value) { - othervalue <- selector_list()[[other]]()[["select"]] - if (!is.null(othervalue)) { - if (identical(value, othervalue)) { - "Row and column facetting variables must be different." - } - } - } - } - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = data_extract, - datasets = data, - select_validation_rule = list( - x = ~ if (length(.) != 1) "Please select exactly one x var.", - y = ~ if (length(.) != 1) "Please select exactly one y var.", - color_by = ~ if (length(.) > 1) "There cannot be more than 1 color variable.", - size_by = ~ if (length(.) > 1) "There cannot be more than 1 size variable.", - row_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("col_facet") + validated_q <- reactive({ + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) == 1, + message = "Please select exactly one x var." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) == 1, + message = "Please select exactly one y var." + ) + validate_input( + inputId = c("x-variables-selected", "y-variables-selected"), + condition = !any(selectors$x()$variables$selected %in% selectors$y()$variables$selected), + message = "X and Y variables must be different." + ) + validate_input( + inputId = "row_facet-variables-selected", + condition = is.null(row_facet) || length(selectors$row_facet()$variables$selected) < 2, + message = "Only single Row Facetting variable is allowed." + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = is.null(col_facet) || length(selectors$col_facet()$variables$selected) < 2, + message = "Only single Column Facetting variable is allowed." + ) + validate_input( + inputId = c("row_facet-variables-selected", "col_facet-variables-selected"), + condition = is.null(row_facet) || !is.null(col_facet) || + !any(selectors$row_facet()$variables$selected %in% selectors$col_facet()$variables$selected), + message = "Row and Column Facetting variables must be different." + ) + validate_input( + "add_density", + condition = !(is.null(input$add_density) && + (length(selectors$row_facet()$variables$selected) || length(selectors$col_facet()$variables$selected)) ), - col_facet = shinyvalidate::compose_rules( - shinyvalidate::sv_optional(), - rule_diff("row_facet") - ) + message = "Cannot add marginal density when Row or Column facetting has been selected" ) - ) - - iv_r <- reactive({ - iv_facet <- shinyvalidate::InputValidator$new() - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - iv_facet <- shinyvalidate::InputValidator$new() - iv_facet$add_rule("add_density", ~ if ( - isTRUE(.) && - ( - length(selector_list()$row_facet()$select) > 0L || - length(selector_list()$col_facet()$select) > 0L + obj <- req(data()) + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Scatter Plot"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") ) - ) { - "Cannot add marginal density when Row or Column facetting has been selected" - }) - iv_facet$enable() - - anl_merged_input <- teal.transform::merge_expression_srv( - selector_list = selector_list, - datasets = data, - merge_function = "dplyr::inner_join" - ) - qenv <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- c( - teal.reporter::teal_card("# Scatter Plot"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(data(), 'library("ggplot2");library("dplyr")') # nolint quotes + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") trend_line_is_applicable <- reactive({ - ANL <- merged$anl_q_r()[["ANL"]] - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - length(x_var) > 0 && length(y_var) > 0 && is.numeric(ANL[[x_var]]) && is.numeric(ANL[[y_var]]) + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y + length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) }) add_trend_line <- reactive({ @@ -381,9 +344,9 @@ srv_g_scatterplot.default <- function(id, if (!is.null(color_by)) { observeEvent( - eventExpr = merged$anl_input_r()$columns_source$color_by, + eventExpr = selectors$color_by(), handlerExpr = { - color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) + color_by_var <- merged$merge_vars()$color_by if (length(color_by_var) > 0) { shinyjs::hide("color") } else { @@ -395,21 +358,21 @@ srv_g_scatterplot.default <- function(id, output$num_na_removed <- renderUI({ if (add_trend_line()) { - ANL <- merged$anl_q_r()[["ANL"]] - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - if ((num_total_na <- nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)]))) > 0) { + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y + if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) } } }) observeEvent( - eventExpr = merged$anl_input_r()$columns_source[c("col_facet", "row_facet")], + eventExpr = list(selectors$row_facet(), selectors$col_facet()), handlerExpr = { if ( - length(merged$anl_input_r()$columns_source$col_facet) == 0 && - length(merged$anl_input_r()$columns_source$row_facet) == 0 + length(merged$merge_vars()$row_facet) == 0 && + length(merged$merge_vars()$col_facet) == 0 ) { shinyjs::hide("free_scales") } else { @@ -419,24 +382,14 @@ srv_g_scatterplot.default <- function(id, ) output_q <- reactive({ - teal::validate_inputs(iv_r(), iv_facet) - - ANL <- merged$anl_q_r()[["ANL"]] - - x_var <- as.vector(merged$anl_input_r()$columns_source$x) - y_var <- as.vector(merged$anl_input_r()$columns_source$y) - color_by_var <- as.vector(merged$anl_input_r()$columns_source$color_by) - size_by_var <- as.vector(merged$anl_input_r()$columns_source$size_by) - row_facet_name <- if (length(merged$anl_input_r()$columns_source$row_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$row_facet) - } - col_facet_name <- if (length(merged$anl_input_r()$columns_source$col_facet) == 0) { - character(0) - } else { - as.vector(merged$anl_input_r()$columns_source$col_facet) - } + req(merged$data()) + anl <- merged$data()[["anl"]] + x_var <- merged$merge_vars()$x + y_var <- merged$merge_vars()$y + color_by_var <- merged$merge_vars()$color_by + size_by_var <- merged$merge_vars()$size_by + row_facet_var <- merged$merge_vars()$row_facet + col_facet_var <- merged$merge_vars()$col_facet alpha <- input$alpha size <- input$size rotate_xaxis_labels <- input$rotate_xaxis_labels @@ -451,80 +404,85 @@ srv_g_scatterplot.default <- function(id, log_x <- input$log_x log_y <- input$log_y - validate(need( - length(row_facet_name) == 0 || inherits(ANL[[row_facet_name]], c("character", "factor", "Date", "integer")), - "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - )) - validate(need( - length(col_facet_name) == 0 || inherits(ANL[[col_facet_name]], c("character", "factor", "Date", "integer")), - "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" - )) + validate_input( + inputId = "row_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[row_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Row facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) + validate_input( + inputId = "col_facet-variables-selected", + condition = length(col_facet_var) == 0 || + inherits(anl[[col_facet_var]], c("character", "factor", "Date", "integer")), + message = "`Column facetting` variable must be of class `character`, `factor`, `Date`, or `integer`" + ) + if (add_density && length(color_by_var) > 0) { - validate(need( - !is.numeric(ANL[[color_by_var]]), - "Marginal plots cannot be produced when the points are colored by numeric variables. - \n Uncheck the 'Add marginal density' checkbox to display the plot." - )) - validate(need( - !( - inherits(ANL[[color_by_var]], "Date") || - inherits(ANL[[color_by_var]], "POSIXct") || - inherits(ANL[[color_by_var]], "POSIXlt") + validate_input( + inputId = "col_facet-variables-selected", + condition = !is.numeric(anl[[color_by_var]]), + message = paste0( + "Marginal plots cannot be produced when the points are colored by numeric variables.", + "\nUncheck the 'Add marginal density' checkbox to display the plot." + ) + ) + validate_input( + "color_by-variables-selected", + condition = !( + inherits(anl[[color_by_var]], "Date") || + inherits(anl[[color_by_var]], "POSIXct") || + inherits(anl[[color_by_var]], "POSIXlt") ), - "Marginal plots cannot be produced when the points are colored by Date or POSIX variables. - \n Uncheck the 'Add marginal density' checkbox to display the plot." - )) + message = paste0( + "Marginal plots cannot be produced when the points are colored by Date or POSIX variables.", + "\n Uncheck the 'Add marginal density' checkbox to display the plot." + ) + ) } - teal::validate_has_data(ANL[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl[, c(x_var, y_var)], 1, complete = TRUE, allow_inf = FALSE) if (log_x) { - validate( - need( - is.numeric(ANL[[x_var]]) && all( - ANL[[x_var]] > 0 | is.na(ANL[[x_var]]) - ), - "X variable can only be log transformed if variable is numeric and all values are positive." - ) + validate_input( + "x-variables-selected", + condition = is.numeric(anl[[x_var]]) && all(anl[[x_var]] > 0 | is.na(anl[[x_var]])), + nessage = "X variable can only be log transformed if variable is numeric and all values are positive." ) } if (log_y) { - validate( - need( - is.numeric(ANL[[y_var]]) && all( - ANL[[y_var]] > 0 | is.na(ANL[[y_var]]) - ), - "Y variable can only be log transformed if variable is numeric and all values are positive." - ) + validate_input( + "y-variables-selected", + condition = is.numeric(anl[[y_var]]) && all(anl[[y_var]] > 0 | is.na(anl[[y_var]])), + message = "Y variable can only be log transformed if variable is numeric and all values are positive." ) } facet_cl <- facet_ggplot_call( - row_facet_name, - col_facet_name, + row_facet_var, + col_facet_var, free_x_scales = isTRUE(input$free_scales), free_y_scales = isTRUE(input$free_scales) ) point_sizes <- if (length(size_by_var) > 0) { - validate(need(is.numeric(ANL[[size_by_var]]), "Variable to size by must be numeric")) + validate(need(is.numeric(anl[[size_by_var]]), "Variable to size by must be numeric")) substitute( - expr = size * ANL[[size_by_var]] / max(ANL[[size_by_var]], na.rm = TRUE), + expr = size * anl[[size_by_var]] / max(anl[[size_by_var]], na.rm = TRUE), env = list(size = size, size_by_var = size_by_var) ) } else { size } - plot_q <- merged$anl_q_r() + plot_q <- merged$data() if (log_x) { log_x_fn <- input$log_x_base plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = ANL[, log_x_var] <- log_x_fn(ANL[, x_var]), + expr = anl[, log_x_var] <- log_x_fn(anl[, x_var]), env = list( x_var = x_var, log_x_fn = as.name(log_x_fn), @@ -539,7 +497,7 @@ srv_g_scatterplot.default <- function(id, plot_q <- teal.code::eval_code( object = plot_q, code = substitute( - expr = ANL[, log_y_var] <- log_y_fn(ANL[, y_var]), + expr = anl[, log_y_var] <- log_y_fn(anl[, y_var]), env = list( y_var = y_var, log_y_fn = as.name(log_y_fn), @@ -551,19 +509,19 @@ srv_g_scatterplot.default <- function(id, pre_pro_anl <- if (input$show_count) { paste0( - "ANL %>% dplyr::group_by(", + "anl %>% dplyr::group_by(", paste( c( - if (length(color_by_var) > 0 && inherits(ANL[[color_by_var]], c("factor", "character"))) color_by_var, - row_facet_name, - col_facet_name + if (length(color_by_var) > 0 && inherits(anl[[color_by_var]], c("factor", "character"))) color_by_var, + row_facet_var, + col_facet_var ), collapse = ", " ), ") %>% dplyr::mutate(n = dplyr::n()) %>% dplyr::ungroup()" ) } else { - "ANL" + "anl" } plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) @@ -668,11 +626,11 @@ srv_g_scatterplot.default <- function(id, shinyjs::show("ci") shinyjs::show("show_form") shinyjs::show("show_r2") - if (nrow(ANL) - nrow(stats::na.omit(ANL[, c(x_var, y_var)])) > 0) { + if (nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)])) > 0) { plot_q <- teal.code::eval_code( plot_q, substitute( - expr = ANL <- dplyr::filter(ANL, !is.na(x_var) & !is.na(y_var)), + expr = anl <- dplyr::filter(anl, !is.na(x_var) & !is.na(y_var)), env = list(x_var = as.name(x_var), y_var = as.name(y_var)) ) ) @@ -717,13 +675,13 @@ srv_g_scatterplot.default <- function(id, y_label <- varname_w_label( y_var, - ANL, + anl, prefix = if (log_y) paste(log_y_fn, "(") else NULL, suffix = if (log_y) ")" else NULL ) x_label <- varname_w_label( x_var, - ANL, + anl, prefix = if (log_x) paste(log_x_fn, "(") else NULL, suffix = if (log_x) ")" else NULL ) @@ -809,7 +767,7 @@ srv_g_scatterplot.default <- function(id, validate(need(!input$add_density, "Brushing feature is currently not supported when plot has marginal density")) } - merged_data <- isolate(output_q()[["ANL"]]) + merged_data <- isolate(output_q()[["anl"]]) brushed_df <- teal.widgets::clean_brushedPoints(merged_data, plot_brush) numeric_cols <- names(brushed_df)[ diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index deff2e0c0..b7d137203 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -195,28 +195,22 @@ tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", } #' @export -tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", - variables = list( - picks( - datasets(), - variables(selected = 1:5, multiple = TRUE) - ) - ), - plot_height = c(600, 200, 2000), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_g_scatterplotmatrix.default <- function(label = "Scatterplot Matrix", + variables, + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplotmatrix") - if (is.null(names(variables))) { - names(variables) <- sprintf("pick_%s", seq_along(variables)) - } + # Normalize the parameters + if (inherits(variables, "data_extract_spec")) variables <- list(variables) # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(variables, types = "picks", names = "named") + checkmate::assert_list(variables, types = "data_extract_spec") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -232,30 +226,31 @@ tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", assert_decorators(decorators, "plot") # End of assertions + # Make UI args args <- as.list(environment()) + ans <- module( label = label, - ui = ui_g_scatterplotmatrix.picks, - server = srv_g_scatterplotmatrix.picks, - ui_args = args[names(args) %in% names(formals(ui_g_scatterplotmatrix.picks))], - server_args = args[names(args) %in% names(formals(srv_g_scatterplotmatrix.picks))], + server = srv_g_scatterplotmatrix.default, + ui = ui_g_scatterplotmatrix.default, + ui_args = args, + server_args = list( + variables = variables, + plot_height = plot_height, + plot_width = plot_width, + decorators = decorators + ), transformators = transformators, - datanames = { - datanames <- datanames(variables) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(variables) ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot matrix module -ui_g_scatterplotmatrix.picks <- function(id, - variables, - pre_output, - post_output, - decorators) { - checkmate::assert_list(variables, "picks", names = "named") +ui_g_scatterplotmatrix.default <- function(id, ...) { + args <- list(...) + is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) ns <- NS(id) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -265,15 +260,15 @@ ui_g_scatterplotmatrix.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - tagList( - lapply(names(variables), function(id) { - teal::teal_nav_item( - teal.transform::module_input_ui(id = ns(id), spec = variables[[id]]) - ) - }) + teal.transform::datanames_input(args$variables), + teal.transform::data_extract_ui( + id = ns("variables"), + label = "Variables", + data_extract_spec = args$variables, + is_single_dataset = is_single_dataset_value ), tags$hr(), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -302,55 +297,66 @@ ui_g_scatterplotmatrix.picks <- function(id, forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = pre_output, - post_output = post_output + pre_output = args$pre_output, + post_output = args$post_output ) } # Server function for the scatterplot matrix module -srv_g_scatterplotmatrix.picks <- function(id, - data, - variables, - plot_height, - plot_width, - decorators) { +srv_g_scatterplotmatrix.default <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv( - spec = variables, - data = data + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(variables = variables), + datasets = data, + select_validation_rule = list( + variables = ~ if (length(.) <= 1) "Please select at least 2 columns." + ) ) - validated_q <- reactive({ - obj <- req(data()) + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + teal.transform::compose_and_enable_validators(iv, selector_list) + }) - input_ids <- sprintf("%s-variables-selected", names(variables)) - selected_variables <- unname(unlist(lapply(selectors, function(selector) selector()$variables$selected))) - validate_input( - inputId = input_ids, # validate all inputs where variable can be selected - condition = length(selected_variables) > 1, - message = "Please select at least 2 columns" - ) + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list + ) + anl_merged_q <- reactive({ + req(anl_merged_input()) + obj <- data() teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Scatter Plot Matrix"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') + qenv <- teal.code::eval_code(obj, 'library("dplyr");library("lattice")') # nolint quotes + teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr)) }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") - merge_vars <- reactive(unname(unlist(merged$merge_vars()))) + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q + ) # plot output_q <- reactive({ - qenv <- req(merged$data()) - anl <- qenv[["anl"]] - cols_names <- merge_vars() + teal::validate_inputs(iv_r()) + + qenv <- merged$anl_q_r() + ANL <- qenv[["ANL"]] + + cols_names <- merged$anl_input_r()$columns_source$variables alpha <- input$alpha cex <- input$cex add_cor <- input$cor @@ -363,19 +369,19 @@ srv_g_scatterplotmatrix.picks <- function(id, "na.fail" } - teal::validate_has_data(anl, 10) - teal::validate_has_data(anl[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(ANL, 10) + teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) # get labels and proper variable names - varnames <- varname_w_label(cols_names, anl, wrap_width = 20) + varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) # check character columns. If any, then those are converted to factors - check_char <- vapply(anl[, cols_names], is.character, logical(1)) + check_char <- vapply(ANL[, cols_names], is.character, logical(1)) if (any(check_char)) { qenv <- teal.code::eval_code( qenv, substitute( - expr = anl <- anl[, cols_names] %>% + expr = ANL <- ANL[, cols_names] %>% dplyr::mutate_if(is.character, as.factor) %>% droplevels(), env = list(cols_names = cols_names) @@ -385,7 +391,7 @@ srv_g_scatterplotmatrix.picks <- function(id, qenv <- teal.code::eval_code( qenv, substitute( - expr = anl <- anl[, cols_names] %>% + expr = ANL <- ANL[, cols_names] %>% droplevels(), env = list(cols_names = cols_names) ) @@ -406,7 +412,7 @@ srv_g_scatterplotmatrix.picks <- function(id, substitute( expr = { plot <- lattice::splom( - anl, + ANL, varnames = varnames_value, panel = function(x, y, ...) { lattice::panel.splom(x = x, y = y, ...) @@ -448,7 +454,7 @@ srv_g_scatterplotmatrix.picks <- function(id, substitute( expr = { plot <- lattice::splom( - anl, + ANL, varnames = varnames_value, pch = 16, alpha = alpha_value, @@ -483,9 +489,11 @@ srv_g_scatterplotmatrix.picks <- function(id, # show a message if conversion to factors took place output$message <- renderText({ - cols_names <- req(merge_vars()) - anl <- merged$data()[["anl"]] - check_char <- vapply(anl[, cols_names], is.character, logical(1)) + req(iv_r()$is_valid()) + req(selector_list()$variables()) + ANL <- merged$anl_q_r()[["ANL"]] + cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) + check_char <- vapply(ANL[, cols_names], is.character, logical(1)) if (any(check_char)) { is_single <- sum(check_char) == 1 paste( diff --git a/R/tm_g_scatterplotmatrix_old.R b/R/tm_g_scatterplotmatrix_picks.R similarity index 72% rename from R/tm_g_scatterplotmatrix_old.R rename to R/tm_g_scatterplotmatrix_picks.R index e7822318e..fb6703153 100644 --- a/R/tm_g_scatterplotmatrix_old.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -1,20 +1,26 @@ #' @export -tm_g_scatterplotmatrix.default <- function(label = "Scatterplot Matrix", - variables, - plot_height = c(600, 200, 2000), - plot_width = NULL, - pre_output = NULL, - post_output = NULL, - transformators = list(), - decorators = list()) { +tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", + variables = list( + picks( + datasets(), + variables(selected = 1:5, multiple = TRUE) + ) + ), + plot_height = c(600, 200, 2000), + plot_width = NULL, + pre_output = NULL, + post_output = NULL, + transformators = list(), + decorators = list()) { message("Initializing tm_g_scatterplotmatrix") - # Normalize the parameters - if (inherits(variables, "data_extract_spec")) variables <- list(variables) + if (is.null(names(variables))) { + names(variables) <- sprintf("pick_%s", seq_along(variables)) + } # Start of assertions checkmate::assert_string(label) - checkmate::assert_list(variables, types = "data_extract_spec") + checkmate::assert_list(variables, types = "picks", names = "named") checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") @@ -30,31 +36,30 @@ tm_g_scatterplotmatrix.default <- function(label = "Scatterplot Matrix", assert_decorators(decorators, "plot") # End of assertions - # Make UI args args <- as.list(environment()) - ans <- module( label = label, - server = srv_g_scatterplotmatrix.default, - ui = ui_g_scatterplotmatrix.default, - ui_args = args, - server_args = list( - variables = variables, - plot_height = plot_height, - plot_width = plot_width, - decorators = decorators - ), + ui = ui_g_scatterplotmatrix.picks, + server = srv_g_scatterplotmatrix.picks, + ui_args = args[names(args) %in% names(formals(ui_g_scatterplotmatrix.picks))], + server_args = args[names(args) %in% names(formals(srv_g_scatterplotmatrix.picks))], transformators = transformators, - datanames = teal.transform::get_extract_datanames(variables) + datanames = { + datanames <- datanames(variables) + if (length(datanames)) datanames else "all" + } ) attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the scatterplot matrix module -ui_g_scatterplotmatrix.default <- function(id, ...) { - args <- list(...) - is_single_dataset_value <- teal.transform::is_single_dataset(args$variables) +ui_g_scatterplotmatrix.picks <- function(id, + variables, + pre_output, + post_output, + decorators) { + checkmate::assert_list(variables, "picks", names = "named") ns <- NS(id) teal.widgets::standard_layout( output = teal.widgets::white_small_well( @@ -64,15 +69,15 @@ ui_g_scatterplotmatrix.default <- function(id, ...) { ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(args$variables), - teal.transform::data_extract_ui( - id = ns("variables"), - label = "Variables", - data_extract_spec = args$variables, - is_single_dataset = is_single_dataset_value + tagList( + lapply(names(variables), function(id) { + teal::teal_nav_item( + teal.transform::module_input_ui(id = ns(id), spec = variables[[id]]) + ) + }) ), tags$hr(), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "plot")), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( open = TRUE, bslib::accordion_panel( @@ -101,66 +106,55 @@ ui_g_scatterplotmatrix.default <- function(id, ...) { forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") ), - pre_output = args$pre_output, - post_output = args$post_output + pre_output = pre_output, + post_output = post_output ) } # Server function for the scatterplot matrix module -srv_g_scatterplotmatrix.default <- function(id, - data, - variables, - plot_height, - plot_width, - decorators) { +srv_g_scatterplotmatrix.picks <- function(id, + data, + variables, + plot_height, + plot_width, + decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(variables = variables), - datasets = data, - select_validation_rule = list( - variables = ~ if (length(.) <= 1) "Please select at least 2 columns." - ) + selectors <- teal.transform::module_input_srv( + spec = variables, + data = data ) - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - teal.transform::compose_and_enable_validators(iv, selector_list) - }) + validated_q <- reactive({ + obj <- req(data()) - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list - ) + input_ids <- sprintf("%s-variables-selected", names(variables)) + selected_variables <- unname(unlist(lapply(selectors, function(selector) selector()$variables$selected))) + validate_input( + inputId = input_ids, # validate all inputs where variable can be selected + condition = length(selected_variables) > 1, + message = "Please select at least 2 columns" + ) - anl_merged_q <- reactive({ - req(anl_merged_input()) - obj <- data() teal.reporter::teal_card(obj) <- c( teal.reporter::teal_card("# Scatter Plot Matrix"), teal.reporter::teal_card(obj), teal.reporter::teal_card("## Module's code") ) - qenv <- teal.code::eval_code(obj, 'library("dplyr");library("lattice")') # nolint quotes - teal.code::eval_code(qenv, as.expression(anl_merged_input()$expr)) + teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) + merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merge_vars <- reactive(unname(unlist(merged$merge_vars()))) # plot output_q <- reactive({ - teal::validate_inputs(iv_r()) - - qenv <- merged$anl_q_r() - ANL <- qenv[["ANL"]] - - cols_names <- merged$anl_input_r()$columns_source$variables + qenv <- req(merged$data()) + anl <- qenv[["anl"]] + cols_names <- merge_vars() alpha <- input$alpha cex <- input$cex add_cor <- input$cor @@ -173,19 +167,19 @@ srv_g_scatterplotmatrix.default <- function(id, "na.fail" } - teal::validate_has_data(ANL, 10) - teal::validate_has_data(ANL[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(anl, 10) + teal::validate_has_data(anl[, cols_names, drop = FALSE], 10, complete = TRUE, allow_inf = FALSE) # get labels and proper variable names - varnames <- varname_w_label(cols_names, ANL, wrap_width = 20) + varnames <- varname_w_label(cols_names, anl, wrap_width = 20) # check character columns. If any, then those are converted to factors - check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { qenv <- teal.code::eval_code( qenv, substitute( - expr = ANL <- ANL[, cols_names] %>% + expr = anl <- anl[, cols_names] %>% dplyr::mutate_if(is.character, as.factor) %>% droplevels(), env = list(cols_names = cols_names) @@ -195,7 +189,7 @@ srv_g_scatterplotmatrix.default <- function(id, qenv <- teal.code::eval_code( qenv, substitute( - expr = ANL <- ANL[, cols_names] %>% + expr = anl <- anl[, cols_names] %>% droplevels(), env = list(cols_names = cols_names) ) @@ -216,7 +210,7 @@ srv_g_scatterplotmatrix.default <- function(id, substitute( expr = { plot <- lattice::splom( - ANL, + anl, varnames = varnames_value, panel = function(x, y, ...) { lattice::panel.splom(x = x, y = y, ...) @@ -258,7 +252,7 @@ srv_g_scatterplotmatrix.default <- function(id, substitute( expr = { plot <- lattice::splom( - ANL, + anl, varnames = varnames_value, pch = 16, alpha = alpha_value, @@ -293,11 +287,9 @@ srv_g_scatterplotmatrix.default <- function(id, # show a message if conversion to factors took place output$message <- renderText({ - req(iv_r()$is_valid()) - req(selector_list()$variables()) - ANL <- merged$anl_q_r()[["ANL"]] - cols_names <- unique(unname(do.call(c, merged$anl_input_r()$columns_source))) - check_char <- vapply(ANL[, cols_names], is.character, logical(1)) + cols_names <- req(merge_vars()) + anl <- merged$data()[["anl"]] + check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { is_single <- sum(check_char) == 1 paste( diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 3375f68f9..ce5f18e31 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -176,29 +176,31 @@ tm_t_crosstable <- function(label = "Cross Table", decorators = list()) { UseMethod("tm_t_crosstable", x) } + #' @export -tm_t_crosstable <- function(label = "Cross Table", - x, - y, - show_percentage = TRUE, - show_total = TRUE, - remove_zero_columns = FALSE, - pre_output = NULL, - post_output = NULL, - basic_table_args = teal.widgets::basic_table_args(), - transformators = list(), - decorators = list()) { +tm_t_crosstable.default <- function(label = "Cross Table", + x, + y, + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { message("Initializing tm_t_crosstable") + # Normalize the parameters + if (inherits(x, "data_extract_spec")) x <- list(x) + if (inherits(y, "data_extract_spec")) y <- list(y) + # Start of assertions checkmate::assert_string(label) - checkmate::assert_class(x, "picks") + checkmate::assert_list(x, types = "data_extract_spec") - checkmate::assert_class(y, "picks") - if (isTRUE(attr(y$variables, "multiple"))) { - warning("`y` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") - attr(y$variables, "multiple") <- FALSE - } + checkmate::assert_list(y, types = "data_extract_spec") + assert_single_selection(y) checkmate::assert_flag(show_percentage) checkmate::assert_flag(show_total) @@ -210,27 +212,36 @@ tm_t_crosstable <- function(label = "Cross Table", assert_decorators(decorators, "table") # End of assertions - args <- as.list(environment()) + # Make UI args + ui_args <- as.list(environment()) + + server_args <- list( + label = label, + x = x, + y = y, + remove_zero_columns = remove_zero_columns, + basic_table_args = basic_table_args, + decorators = decorators + ) + ans <- module( label = label, - server = srv_t_crosstable.picks, - ui = ui_t_crosstable.picks, - ui_args = args[names(args) %in% names(formals(ui_t_crosstable.picks))], - server_args = args[names(args) %in% names(formals(srv_t_crosstable.picks))], + server = srv_t_crosstable.default, + ui = ui_t_crosstable.default, + ui_args = ui_args, + server_args = server_args, transformators = transformators, - datanames = { - datanames <- datanames(list(x, y)) - if (length(datanames)) datanames else "all" - } + datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) ) - attr(ans, "teal_bookmarkable") <- TRUE ans } # UI function for the cross-table module -ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, decorators) { +ui_t_crosstable.default <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { + args <- list(...) ns <- NS(id) + is_single_dataset <- teal.transform::is_single_dataset(x, y) join_default_options <- c( "Full Join" = "dplyr::full_join", @@ -246,19 +257,15 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Row values"), - teal.transform::module_input_ui(id = ns("x"), spec = x) - ), - teal::teal_nav_item( - label = tags$strong("Column values"), - teal.transform::module_input_ui(id = ns("y"), spec = y) - ), - shinyWidgets::pickerInput( + teal.transform::datanames_input(list(x, y)), + teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset), + teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset), + teal.widgets::optionalSelectInput( ns("join_fun"), label = "Row to Column type of join", choices = join_default_options, - selected = join_default_options[1] + selected = join_default_options[1], + multiple = FALSE ), tags$hr(), bslib::accordion( @@ -270,7 +277,7 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) ) ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")) + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table")) ), forms = tagList( teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") @@ -281,43 +288,40 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ } # Server function for the cross-table module -srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { +srv_t_crosstable.default <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(x = x, y = y), data = data) - - validated_q <- reactive({ - validate_input( - inputId = "x-variables-selected", - condition = length(selectors$x()$variables$selected) > 0, - message = "Please define column(s) for row variables." - ) - validate_input( - inputId = "y-variables-selected", - condition = length(selectors$y()$variables$selected) == 1, - message = "Please define column for column variable." + selector_list <- teal.transform::data_extract_multiple_srv( + data_extract = list(x = x, y = y), + datasets = data, + select_validation_rule = list( + x = shinyvalidate::sv_required("Please define column for row variable."), + y = shinyvalidate::sv_required("Please define column for column variable.") ) + ) - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Cross Table"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes + iv_r <- reactive({ + iv <- shinyvalidate::InputValidator$new() + iv$add_rule("join_fun", function(value) { + if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { + if (!shinyvalidate::input_provided(value)) { + "Please select a joining function." + } + } + }) + teal.transform::compose_and_enable_validators(iv, selector_list) }) observeEvent( eventExpr = { - selectors$x() - selectors$y() + req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) + list(selector_list()$x(), selector_list()$y()) }, handlerExpr = { - if (identical(selectors$x()$datasets$selected, selectors$x()$datasets$selected)) { + if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { shinyjs::hide("join_fun") } else { shinyjs::show("join_fun") @@ -325,31 +329,58 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b } ) - merged <- teal.transform::merge_srv( - "merge", - data = validated_q, - selectors = selectors, - output_name = "anl", - join_fun = input$join_fun # todo: make reactive + merge_function <- reactive({ + if (is.null(input$join_fun)) { + "dplyr::full_join" + } else { + input$join_fun + } + }) + + anl_merged_input <- teal.transform::merge_expression_srv( + datasets = data, + selector_list = selector_list, + merge_function = merge_function + ) + qenv <- reactive({ + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Cross Table"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes + }) + anl_merged_q <- reactive({ + req(anl_merged_input()) + qenv() %>% + teal.code::eval_code(as.expression(anl_merged_input()$expr)) + }) + + merged <- list( + anl_input_r = anl_merged_input, + anl_q_r = anl_merged_q ) output_q <- reactive({ - anl <- merged$data()[["anl"]] + teal::validate_inputs(iv_r()) + ANL <- merged$anl_q_r()[["ANL"]] # As this is a summary - x_name <- merged$merge_vars()$x - y_name <- merged$merge_vars()$y + x_name <- as.vector(merged$anl_input_r()$columns_source$x) + y_name <- as.vector(merged$anl_input_r()$columns_source$y) - teal::validate_has_data(anl, 3) - teal::validate_has_data(anl[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) + teal::validate_has_data(ANL, 3) + teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) validate(need( - all(vapply(anl[x_name], is_allowed_class, logical(1))), + all(vapply(ANL[x_name], is_allowed_class, logical(1))), "Selected row variable has an unsupported data type." )) validate(need( - is_allowed_class(anl[[y_name]]), + is_allowed_class(ANL[[y_name]]), "Selected column variable has an unsupported data type." )) @@ -359,69 +390,90 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b plot_title <- paste( "Cross-Table of", - paste0(varname_w_label(x_name, anl), collapse = ", "), + paste0(varname_w_label(x_name, ANL), collapse = ", "), "(rows)", "vs.", - varname_w_label(y_name, anl), + varname_w_label(y_name, ANL), "(columns)" ) - labels_vec <- vapply(x_name, varname_w_label, character(1), anl) + labels_vec <- vapply( + x_name, + varname_w_label, + character(1), + ANL + ) - obj <- merged$data() + obj <- merged$anl_q_r() teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") - obj <- within( + obj <- teal.code::eval_code( obj, - expr = title <- plot_title, - plot_title = plot_title - ) %>% - within( + substitute( expr = { - table <- basic_tables %>% - split_call %>% # styler: off - rtables::add_colcounts() %>% - tern::analyze_vars( - vars = x_name, - var_labels = labels_vec, - na.rm = FALSE, - denom = "N_col", - .stats = c("mean_sd", "median", "range", count_value) - ) + title <- plot_title }, - basic_tables = teal.widgets::parse_basic_table_args( - basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) - ), - split_call = if (show_total) { - substitute( - expr = rtables::split_cols_by( - y_name, - split_fun = rtables::add_overall_level(label = "Total", first = FALSE) + env = list(plot_title = plot_title) + ) + ) %>% + teal.code::eval_code( + substitute( + expr = { + table <- basic_tables %>% + split_call %>% # styler: off + rtables::add_colcounts() %>% + tern::analyze_vars( + vars = x_name, + var_labels = labels_vec, + na.rm = FALSE, + denom = "N_col", + .stats = c("mean_sd", "median", "range", count_value) + ) + }, + env = list( + basic_tables = teal.widgets::parse_basic_table_args( + basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) ), - env = list(y_name = y_name) + split_call = if (show_total) { + substitute( + expr = rtables::split_cols_by( + y_name, + split_fun = rtables::add_overall_level(label = "Total", first = FALSE) + ), + env = list(y_name = y_name) + ) + } else { + substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) + }, + x_name = x_name, + labels_vec = labels_vec, + count_value = ifelse(show_percentage, "count_fraction", "count") ) - } else { - substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) - }, - x_name = x_name, - labels_vec = labels_vec, - count_value = ifelse(show_percentage, "count_fraction", "count") + ) ) %>% - within(anl <- tern::df_explicit_na(anl)) - - obj <- if (remove_zero_columns) { - within( - obj, - { - anl[[y_name]] <- droplevels(anl[[y_name]]) - table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]) - }, - y_name = y_name + teal.code::eval_code( + expression(ANL <- tern::df_explicit_na(ANL)) ) + + if (remove_zero_columns) { + obj <- obj %>% + teal.code::eval_code( + substitute( + expr = { + ANL[[y_name]] <- droplevels(ANL[[y_name]]) + table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) + }, + env = list(y_name = y_name) + ) + ) } else { - within( - obj, - table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]), - y_name = y_name - ) + obj <- obj %>% + teal.code::eval_code( + substitute( + expr = { + table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) + }, + env = list(y_name = y_name) + ) + ) } obj }) @@ -436,8 +488,8 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b output$title <- renderText(req(decorated_output_q())[["title"]]) table_r <- reactive({ - obj <- req(decorated_output_q()) - tail(teal.code::get_outputs(obj), 1)[[1]] + req(iv_r()$is_valid()) + req(decorated_output_q())[["table"]] }) teal.widgets::table_with_settings_srv( diff --git a/R/tm_t_crosstable_old.R b/R/tm_t_crosstable_old.R deleted file mode 100644 index 94b8753f2..000000000 --- a/R/tm_t_crosstable_old.R +++ /dev/null @@ -1,331 +0,0 @@ -#' @export -tm_t_crosstable.default <- function(label = "Cross Table", - x, - y, - show_percentage = TRUE, - show_total = TRUE, - remove_zero_columns = FALSE, - pre_output = NULL, - post_output = NULL, - basic_table_args = teal.widgets::basic_table_args(), - transformators = list(), - decorators = list()) { - message("Initializing tm_t_crosstable") - - # Normalize the parameters - if (inherits(x, "data_extract_spec")) x <- list(x) - if (inherits(y, "data_extract_spec")) y <- list(y) - - # Start of assertions - checkmate::assert_string(label) - checkmate::assert_list(x, types = "data_extract_spec") - - checkmate::assert_list(y, types = "data_extract_spec") - assert_single_selection(y) - - checkmate::assert_flag(show_percentage) - checkmate::assert_flag(show_total) - checkmate::assert_flag(remove_zero_columns) - checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) - checkmate::assert_class(basic_table_args, classes = "basic_table_args") - - assert_decorators(decorators, "table") - # End of assertions - - # Make UI args - ui_args <- as.list(environment()) - - server_args <- list( - label = label, - x = x, - y = y, - remove_zero_columns = remove_zero_columns, - basic_table_args = basic_table_args, - decorators = decorators - ) - - ans <- module( - label = label, - server = srv_t_crosstable.default, - ui = ui_t_crosstable.default, - ui_args = ui_args, - server_args = server_args, - transformators = transformators, - datanames = teal.transform::get_extract_datanames(list(x = x, y = y)) - ) - attr(ans, "teal_bookmarkable") <- TRUE - ans -} - -# UI function for the cross-table module -ui_t_crosstable.default <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, ...) { - args <- list(...) - ns <- NS(id) - is_single_dataset <- teal.transform::is_single_dataset(x, y) - - join_default_options <- c( - "Full Join" = "dplyr::full_join", - "Inner Join" = "dplyr::inner_join", - "Left Join" = "dplyr::left_join", - "Right Join" = "dplyr::right_join" - ) - - teal.widgets::standard_layout( - output = teal.widgets::white_small_well( - textOutput(ns("title")), - teal.widgets::table_with_settings_ui(ns("table")) - ), - encoding = tags$div( - tags$label("Encodings", class = "text-primary"), - teal.transform::datanames_input(list(x, y)), - teal.transform::data_extract_ui(ns("x"), label = "Row values", x, is_single_dataset = is_single_dataset), - teal.transform::data_extract_ui(ns("y"), label = "Column values", y, is_single_dataset = is_single_dataset), - teal.widgets::optionalSelectInput( - ns("join_fun"), - label = "Row to Column type of join", - choices = join_default_options, - selected = join_default_options[1], - multiple = FALSE - ), - tags$hr(), - bslib::accordion( - open = TRUE, - bslib::accordion_panel( - title = "Table settings", - checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage), - checkboxInput(ns("show_total"), "Show total column", value = show_total), - checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) - ) - ), - ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(args$decorators, "table")) - ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), - pre_output = pre_output, - post_output = post_output - ) -} - -# Server function for the cross-table module -srv_t_crosstable.default <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - - selector_list <- teal.transform::data_extract_multiple_srv( - data_extract = list(x = x, y = y), - datasets = data, - select_validation_rule = list( - x = shinyvalidate::sv_required("Please define column for row variable."), - y = shinyvalidate::sv_required("Please define column for column variable.") - ) - ) - - iv_r <- reactive({ - iv <- shinyvalidate::InputValidator$new() - iv$add_rule("join_fun", function(value) { - if (!identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { - if (!shinyvalidate::input_provided(value)) { - "Please select a joining function." - } - } - }) - teal.transform::compose_and_enable_validators(iv, selector_list) - }) - - observeEvent( - eventExpr = { - req(!is.null(selector_list()$x()) && !is.null(selector_list()$y())) - list(selector_list()$x(), selector_list()$y()) - }, - handlerExpr = { - if (identical(selector_list()$x()$dataname, selector_list()$y()$dataname)) { - shinyjs::hide("join_fun") - } else { - shinyjs::show("join_fun") - } - } - ) - - merge_function <- reactive({ - if (is.null(input$join_fun)) { - "dplyr::full_join" - } else { - input$join_fun - } - }) - - anl_merged_input <- teal.transform::merge_expression_srv( - datasets = data, - selector_list = selector_list, - merge_function = merge_function - ) - qenv <- reactive({ - obj <- data() - teal.reporter::teal_card(obj) <- - c( - teal.reporter::teal_card("# Cross Table"), - teal.reporter::teal_card(obj), - teal.reporter::teal_card("## Module's code") - ) - teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes - }) - anl_merged_q <- reactive({ - req(anl_merged_input()) - qenv() %>% - teal.code::eval_code(as.expression(anl_merged_input()$expr)) - }) - - merged <- list( - anl_input_r = anl_merged_input, - anl_q_r = anl_merged_q - ) - - output_q <- reactive({ - teal::validate_inputs(iv_r()) - ANL <- merged$anl_q_r()[["ANL"]] - - # As this is a summary - x_name <- as.vector(merged$anl_input_r()$columns_source$x) - y_name <- as.vector(merged$anl_input_r()$columns_source$y) - - teal::validate_has_data(ANL, 3) - teal::validate_has_data(ANL[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) - - is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) - validate(need( - all(vapply(ANL[x_name], is_allowed_class, logical(1))), - "Selected row variable has an unsupported data type." - )) - validate(need( - is_allowed_class(ANL[[y_name]]), - "Selected column variable has an unsupported data type." - )) - - show_percentage <- input$show_percentage - show_total <- input$show_total - remove_zero_columns <- input$remove_zero_columns - - plot_title <- paste( - "Cross-Table of", - paste0(varname_w_label(x_name, ANL), collapse = ", "), - "(rows)", "vs.", - varname_w_label(y_name, ANL), - "(columns)" - ) - - labels_vec <- vapply( - x_name, - varname_w_label, - character(1), - ANL - ) - - obj <- merged$anl_q_r() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") - obj <- teal.code::eval_code( - obj, - substitute( - expr = { - title <- plot_title - }, - env = list(plot_title = plot_title) - ) - ) %>% - teal.code::eval_code( - substitute( - expr = { - table <- basic_tables %>% - split_call %>% # styler: off - rtables::add_colcounts() %>% - tern::analyze_vars( - vars = x_name, - var_labels = labels_vec, - na.rm = FALSE, - denom = "N_col", - .stats = c("mean_sd", "median", "range", count_value) - ) - }, - env = list( - basic_tables = teal.widgets::parse_basic_table_args( - basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) - ), - split_call = if (show_total) { - substitute( - expr = rtables::split_cols_by( - y_name, - split_fun = rtables::add_overall_level(label = "Total", first = FALSE) - ), - env = list(y_name = y_name) - ) - } else { - substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) - }, - x_name = x_name, - labels_vec = labels_vec, - count_value = ifelse(show_percentage, "count_fraction", "count") - ) - ) - ) %>% - teal.code::eval_code( - expression(ANL <- tern::df_explicit_na(ANL)) - ) - - if (remove_zero_columns) { - obj <- obj %>% - teal.code::eval_code( - substitute( - expr = { - ANL[[y_name]] <- droplevels(ANL[[y_name]]) - table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) - }, - env = list(y_name = y_name) - ) - ) - } else { - obj <- obj %>% - teal.code::eval_code( - substitute( - expr = { - table <- rtables::build_table(lyt = table, df = ANL[order(ANL[[y_name]]), ]) - }, - env = list(y_name = y_name) - ) - ) - } - obj - }) - - decorated_output_q <- srv_decorate_teal_data( - id = "decorator", - data = output_q, - decorators = select_decorators(decorators, "table"), - expr = quote(table) - ) - - output$title <- renderText(req(decorated_output_q())[["title"]]) - - table_r <- reactive({ - req(iv_r()$is_valid()) - req(decorated_output_q())[["table"]] - }) - - teal.widgets::table_with_settings_srv( - id = "table", - table_r = table_r - ) - - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Show R Code for Cross-Table" - ) - decorated_output_q - }) -} diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R new file mode 100644 index 000000000..c4337351c --- /dev/null +++ b/R/tm_t_crosstable_picks.R @@ -0,0 +1,280 @@ +#' @export +tm_t_crosstable.picks <- function(label = "Cross Table", + x, + y, + show_percentage = TRUE, + show_total = TRUE, + remove_zero_columns = FALSE, + pre_output = NULL, + post_output = NULL, + basic_table_args = teal.widgets::basic_table_args(), + transformators = list(), + decorators = list()) { + message("Initializing tm_t_crosstable") + + # Start of assertions + checkmate::assert_string(label) + checkmate::assert_class(x, "picks") + + checkmate::assert_class(y, "picks") + if (isTRUE(attr(y$variables, "multiple"))) { + warning("`y` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + attr(y$variables, "multiple") <- FALSE + } + + checkmate::assert_flag(show_percentage) + checkmate::assert_flag(show_total) + checkmate::assert_flag(remove_zero_columns) + checkmate::assert_multi_class(pre_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_multi_class(post_output, c("shiny.tag", "shiny.tag.list", "html"), null.ok = TRUE) + checkmate::assert_class(basic_table_args, classes = "basic_table_args") + + assert_decorators(decorators, "table") + # End of assertions + + args <- as.list(environment()) + ans <- module( + label = label, + server = srv_t_crosstable.picks, + ui = ui_t_crosstable.picks, + ui_args = args[names(args) %in% names(formals(ui_t_crosstable.picks))], + server_args = args[names(args) %in% names(formals(srv_t_crosstable.picks))], + transformators = transformators, + datanames = { + datanames <- datanames(list(x, y)) + if (length(datanames)) datanames else "all" + } + ) + + attr(ans, "teal_bookmarkable") <- TRUE + ans +} + +# UI function for the cross-table module +ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_zero_columns, pre_output, post_output, decorators) { + ns <- NS(id) + + join_default_options <- c( + "Full Join" = "dplyr::full_join", + "Inner Join" = "dplyr::inner_join", + "Left Join" = "dplyr::left_join", + "Right Join" = "dplyr::right_join" + ) + + teal.widgets::standard_layout( + output = teal.widgets::white_small_well( + textOutput(ns("title")), + teal.widgets::table_with_settings_ui(ns("table")) + ), + encoding = tags$div( + tags$label("Encodings", class = "text-primary"), + teal::teal_nav_item( + label = tags$strong("Row values"), + teal.transform::module_input_ui(id = ns("x"), spec = x) + ), + teal::teal_nav_item( + label = tags$strong("Column values"), + teal.transform::module_input_ui(id = ns("y"), spec = y) + ), + shinyWidgets::pickerInput( + ns("join_fun"), + label = "Row to Column type of join", + choices = join_default_options, + selected = join_default_options[1] + ), + tags$hr(), + bslib::accordion( + open = TRUE, + bslib::accordion_panel( + title = "Table settings", + checkboxInput(ns("show_percentage"), "Show column percentage", value = show_percentage), + checkboxInput(ns("show_total"), "Show total column", value = show_total), + checkboxInput(ns("remove_zero_columns"), "Remove zero-only columns", value = remove_zero_columns) + ) + ), + ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")) + ), + forms = tagList( + teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") + ), + pre_output = pre_output, + post_output = post_output + ) +} + +# Server function for the cross-table module +srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, basic_table_args, decorators) { + checkmate::assert_class(data, "reactive") + checkmate::assert_class(isolate(data()), "teal_data") + moduleServer(id, function(input, output, session) { + teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") + + selectors <- teal.transform::module_input_srv(spec = list(x = x, y = y), data = data) + + validated_q <- reactive({ + validate_input( + inputId = "x-variables-selected", + condition = length(selectors$x()$variables$selected) > 0, + message = "Please define column(s) for row variables." + ) + validate_input( + inputId = "y-variables-selected", + condition = length(selectors$y()$variables$selected) == 1, + message = "Please define column for column variable." + ) + + obj <- data() + teal.reporter::teal_card(obj) <- + c( + teal.reporter::teal_card("# Cross Table"), + teal.reporter::teal_card(obj), + teal.reporter::teal_card("## Module's code") + ) + teal.code::eval_code(obj, 'library("rtables");library("tern");library("dplyr")') # nolint quotes + }) + + observeEvent( + eventExpr = { + selectors$x() + selectors$y() + }, + handlerExpr = { + if (identical(selectors$x()$datasets$selected, selectors$x()$datasets$selected)) { + shinyjs::hide("join_fun") + } else { + shinyjs::show("join_fun") + } + } + ) + + merged <- teal.transform::merge_srv( + "merge", + data = validated_q, + selectors = selectors, + output_name = "anl", + join_fun = input$join_fun # todo: make reactive + ) + + output_q <- reactive({ + anl <- merged$data()[["anl"]] + + # As this is a summary + x_name <- merged$merge_vars()$x + y_name <- merged$merge_vars()$y + + teal::validate_has_data(anl, 3) + teal::validate_has_data(anl[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) + + is_allowed_class <- function(x) is.numeric(x) || is.factor(x) || is.character(x) || is.logical(x) + validate(need( + all(vapply(anl[x_name], is_allowed_class, logical(1))), + "Selected row variable has an unsupported data type." + )) + validate(need( + is_allowed_class(anl[[y_name]]), + "Selected column variable has an unsupported data type." + )) + + show_percentage <- input$show_percentage + show_total <- input$show_total + remove_zero_columns <- input$remove_zero_columns + + plot_title <- paste( + "Cross-Table of", + paste0(varname_w_label(x_name, anl), collapse = ", "), + "(rows)", "vs.", + varname_w_label(y_name, anl), + "(columns)" + ) + + labels_vec <- vapply(x_name, varname_w_label, character(1), anl) + + obj <- merged$data() + teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "# Table") + obj <- within( + obj, + expr = title <- plot_title, + plot_title = plot_title + ) %>% + within( + expr = { + table <- basic_tables %>% + split_call %>% # styler: off + rtables::add_colcounts() %>% + tern::analyze_vars( + vars = x_name, + var_labels = labels_vec, + na.rm = FALSE, + denom = "N_col", + .stats = c("mean_sd", "median", "range", count_value) + ) + }, + basic_tables = teal.widgets::parse_basic_table_args( + basic_table_args = teal.widgets::resolve_basic_table_args(basic_table_args) + ), + split_call = if (show_total) { + substitute( + expr = rtables::split_cols_by( + y_name, + split_fun = rtables::add_overall_level(label = "Total", first = FALSE) + ), + env = list(y_name = y_name) + ) + } else { + substitute(rtables::split_cols_by(y_name), env = list(y_name = y_name)) + }, + x_name = x_name, + labels_vec = labels_vec, + count_value = ifelse(show_percentage, "count_fraction", "count") + ) %>% + within(anl <- tern::df_explicit_na(anl)) + + obj <- if (remove_zero_columns) { + within( + obj, + { + anl[[y_name]] <- droplevels(anl[[y_name]]) + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]) + }, + y_name = y_name + ) + } else { + within( + obj, + table <- rtables::build_table(lyt = table, df = anl[order(anl[[y_name]]), ]), + y_name = y_name + ) + } + obj + }) + + decorated_output_q <- srv_decorate_teal_data( + id = "decorator", + data = output_q, + decorators = select_decorators(decorators, "table"), + expr = quote(table) + ) + + output$title <- renderText(req(decorated_output_q())[["title"]]) + + table_r <- reactive({ + obj <- req(decorated_output_q()) + tail(teal.code::get_outputs(obj), 1)[[1]] + }) + + teal.widgets::table_with_settings_srv( + id = "table", + table_r = table_r + ) + + # Render R code. + source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) + + teal.widgets::verbatim_popup_srv( + id = "rcode", + verbatim_content = source_code_r, + title = "Show R Code for Cross-Table" + ) + decorated_output_q + }) +} From ea0bae03735f0fc10cde1bacfd0e78691e360167 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 9 Oct 2025 15:10:49 +0200 Subject: [PATCH 144/158] roxy --- NAMESPACE | 3 ++- man/get_scatterplotmatrix_stats.Rd | 2 +- man/tm_a_regression.Rd | 6 +++--- man/tm_g_bivariate.Rd | 14 +++++++------- 4 files changed, 13 insertions(+), 12 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index 852b3de84..4a527c7dc 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -24,6 +24,8 @@ S3method(tm_g_scatterplot,default) S3method(tm_g_scatterplot,picks) S3method(tm_g_scatterplotmatrix,default) S3method(tm_g_scatterplotmatrix,picks) +S3method(tm_t_crosstable,default) +S3method(tm_t_crosstable,picks) export(add_facet_labels) export(get_scatterplotmatrix_stats) export(tm_a_pca) @@ -48,7 +50,6 @@ export(tm_p_swimlane) export(tm_p_waterfall) export(tm_rmarkdown) export(tm_t_crosstable) -export(tm_t_crosstable.default) export(tm_t_reactables) export(tm_variable_browser) import(ggmosaic) diff --git a/man/get_scatterplotmatrix_stats.Rd b/man/get_scatterplotmatrix_stats.Rd index ba6f41952..bd4c71f38 100644 --- a/man/get_scatterplotmatrix_stats.Rd +++ b/man/get_scatterplotmatrix_stats.Rd @@ -1,6 +1,6 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/tm_g_scatterplotmatrix.R, -% R/tm_g_scatterplotmatrix_old.R +% R/tm_g_scatterplotmatrix_picks.R \name{get_scatterplotmatrix_stats} \alias{get_scatterplotmatrix_stats} \title{Get stats for x-y pairs in scatterplot matrix} diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 51df8f750..8c113d8e7 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -25,11 +25,11 @@ tm_a_regression( } \arguments{ \item{regressor}{(\code{picks}) Specification for regressor variables selection. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting variables +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting variables to use as regressors in the regression model. \code{variables(multiple = TRUE)} allowed.} \item{response}{(\code{picks}) Specification for response variable selection. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a single numeric variable +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting a single numeric variable to use as the response in the regression model. \code{variables(multiple = TRUE)} not allowed.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -100,7 +100,7 @@ decorator for tables or plots included in the module output reported. The decorators are applied to the respective output objects.} \item{outlier}{(\code{picks}) Optional specification for outlier label variable selection. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a factor or character variable +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting a factor or character variable to label outlier points on the plots.} } \value{ diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index b95d33303..f558f6c8b 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -33,17 +33,17 @@ tm_g_bivariate( ) } \arguments{ -\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. +\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}. Can be numeric, factor or character. No empty selections are allowed.} -\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. +\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}. Can be numeric, factor or character.} \item{row_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting rows. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} \item{col_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting columns. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} \item{facet}{(\code{logical}) optional, specifies whether the facet encodings \code{ui} elements are toggled on and shown to the user by default. Defaults to \code{TRUE} if either \code{row_facet} or \code{column_facet} @@ -51,15 +51,15 @@ are supplied.} \item{color}{(\code{picks}) optional, specification of the data variable(s) selected for the outline color inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} \item{fill}{(\code{picks}) optional, specification of the data variable(s) selected for the fill color inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} \item{size}{(\code{picks}) optional, specification of the data variable(s) selected for the size of \code{geom_point} plots inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} \item{use_density}{(\code{logical}) optional, indicates whether to plot density (\code{TRUE}) or frequency (\code{FALSE}). Defaults to frequency (\code{FALSE}).} From a71bb7f5a0955284da6045253879994a08e2da38 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Thu, 9 Oct 2025 15:18:06 +0200 Subject: [PATCH 145/158] remove src --- R/tm_a_pca_picks.R | 16 +--------------- R/tm_a_regression_picks.R | 15 +-------------- R/tm_g_association_picks.R | 14 +------------- R/tm_g_bivariate_picks.R | 16 +--------------- R/tm_g_distribution_picks.R | 12 ------------ R/tm_g_response_picks.R | 15 +-------------- R/tm_g_scatterplot_picks.R | 15 +-------------- R/tm_g_scatterplotmatrix_picks.R | 15 +-------------- R/tm_t_crosstable_picks.R | 15 +-------------- 9 files changed, 8 insertions(+), 125 deletions(-) diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R index 7431a5aa1..98ad4601d 100644 --- a/R/tm_a_pca_picks.R +++ b/R/tm_a_pca_picks.R @@ -219,9 +219,6 @@ ui_a_pca.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -894,8 +891,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args graph_align = "center" ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) - # tables ---- output$tbl_importance <- renderTable( expr = { @@ -923,15 +918,6 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args req("eigenvector" %in% input$tables_display) }) - - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "R Code for PCA" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_q) }) } diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 05bcb11bc..345f07b8d 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -225,9 +225,6 @@ ui_a_regression.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -787,20 +784,10 @@ srv_a_regression.picks <- function(id, width = plot_width ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) - output$text <- renderText({ paste(utils::capture.output(summary(fitted()))[-1], collapse = "\n") }) - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "R code for the regression plot", - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_q) }) } diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R index 999306c29..307d4a4e9 100644 --- a/R/tm_g_association_picks.R +++ b/R/tm_g_association_picks.R @@ -137,9 +137,6 @@ ui_g_association.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -361,18 +358,9 @@ srv_g_association.picks <- function(id, width = plot_width ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_grob_q) output$title <- renderText(output_q()[["title"]]) - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Association Plot" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_grob_q) }) } diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 215033135..994c23a34 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -244,9 +244,6 @@ ui_g_bivariate.picks <- function(id, ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -479,17 +476,6 @@ srv_g_bivariate.picks <- function(id, width = plot_width ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q_facets) - - # Render R code. - - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Bivariate Plot" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_q_facets) }) } diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R index baff37348..c5ac82003 100644 --- a/R/tm_g_distribution_picks.R +++ b/R/tm_g_distribution_picks.R @@ -188,9 +188,6 @@ ui_g_distribution.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -519,15 +516,6 @@ srv_g_distribution.picks <- function(id, # ) # out_q # }) - - # Render R code. - # source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - - # teal.widgets::verbatim_popup_srv( - # id = "rcode", - # verbatim_content = source_code_r, - # title = "R Code for distribution" - # ) NULL }) } diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R index 90c0823b6..e0e3abdc2 100644 --- a/R/tm_g_response_picks.R +++ b/R/tm_g_response_picks.R @@ -141,9 +141,6 @@ ui_g_response.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -390,16 +387,6 @@ srv_g_response.picks <- function(id, width = plot_width ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) - - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Show R Code for Response" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_plot_q) }) } diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index f7b509348..c81c1257f 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -244,9 +244,6 @@ ui_g_scatterplot.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -758,8 +755,6 @@ srv_g_scatterplot.picks <- function(id, click = TRUE ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_plot_q) - output$data_table <- DT::renderDataTable({ plot_brush <- pws$brush() @@ -788,14 +783,6 @@ srv_g_scatterplot.picks <- function(id, } }) - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "R Code for scatterplot" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_plot_q) }) } diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R index fb6703153..e7c967b0e 100644 --- a/R/tm_g_scatterplotmatrix_picks.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -103,9 +103,6 @@ ui_g_scatterplotmatrix.picks <- function(id, ) ) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -283,8 +280,6 @@ srv_g_scatterplotmatrix.picks <- function(id, width = plot_width ) - decorated_output_dims_q <- set_chunk_dims(pws, decorated_output_q) - # show a message if conversion to factors took place output$message <- renderText({ cols_names <- req(merge_vars()) @@ -305,15 +300,7 @@ srv_g_scatterplotmatrix.picks <- function(id, } }) - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_dims_q()))) - - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Show R Code for Scatterplotmatrix" - ) - decorated_output_dims_q + set_chunk_dims(pws, decorated_output_q) }) } diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index c4337351c..7c15f41ca 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -94,9 +94,6 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ ), ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "table")) ), - forms = tagList( - teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") - ), pre_output = pre_output, post_output = post_output ) @@ -262,19 +259,9 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b tail(teal.code::get_outputs(obj), 1)[[1]] }) - teal.widgets::table_with_settings_srv( - id = "table", - table_r = table_r - ) + teal.widgets::table_with_settings_srv(id = "table", table_r = table_r) - # Render R code. - source_code_r <- reactive(teal.code::get_code(req(decorated_output_q()))) - teal.widgets::verbatim_popup_srv( - id = "rcode", - verbatim_content = source_code_r, - title = "Show R Code for Cross-Table" - ) decorated_output_q }) } From 7ec893df7b286aa6527dc50ac6bbf6ec7bbd7a81 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 20 Oct 2025 13:00:53 +0200 Subject: [PATCH 146/158] update docs --- man/srv_decorate_teal_data.Rd | 5 +++++ man/tm_a_pca.Rd | 6 ++++++ man/tm_a_regression.Rd | 6 ++++++ man/tm_data_table.Rd | 15 +++++++++++++++ man/tm_file_viewer.Rd | 3 +++ man/tm_front_page.Rd | 15 +++++++++++++++ man/tm_g_association.Rd | 6 ++++++ man/tm_g_bivariate.Rd | 6 ++++++ man/tm_g_distribution.Rd | 6 ++++++ man/tm_g_response.Rd | 6 ++++++ man/tm_g_scatterplot.Rd | 6 ++++++ man/tm_g_scatterplotmatrix.Rd | 6 ++++++ man/tm_missing_data.Rd | 15 +++++++++++++++ man/tm_outliers.Rd | 10 ++++++++-- man/tm_p_spiderplot.Rd | 6 ++++++ man/tm_p_swimlane.Rd | 3 +++ man/tm_p_waterfall.Rd | 3 +++ man/tm_rmarkdown.Rd | 12 ++++++++++++ man/tm_t_crosstable.Rd | 6 ++++++ man/tm_t_reactables.Rd | 15 +++++++++++++++ man/tm_variable_browser.Rd | 15 +++++++++++++++ 21 files changed, 169 insertions(+), 2 deletions(-) diff --git a/man/srv_decorate_teal_data.Rd b/man/srv_decorate_teal_data.Rd index d1dcbc08a..988dc6eec 100644 --- a/man/srv_decorate_teal_data.Rd +++ b/man/srv_decorate_teal_data.Rd @@ -10,6 +10,11 @@ srv_decorate_teal_data(id, data, decorators, expr) ui_decorate_teal_data(id, decorators, ...) } \arguments{ +\item{id}{(\code{character(1)}) \code{shiny} module instance id.} + +\item{data}{(\code{teal_data}, \code{teal_data_module}, or \code{reactive} returning \code{teal_data}) +The data which application will depend on.} + \item{expr}{(\code{reactive}) with expression to evaluate on the output of the decoration. It must be compatible with \code{code} argument of \code{\link[teal.code:eval_code]{teal.code::eval_code()}}. Default is \code{NULL} which won't evaluate any appending code.} diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 4d99a7cc8..911a2fd70 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -22,6 +22,9 @@ tm_a_pca( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{dat}{(\code{picks}) specifying columns used to compute PCA.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -69,6 +72,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 8c113d8e7..463541f08 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -24,6 +24,9 @@ tm_a_regression( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{regressor}{(\code{picks}) Specification for regressor variables selection. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting variables to use as regressors in the regression model. \code{variables(multiple = TRUE)} allowed.} @@ -94,6 +97,9 @@ It takes the form of \code{c(value, min, max)} and it is passed to the \code{val argument in \code{teal.widgets::optionalSliderInputValMinMax}. }} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_data_table.Rd b/man/tm_data_table.Rd index 629bc71bd..e5084fbf8 100644 --- a/man/tm_data_table.Rd +++ b/man/tm_data_table.Rd @@ -19,6 +19,9 @@ tm_data_table( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{variables_selected}{(\verb{named list}) Character vectors of the variables (i.e. columns) which should be initially shown for each dataset. Names of list elements should correspond to the names of the datasets available in the app. @@ -28,6 +31,15 @@ dataset will initially be shown.} \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} A vector of datasets which should be shown and in what order. Use \code{datanames} instead.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{dt_args}{(\verb{named list}) Additional arguments to be passed to \code{\link[DT:datatable]{DT::datatable()}} (must not include \code{data} or \code{options}).} @@ -43,6 +55,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_file_viewer.Rd b/man/tm_file_viewer.Rd index 839a410d5..a1617b9db 100644 --- a/man/tm_file_viewer.Rd +++ b/man/tm_file_viewer.Rd @@ -10,6 +10,9 @@ tm_file_viewer( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{input_path}{(\code{list}) of the input paths, optional. Each element can be: Paths can be specified as absolute paths or relative to the running directory of the application. diff --git a/man/tm_front_page.Rd b/man/tm_front_page.Rd index 60556c83a..36a288b5a 100644 --- a/man/tm_front_page.Rd +++ b/man/tm_front_page.Rd @@ -16,6 +16,9 @@ tm_front_page( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{header_text}{(\code{character} vector) text to be shown at the top of the module, for each element, if named the name is shown first in bold as a header followed by the value. The first element's header is displayed larger than the others.} @@ -32,6 +35,18 @@ element, if named the name is shown first in bold, followed by the value.} \item{show_metadata}{(\code{logical}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} indicating whether the metadata of the datasets be available on the module. Metadata shown automatically when \code{datanames} set.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 1fb99811e..39f80f394 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -27,6 +27,9 @@ tm_g_association( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{ref}{(\code{picks}) Reference variable specification created using \code{picks()}.} @@ -58,6 +61,9 @@ List names should match the following: \code{c("default", "Bivariate1", "Bivaria For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index f558f6c8b..5b4c67096 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -33,6 +33,9 @@ tm_g_bivariate( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}. Can be numeric, factor or character. No empty selections are allowed.} @@ -99,6 +102,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index 4034c9935..d643998f4 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -22,6 +22,9 @@ tm_g_distribution( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{dist_var}{(\code{picks} or \code{list} of multiple \code{picks}) Variable(s) for which the distribution will be analyzed.} @@ -62,6 +65,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, with text placed after the output to put the output into context. For example the \code{\link[shiny:helpText]{shiny::helpText()}} elements are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 30e9f7736..3432183de 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -27,6 +27,9 @@ tm_g_response( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{response}{(\code{picks}) Which variable to use as the response. The \code{picks} must not allow multiple variable selection in this case.} @@ -78,6 +81,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index b20f94f64..c50559e74 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -29,6 +29,9 @@ tm_g_scatterplot( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable names selected to plot along the x-axis by default.} @@ -93,6 +96,9 @@ The argument is merged with options variable \code{teal.ggplot2_args} and defaul For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index 4d6161972..5bc2a681f 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -16,6 +16,9 @@ tm_g_scatterplotmatrix( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{variables}{(\code{picks} or \code{list} of \code{picks}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of \code{picks} use \code{variables(..., ordered = TRUE)} if plot elements should be @@ -34,6 +37,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_missing_data.Rd b/man/tm_missing_data.Rd index 7da0234f1..ef6abaf03 100644 --- a/man/tm_missing_data.Rd +++ b/man/tm_missing_data.Rd @@ -21,12 +21,24 @@ tm_missing_data( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} \item{plot_width}{(\code{numeric}) optional, specifies the plot width as a three-element vector of \code{value}, \code{min}, and \code{max} for a slider encoding the plot width.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{parent_dataname}{(\code{character(1)}) Specifies the parent dataset name. Default is \code{ADSL} for \code{CDISC} data. If provided and exists, enables additional analysis "by subject". For non-\code{CDISC} data, this parameter can be ignored.} @@ -46,6 +58,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index f8231784c..4feff6ffc 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -19,6 +19,9 @@ tm_outliers( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{outlier_var}{(\code{picks} or \code{list} of multiple \code{picks}) Specifies variable(s) to be analyzed for outliers.} @@ -46,6 +49,9 @@ with text placed before the output to put the output into context. For example a \item{post_output}{(\code{shiny.tag}) optional, text or UI element to be displayed after the module's output, adding context or further instructions. Elements like \code{shiny::helpText()} are useful.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. @@ -193,8 +199,8 @@ if (interactive()) { \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3EpIe0VCV2HVQnldABeJURXCKvhCEREtXa4TfRX1UgwdJEQSkOgyebG+q6C1W2gyB4sVW6OiiUgKiD2v26VAcqa233+v1ZKmkW0I5pIsByTWhsP1RnM3U+5P+klksTu1MsuBsnNciI8mMDMAo6oEBUIgDirjwunhACEALJYADSWAAjPDcYnM36qTTyPx3byG-DB0P6jANrR4no1T8Gi1As4Z7OTLRonT3av164k8mE3aw49qIJviNM7f-WeT-UCOE4BJsRzuK7GO7Pd7z-agYEMGGZDhGcBRrWfLxluyb5umj6zpe14hrOKZPHmTywZm2YcrmarIYWuGcgspZwuWcZVroIoACQjnAtL8IhaH0YxmFXkR7IkTC5HQVRtGsWOzGzvOAKLiI7qgses73mGsn2vJ94jCMtAmLowKqMwlg6DYti1KGojlBArANOg7CQjRgi0NUFlUowOg4kMShgIMVxAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3JD2ioSuw6qE8roALyKiK4BV8IQiImqrXCb4K+qkGDpIiCUh0GTzI31XTmy20GQPFgq3R0USkeUQO2+3SoDlTG0+v2+rJU0g2hHNJFgOQakOh+qM5k671Jv0ksliN0pllwNnZrkRHnRgZgFHVAjyhEAcVceF08IAQgBZLAAaSwAEZ4biExnfVSaeR+G7efX4QPB-UYBtaPE9Kqfg0WoFnNOZyZaNE6W6V2vXImk-HbaHHtRBN8Rhmb37T8f6gRwnAJNiOdwXYw3R6vWe7QGBBBumg7hnAkY1nycabkmeZpg+M4XlewYzsmTy5k8MEZlmHI5qqSEFjhnILCWcJlrGla6CKAAkw5wLS-AIahdEMRhl6EeyxEwmRUGUTRLGjkxM5zgCC4iG6oJHjOd6hjJdpyXeIwjLQJi6MCqjMJYOg2LYtQhqI5QQKwDToOwkLUYItDVOZVKMDoOJDEoYCDFcQA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 740cd0a08..1f8cdcce3 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -20,6 +20,9 @@ tm_p_spiderplot( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column in \code{plot_dataname} to be used as x-axis.} @@ -46,6 +49,9 @@ by levels of \code{color_var} column.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 0404d54ec..85f7598fc 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -21,6 +21,9 @@ tm_p_swimlane( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} \item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index f33b9a993..eabdeea88 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -19,6 +19,9 @@ tm_p_waterfall( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} \item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd index f506b10b7..7b0c159ab 100644 --- a/man/tm_rmarkdown.Rd +++ b/man/tm_rmarkdown.Rd @@ -12,12 +12,24 @@ tm_rmarkdown( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{text}{(\code{character}) arbitrary Rmd code} \item{params}{A list of named parameters that override custom params specified within the YAML front-matter (e.g. specifying a dataset to read or a date range to confine output to). Pass \code{"ask"} to start an application that helps guide parameter configuration.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index 49f6d23dd..d939f1401 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -19,6 +19,9 @@ tm_t_crosstable( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{x}{(\code{picks} or \code{list} of \code{picks}) Object with all available choices with pre-selected option for variable X - row values. In case of \code{picks} use \code{variables(..., ordered = TRUE)} if table elements should be @@ -54,6 +57,9 @@ The argument is merged with options variable \code{teal.basic_table_args} and de For more details see the vignette: \code{vignette("custom-basic-table-arguments", package = "teal.widgets")}} +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd index 0db9451c3..6257d9d2f 100644 --- a/man/tm_t_reactables.Rd +++ b/man/tm_t_reactables.Rd @@ -14,6 +14,21 @@ tm_t_reactables( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} + \item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} (named \code{list} of lists of \code{teal_transform_module}) optional, decorator for tables or plots included in the module output reported. diff --git a/man/tm_variable_browser.Rd b/man/tm_variable_browser.Rd index 408d6b5ed..9f439c157 100644 --- a/man/tm_variable_browser.Rd +++ b/man/tm_variable_browser.Rd @@ -16,9 +16,21 @@ tm_variable_browser( ) } \arguments{ +\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. +For \code{modules()} defaults to \code{"root"}. See \code{Details}.} + \item{datasets_selected}{(\code{character}) \ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#deprecated}{\figure{lifecycle-deprecated.svg}{options: alt='[Deprecated]'}}}{\strong{[Deprecated]}} vector of datasets to show, please use the \code{datanames} argument.} +\item{datanames}{(\code{character}) Names of the datasets relevant to the item. +There are 2 reserved values that have specific behaviors: +\itemize{ +\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. +\item \code{NULL} hides the sidebar panel completely. +\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} +argument. +}} + \item{parent_dataname}{(\code{character(1)}) string specifying a parent dataset. If it exists in \code{datanames} then an extra checkbox will be shown to allow users to not show variables in other datasets which exist in this \code{dataname}. @@ -37,6 +49,9 @@ with settings for the module plot. The argument is merged with options variable \code{teal.ggplot2_args} and default module setup. For more details see the vignette: \code{vignette("custom-ggplot2-arguments", package = "teal.widgets")}} + +\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. +To learn more check \code{vignette("transform-input-data", package = "teal")}.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. From c91a8eef6882f479decd5f2a29173ba533a0fdaf Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Tue, 21 Oct 2025 15:58:51 +0200 Subject: [PATCH 147/158] rename mathods in teal.transform --- R/tm_a_pca_picks.R | 6 +-- R/tm_a_regression_picks.R | 28 ++++++------ R/tm_g_association_picks.R | 10 ++--- R/tm_g_bivariate_picks.R | 34 +++++++------- R/tm_g_distribution.R | 50 ++++++++++----------- R/tm_g_distribution_picks.R | 76 ++++++++++++++++---------------- R/tm_g_response_picks.R | 18 ++++---- R/tm_g_scatterplot_picks.R | 40 ++++++++--------- R/tm_g_scatterplotmatrix_picks.R | 10 ++--- R/tm_p_scatterplot.R | 26 +++++------ R/tm_p_spaghetti.R | 24 +++++----- R/tm_p_spiderplot.R | 14 +++--- R/tm_t_crosstable_picks.R | 10 ++--- 13 files changed, 173 insertions(+), 173 deletions(-) diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R index 98ad4601d..7fc66bc42 100644 --- a/R/tm_a_pca_picks.R +++ b/R/tm_a_pca_picks.R @@ -127,7 +127,7 @@ ui_a_pca.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Data selection"), - teal.transform::module_input_ui(id = ns("dat"), spec = dat) + teal.transform::picks_ui(id = ns("dat"), spec = dat) ), bslib::accordion( open = TRUE, @@ -232,7 +232,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(dat = dat), data = data) + selectors <- teal.transform::picks_srv(spec = list(dat = dat), data = data) qenv <- reactive({ validate_input( @@ -252,7 +252,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args merged <- merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") anl_merged_q <- merged$data - selected_vars <- reactive(merged$merge_vars()$dat) + selected_vars <- reactive(merged$variables()$dat) validate_data <- reactive({ obj <- req(anl_merged_q()) diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 345f07b8d..3f8d14716 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -150,11 +150,11 @@ ui_a_regression.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$br(), teal::teal_nav_item( label = tags$strong("Response variable"), - teal.transform::module_input_ui(id = ns("response"), spec = response) + teal.transform::picks_ui(id = ns("response"), spec = response) ), teal::teal_nav_item( label = tags$strong("Regressor variables"), - teal.transform::module_input_ui(id = ns("regressor"), spec = regressor) + teal.transform::picks_ui(id = ns("regressor"), spec = regressor) ), radioButtons( ns("plot_type"), @@ -183,7 +183,7 @@ ui_a_regression.picks <- function(id, ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.transform::module_input_ui(id = ns("outlier"), spec = outlier) + teal.transform::picks_ui(id = ns("outlier"), spec = outlier) ), ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( @@ -246,7 +246,7 @@ srv_a_regression.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = list(response = response, regressor = regressor, outlier = outlier), data = data ) @@ -294,15 +294,15 @@ srv_a_regression.picks <- function(id, teal::validate_has_data(anl, 10) teal::validate_has_data( - anl[, c(merged$merge_vars()$response, merged$merge_vars()$regressor)], 10, + anl[, c(merged$variables()$response, merged$variables()$regressor)], 10, complete = TRUE, allow_inf = FALSE ) form <- stats::as.formula( paste( - merged$merge_vars()$response, + merged$variables()$response, paste( - merged$merge_vars()$regressor, + merged$variables()$regressor, collapse = " + " ), sep = " ~ " @@ -332,7 +332,7 @@ srv_a_regression.picks <- function(id, "" ) %>% dplyr::if_else(is.na(.), "cooksd == NaN", .), - env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$merge_vars()$outlier) + env = list(outlier_cutoff = input$outlier_cutoff, label_var = merged$variables()$outlier) ) }) @@ -377,7 +377,7 @@ srv_a_regression.picks <- function(id, fit <- obj[["fit"]] anl <- obj[["anl"]] - if (!is.factor(anl[[merged$merge_vars()$regressor]])) { + if (!is.factor(anl[[merged$variables()$regressor]])) { shinyjs::show("size") shinyjs::show("alpha") plot <- substitute( @@ -385,8 +385,8 @@ srv_a_regression.picks <- function(id, ggplot2::geom_point(size = size, alpha = alpha) + ggplot2::stat_smooth(method = "lm", formula = y ~ x, se = FALSE), env = list( - regressor = merged$merge_vars()$regressor, - response = merged$merge_vars()$response, + regressor = merged$variables()$regressor, + response = merged$variables()$response, size = input$size, alpha = input$alpha ) @@ -403,7 +403,7 @@ srv_a_regression.picks <- function(id, plot <- substitute( expr = ggplot2::ggplot(fit$model[, 2:1], ggplot2::aes_string(regressor, response)) + ggplot2::geom_boxplot(), - env = list(regressor = merged$merge_vars()$regressor, response = merged$merge_vars()$response) + env = list(regressor = merged$variables()$regressor, response = merged$variables()$response) ) if (input$show_outlier) { plot <- substitute( @@ -420,8 +420,8 @@ srv_a_regression.picks <- function(id, module_plot = teal.widgets::ggplot2_args( labs = list( title = "Response vs Regressor", - x = varname_w_label(merged$merge_vars()$regressor, anl), - y = varname_w_label(merged$merge_vars()$response, anl) + x = varname_w_label(merged$variables()$regressor, anl), + y = varname_w_label(merged$variables()$response, anl) ), theme = list() ) diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R index 307d4a4e9..242dda7ef 100644 --- a/R/tm_g_association_picks.R +++ b/R/tm_g_association_picks.R @@ -102,11 +102,11 @@ ui_g_association.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Reference variable"), - teal.transform::module_input_ui(id = ns("ref"), spec = ref) + teal.transform::picks_ui(id = ns("ref"), spec = ref) ), teal::teal_nav_item( label = tags$strong("Associated variables"), - teal.transform::module_input_ui(id = ns("vars"), spec = vars) + teal.transform::picks_ui(id = ns("vars"), spec = vars) ), checkboxInput(ns("association"), "Association with reference variable", value = show_association), checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), @@ -157,7 +157,7 @@ srv_g_association.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(ref = ref, vars = vars), data = data) + selectors <- teal.transform::picks_srv(spec = list(ref = ref, vars = vars), data = data) validated_q <- reactive({ obj <- req(data()) @@ -191,8 +191,8 @@ srv_g_association.picks <- function(id, req(merged$data()) logger::log_debug("srv_g_association@1 recalculating a plot") anl <- merged$data()[["anl"]] - ref_name <- merged$merge_vars()$ref - vars_names <- merged$merge_vars()$vars + ref_name <- merged$variables()$ref + vars_names <- merged$variables()$vars teal::validate_has_data(anl, 3) teal::validate_has_data(anl[, c(ref_name, vars_names)], 3, complete = TRUE, allow_inf = FALSE) diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 994c23a34..035678542 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -151,11 +151,11 @@ ui_g_bivariate.picks <- function(id, encoding = shiny::tagList( teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), spec = x) ), teal::teal_nav_item( label = tags$strong("Y variable"), - teal.transform::module_input_ui(id = ns("y"), spec = y) + teal.transform::picks_ui(id = ns("y"), spec = y) ), conditionalPanel( condition = @@ -176,7 +176,7 @@ ui_g_bivariate.picks <- function(id, teal::teal_nav_item( tags$div( tags$strong("Row facetting variable"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet), + teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet), checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) ) ) @@ -185,7 +185,7 @@ ui_g_bivariate.picks <- function(id, teal::teal_nav_item( tags$div( tags$strong("Column facetting variable"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet), + teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet), checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) ) ) @@ -199,11 +199,11 @@ ui_g_bivariate.picks <- function(id, conditionalPanel( condition = paste0("input['", ns("coloring"), "']"), tags$div( - teal.transform::module_input_ui(id = ns("color"), spec = color), # label = "Outline color by variable" - teal.transform::module_input_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" + teal.transform::picks_ui(id = ns("color"), spec = color), # label = "Outline color by variable" + teal.transform::picks_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" tags$div( id = ns("size_settings"), - teal.transform::module_input_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" + teal.transform::picks_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" ) ) ) @@ -270,7 +270,7 @@ srv_g_bivariate.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = list( x = x, y = y, @@ -317,13 +317,13 @@ srv_g_bivariate.picks <- function(id, teal::validate_has_data(anl, 3) - x_name <- merged$merge_vars()$x - y_name <- merged$merge_vars()$y - row_facet_name <- merged$merge_vars()$row_facet - col_facet_name <- merged$merge_vars()$col_facet - color_name <- merged$merge_vars()$color - fill_name <- merged$merge_vars()$fill - size_name <- merged$merge_vars()$size + x_name <- merged$variables()$x + y_name <- merged$variables()$y + row_facet_name <- merged$variables()$row_facet + col_facet_name <- merged$variables()$col_facet + color_name <- merged$variables()$color + fill_name <- merged$variables()$fill + size_name <- merged$variables()$size use_density <- input$use_density == "density" free_x_scales <- input$free_x_scales @@ -440,8 +440,8 @@ srv_g_bivariate.picks <- function(id, decorators = select_decorators(decorators, "plot"), expr = reactive({ anl <- merged$data()[["anl"]] - row_facet_name <- merged$merge_vars()$row_facet - col_facet_name <- merged$merge_vars()$col_facet + row_facet_name <- merged$variables()$row_facet + col_facet_name <- merged$variables()$col_facet # Add labels to facets nulled_row_facet_name <- varname_w_label(row_facet_name, anl) diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 23c5e2169..6e0c13827 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -572,7 +572,7 @@ srv_g_distribution.default <- function(id, } ANL <- merged$anl_q_r()[["ANL"]] - round(get_dist_params(as.numeric(stats::na.omit(ANL[[merge_vars()$dist_var]])), input$t_dist), 2) + round(get_dist_params(as.numeric(stats::na.omit(ANL[[variables()$dist_var]])), input$t_dist), 2) } else { c("param1" = NA_real_, "param2" = NA_real_) } @@ -642,13 +642,13 @@ srv_g_distribution.default <- function(id, ) ANL <- obj[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name roundn <- input$roundn dist_param1 <- input$dist_param1 @@ -780,12 +780,12 @@ srv_g_distribution.default <- function(id, is.null(input$ggtheme) }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name t_dist <- input$t_dist dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -976,12 +976,12 @@ srv_g_distribution.default <- function(id, input$tabs }, valueExpr = { - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 @@ -1110,13 +1110,13 @@ srv_g_distribution.default <- function(id, # Create a private stack for this function only. ANL <- common_q()[["ANL"]] - dist_var <- merge_vars()$dist_var - s_var <- merge_vars()$s_var - g_var <- merge_vars()$g_var + dist_var <- variables()$dist_var + s_var <- variables()$s_var + g_var <- variables()$g_var - dist_var_name <- merge_vars()$dist_var_name - s_var_name <- merge_vars()$s_var_name - g_var_name <- merge_vars()$g_var_name + dist_var_name <- variables()$dist_var_name + s_var_name <- variables()$s_var_name + g_var_name <- variables()$g_var_name dist_param1 <- input$dist_param1 dist_param2 <- input$dist_param2 diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R index c5ac82003..454c506d7 100644 --- a/R/tm_g_distribution_picks.R +++ b/R/tm_g_distribution_picks.R @@ -121,13 +121,13 @@ ui_g_distribution.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Variable"), - teal.transform::module_input_ui(id = ns("dist_var"), spec = dist_var) + teal.transform::picks_ui(id = ns("dist_var"), spec = dist_var) ), if (!is.null(group_var)) { tagList( teal::teal_nav_item( label = tags$strong("Group by:"), - teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) + teal.transform::picks_ui(id = ns("group_var"), spec = group_var) ), uiOutput(ns("scales_types_ui")) ) @@ -136,7 +136,7 @@ ui_g_distribution.picks <- function(id, tagList( teal::teal_nav_item( label = tags$strong("Stratify by:"), - teal.transform::module_input_ui(id = ns("strata_var"), spec = strata_var) + teal.transform::picks_ui(id = ns("strata_var"), spec = strata_var) ) ) }, @@ -212,7 +212,7 @@ srv_g_distribution.picks <- function(id, ns <- session$ns - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), data = data ) @@ -241,28 +241,28 @@ srv_g_distribution.picks <- function(id, validate_input( inputId = "dist_var-variables-selected", - condition = is.numeric(anl[[merged$merge_vars()$dist_var]]), + condition = is.numeric(anl[[merged$variables()$dist_var]]), message = "Distribution variable must be numeric." ) - if (length(merged$merge_vars()$group_var) > 0) { + if (length(merged$variables()$group_var) > 0) { validate_input( "group_var-variables-selected", - condition = inherits(anl[[merged$merge_vars()$group_var]], c("integer", "factor", "character")), + condition = inherits(anl[[merged$variables()$group_var]], c("integer", "factor", "character")), message = "Group by variable must be `factor`, `character`, or `integer`" ) obj <- within(obj, library("forcats")) obj <- within( obj, expr = anl[[group_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[group_var]]), "NA"), - group_var = merged$merge_vars()$group_var + group_var = merged$variables()$group_var ) } - if (length(merged$merge_vars()$strata_var) > 0) { + if (length(merged$variables()$strata_var) > 0) { validate_input( "strata_var-variables-selected", - condition = inherits(anl[[merged$merge_vars()$strata_var]], c("integer", "factor", "character")), + condition = inherits(anl[[merged$variables()$strata_var]], c("integer", "factor", "character")), message = "Stratify by variable must be `factor`, `character`, or `integer`" ) @@ -270,7 +270,7 @@ srv_g_distribution.picks <- function(id, obj <- within( obj, expr = anl[[strata_var]] <- forcats::fct_na_value_to_level(as.factor(anl[[strata_var]]), "NA"), - strata_var = merged$merge_vars()$strata_var + strata_var = merged$variables()$strata_var ) } @@ -281,7 +281,7 @@ srv_g_distribution.picks <- function(id, output$scales_types_ui <- renderUI({ validate_merged() - if (length(merged$merge_vars()$group_var) > 0) { + if (length(merged$variables()$group_var) > 0) { shinyWidgets::prettyRadioButtons( ns("scales_type"), label = "Scales:", @@ -297,7 +297,7 @@ srv_g_distribution.picks <- function(id, eventExpr = { input$t_dist input$params_reset - merged$merge_vars()$dist_var + merged$variables()$dist_var }, handlerExpr = { params <- if (length(input$t_dist)) { @@ -306,7 +306,7 @@ srv_g_distribution.picks <- function(id, anl <- merged$data()[["anl"]] round( .calc_dist_params( - x = as.numeric(stats::na.omit(anl[[merged$merge_vars()$dist_var]])), + x = as.numeric(stats::na.omit(anl[[merged$variables()$dist_var]])), dist = input$t_dist ), 2 @@ -401,7 +401,7 @@ srv_g_distribution.picks <- function(id, validate_dist() merged$data() }), - merge_vars = merged$merge_vars, + variables = merged$variables, t_dist = reactive(input$t_dist), dist_param1 = reactive(input$dist_param1), dist_param2 = reactive(input$dist_param2), @@ -429,7 +429,7 @@ srv_g_distribution.picks <- function(id, validate_dist() merged$data() }), - merge_vars = merged$merge_vars, + variables = merged$variables, t_dist = reactive(input$t_dist), dist_param1 = reactive(input$dist_param1), dist_param2 = reactive(input$dist_param2), @@ -451,7 +451,7 @@ srv_g_distribution.picks <- function(id, validate_merged() merged$data() }), - merge_vars = merged$merge_vars, + variables = merged$variables, decorators = select_decorators(decorators, "Statistics Table") ) @@ -459,8 +459,8 @@ srv_g_distribution.picks <- function(id, validate_merged() obj <- merged$data() anl <- obj[["anl"]] - s_var <- merged$merge_vars()$strata_var - g_var <- merged$merge_vars()$group_var + s_var <- merged$variables()$strata_var + g_var <- merged$variables()$group_var dist_test <- input$`test_table-dist_test` if (identical(dist_test, "Fligner-Killeen")) { @@ -500,7 +500,7 @@ srv_g_distribution.picks <- function(id, test_output <- .srv_test_table( "test_table", data = test_q, - merge_vars = merged$merge_vars, + variables = merged$variables, t_dist = reactive(input$t_dist), decorators = select_decorators(decorators, "Test Table") ) @@ -543,7 +543,7 @@ srv_g_distribution.picks <- function(id, .srv_hist <- function(id, data, - merge_vars, + variables, ggtheme, scales_type, t_dist, @@ -570,9 +570,9 @@ srv_g_distribution.picks <- function(id, statistic <- if (req(input$statistic) == "Density") "density" else "count" logger::log_debug(".srv_hist@1 Recalculating Histogram") add_density <- input$add_density - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var ndensity <- 512 teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Histogram Plot") @@ -713,7 +713,7 @@ srv_g_distribution.picks <- function(id, .srv_qq <- function(id, data, - merge_vars, + variables, t_dist, dist_param1, dist_param2, @@ -734,12 +734,12 @@ srv_g_distribution.picks <- function(id, ggtheme() }, { - req(data(), merge_vars(), ggtheme(), t_dist()) + req(data(), variables(), ggtheme(), t_dist()) logger::log_debug(".srv_qq@1 Recalculating QQ Plot...") obj <- data() - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## QQ Plot") @@ -858,14 +858,14 @@ srv_g_distribution.picks <- function(id, ) } -.srv_summary_table <- function(id, data, merge_vars, decorators) { +.srv_summary_table <- function(id, data, variables, decorators) { moduleServer(id, function(input, output, session) { output_q <- reactive({ obj <- req(data()) roundn <- input$roundn teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Statistics table") - obj <- if (length(merge_vars()$strata_var) == 0 && length(merge_vars()$group_var) == 0) { + obj <- if (length(variables()$strata_var) == 0 && length(variables()$group_var) == 0) { within( obj, expr = { @@ -879,7 +879,7 @@ srv_g_distribution.picks <- function(id, count = dplyr::n() ) }, - d_var_name = as.name(merge_vars()$dist_var), + d_var_name = as.name(variables()$dist_var), roundn = roundn ) } else { @@ -897,8 +897,8 @@ srv_g_distribution.picks <- function(id, count = dplyr::n() ) }, - d_var_name = as.name(merge_vars()$dist_var), - strata_vars = c(merge_vars()$group_var, merge_vars()$strata_var), + d_var_name = as.name(variables()$dist_var), + strata_vars = c(variables()$group_var, variables()$strata_var), roundn = roundn ) } @@ -974,7 +974,7 @@ srv_g_distribution.picks <- function(id, ) } -.srv_test_table <- function(id, data, merge_vars, t_dist, decorators) { +.srv_test_table <- function(id, data, variables, t_dist, decorators) { moduleServer(id, function(input, output, session) { output_q <- eventReactive( ignoreNULL = FALSE, @@ -985,9 +985,9 @@ srv_g_distribution.picks <- function(id, valueExpr = { obj <- data() anl <- obj[["anl"]] - d_var <- merge_vars()$dist_var - s_var <- merge_vars()$strata_var - g_var <- merge_vars()$group_var + d_var <- variables()$dist_var + s_var <- variables()$strata_var + g_var <- variables()$group_var d_var_name <- as.name(d_var) s_var_name <- if (!is.null(s_var)) as.name(s_var) g_var_name <- if (!is.null(g_var)) as.name(g_var) diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R index e0e3abdc2..fad00ee6d 100644 --- a/R/tm_g_response_picks.R +++ b/R/tm_g_response_picks.R @@ -98,22 +98,22 @@ ui_g_response.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Response variable"), - teal.transform::module_input_ui(id = ns("response"), spec = response) + teal.transform::picks_ui(id = ns("response"), spec = response) ), teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), spec = x) ), if (!is.null(row_facet)) { teal::teal_nav_item( label = tags$strong("Row facetting"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) + teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet) ) }, if (!is.null(col_facet)) { teal::teal_nav_item( label = tags$strong("Column facetting"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) + teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet) ) }, shinyWidgets::radioGroupButtons( @@ -162,7 +162,7 @@ srv_g_response.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = list( response = response, x = x, @@ -227,16 +227,16 @@ srv_g_response.picks <- function(id, qenv <- merged$data() anl <- qenv[["anl"]] - response_var <- merged$merge_vars()$response - x_var <- merged$merge_vars()$x + response_var <- merged$variables()$response + x_var <- merged$variables()$x validate(need(is.factor(anl[[response_var]]), "Please select a factor variable as the response.")) validate(need(is.factor(anl[[x_var]]), "Please select a factor variable as the X-Variable.")) teal::validate_has_data(anl, 10) teal::validate_has_data(anl[, c(response_var, x_var)], 10, complete = TRUE, allow_inf = FALSE) - row_facet_var <- merged$merge_vars()$row_facet - col_facet_var <- merged$merge_vars()$col_facet + row_facet_var <- merged$variables()$row_facet + col_facet_var <- merged$variables()$col_facet freq <- input$freq == "frequency" swap_axes <- input$coord_flip diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index c81c1257f..2271cfd4a 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -137,7 +137,7 @@ ui_g_scatterplot.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::module_input_ui(id = ns("x"), spec = x), + teal.transform::picks_ui(id = ns("x"), spec = x), checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_x"), "'] == true"), @@ -151,7 +151,7 @@ ui_g_scatterplot.picks <- function(id, ), teal::teal_nav_item( label = tags$strong("Y variable"), - teal.transform::module_input_ui(id = ns("y"), spec = y), + teal.transform::picks_ui(id = ns("y"), spec = y), checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_y"), "'] == true"), @@ -166,25 +166,25 @@ ui_g_scatterplot.picks <- function(id, if (!is.null(color_by)) { teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_by"), spec = color_by) + teal.transform::picks_ui(id = ns("color_by"), spec = color_by) ) }, if (!is.null(size_by)) { teal::teal_nav_item( label = tags$strong("Size by:"), - teal.transform::module_input_ui(id = ns("size_by"), spec = size_by) + teal.transform::picks_ui(id = ns("size_by"), spec = size_by) ) }, if (!is.null(row_facet)) { teal::teal_nav_item( label = tags$strong("Row facetting"), - teal.transform::module_input_ui(id = ns("row_facet"), spec = row_facet) + teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet) ) }, if (!is.null(col_facet)) { teal::teal_nav_item( label = tags$strong("Column facetting"), - teal.transform::module_input_ui(id = ns("col_facet"), spec = col_facet) + teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet) ) }, ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), @@ -270,7 +270,7 @@ srv_g_scatterplot.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), data = data ) @@ -329,8 +329,8 @@ srv_g_scatterplot.picks <- function(id, trend_line_is_applicable <- reactive({ anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y + x_var <- merged$variables()$x + y_var <- merged$variables()$y length(x_var) > 0 && length(y_var) > 0 && is.numeric(anl[[x_var]]) && is.numeric(anl[[y_var]]) }) @@ -343,7 +343,7 @@ srv_g_scatterplot.picks <- function(id, observeEvent( eventExpr = selectors$color_by(), handlerExpr = { - color_by_var <- merged$merge_vars()$color_by + color_by_var <- merged$variables()$color_by if (length(color_by_var) > 0) { shinyjs::hide("color") } else { @@ -356,8 +356,8 @@ srv_g_scatterplot.picks <- function(id, output$num_na_removed <- renderUI({ if (add_trend_line()) { anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y + x_var <- merged$variables()$x + y_var <- merged$variables()$y if ((num_total_na <- nrow(anl) - nrow(stats::na.omit(anl[, c(x_var, y_var)]))) > 0) { tags$div(paste(num_total_na, "row(s) with missing values were removed"), tags$hr()) } @@ -368,8 +368,8 @@ srv_g_scatterplot.picks <- function(id, eventExpr = list(selectors$row_facet(), selectors$col_facet()), handlerExpr = { if ( - length(merged$merge_vars()$row_facet) == 0 && - length(merged$merge_vars()$col_facet) == 0 + length(merged$variables()$row_facet) == 0 && + length(merged$variables()$col_facet) == 0 ) { shinyjs::hide("free_scales") } else { @@ -381,12 +381,12 @@ srv_g_scatterplot.picks <- function(id, output_q <- reactive({ req(merged$data()) anl <- merged$data()[["anl"]] - x_var <- merged$merge_vars()$x - y_var <- merged$merge_vars()$y - color_by_var <- merged$merge_vars()$color_by - size_by_var <- merged$merge_vars()$size_by - row_facet_var <- merged$merge_vars()$row_facet - col_facet_var <- merged$merge_vars()$col_facet + x_var <- merged$variables()$x + y_var <- merged$variables()$y + color_by_var <- merged$variables()$color_by + size_by_var <- merged$variables()$size_by + row_facet_var <- merged$variables()$row_facet + col_facet_var <- merged$variables()$col_facet alpha <- input$alpha size <- input$size rotate_xaxis_labels <- input$rotate_xaxis_labels diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R index e7c967b0e..0dbba379d 100644 --- a/R/tm_g_scatterplotmatrix_picks.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -72,7 +72,7 @@ ui_g_scatterplotmatrix.picks <- function(id, tagList( lapply(names(variables), function(id) { teal::teal_nav_item( - teal.transform::module_input_ui(id = ns(id), spec = variables[[id]]) + teal.transform::picks_ui(id = ns(id), spec = variables[[id]]) ) }) ), @@ -120,7 +120,7 @@ srv_g_scatterplotmatrix.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( spec = variables, data = data ) @@ -145,13 +145,13 @@ srv_g_scatterplotmatrix.picks <- function(id, }) merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") - merge_vars <- reactive(unname(unlist(merged$merge_vars()))) + variables <- reactive(unname(unlist(merged$variables()))) # plot output_q <- reactive({ qenv <- req(merged$data()) anl <- qenv[["anl"]] - cols_names <- merge_vars() + cols_names <- variables() alpha <- input$alpha cex <- input$cex add_cor <- input$cor @@ -282,7 +282,7 @@ srv_g_scatterplotmatrix.picks <- function(id, # show a message if conversion to factors took place output$message <- renderText({ - cols_names <- req(merge_vars()) + cols_names <- req(variables()) anl <- merged$data()[["anl"]] check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index e0b61f8c3..14e63cf43 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -91,19 +91,19 @@ ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Subject Variable:"), - teal.transform::module_input_ui(id = ns("subject_var"), spec = subject_var) + teal.transform::picks_ui(id = ns("subject_var"), spec = subject_var) ), teal::teal_nav_item( label = tags$strong("X-axis Variable:"), - teal.transform::module_input_ui(id = ns("x_var"), spec = x_var) + teal.transform::picks_ui(id = ns("x_var"), spec = x_var) ), teal::teal_nav_item( label = tags$strong("Y-axis Variable:"), - teal.transform::module_input_ui(id = ns("y_var"), spec = y_var) + teal.transform::picks_ui(id = ns("y_var"), spec = y_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), spec = color_var), colour_picker_ui(ns("colors")) ) ), @@ -112,15 +112,15 @@ ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { } srv_p_scatterplot_module <- function(id, - data, - subject_var, - x_var, - y_var, - color_var, - point_colors, - tooltip_vars = NULL) { + data, + subject_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( data = data, spec = list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) ) @@ -310,4 +310,4 @@ srv_p_scatterplot <- function(id, } }) }) -} \ No newline at end of file +} diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index 36a6e1090..df78ffda4 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -99,19 +99,19 @@ ui_p_spaghetti_module <- function(id, group_var, x_var, y_var, color_var, toolti class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Group Variable:"), - teal.transform::module_input_ui(id = ns("group_var"), spec = group_var) + teal.transform::picks_ui(id = ns("group_var"), spec = group_var) ), teal::teal_nav_item( label = tags$strong("X-axis Variable:"), - teal.transform::module_input_ui(id = ns("x_var"), spec = x_var) + teal.transform::picks_ui(id = ns("x_var"), spec = x_var) ), teal::teal_nav_item( label = tags$strong("Y-axis Variable:"), - teal.transform::module_input_ui(id = ns("y_var"), spec = y_var) + teal.transform::picks_ui(id = ns("y_var"), spec = y_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), spec = color_var), colour_picker_ui(ns("colors")) ) ), @@ -120,15 +120,15 @@ ui_p_spaghetti_module <- function(id, group_var, x_var, y_var, color_var, toolti } srv_p_spaghetti_module <- function(id, - data, - group_var, - x_var, - y_var, - color_var, - point_colors, - tooltip_vars = NULL) { + data, + group_var, + x_var, + y_var, + color_var, + point_colors, + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( data = data, spec = list(group_var = group_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) ) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index a4cd3810b..0d7d2cad9 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -145,31 +145,31 @@ ui_p_spiderplot <- function(id, class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Time variable (x-axis):"), - teal.transform::module_input_ui(id = ns("time_var"), spec = time_var) + teal.transform::picks_ui(id = ns("time_var"), spec = time_var) ), teal::teal_nav_item( label = tags$strong("Value variable (y-axis):"), - teal.transform::module_input_ui(id = ns("value_var"), spec = value_var) + teal.transform::picks_ui(id = ns("value_var"), spec = value_var) ), teal::teal_nav_item( label = tags$strong("Subject variable:"), - teal.transform::module_input_ui(id = ns("subject_var"), spec = subject_var) + teal.transform::picks_ui(id = ns("subject_var"), spec = subject_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::module_input_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), spec = color_var), colour_picker_ui(ns("colors")) ), if (!is.null(tooltip_vars)) { # todo: don't show at all teal::teal_nav_item( label = tags$strong("Tooltip variables:"), - teal.transform::module_input_ui(id = ns("tooltip_vars"), spec = tooltip_vars) + teal.transform::picks_ui(id = ns("tooltip_vars"), spec = tooltip_vars) ) }, if (!is.null(size_var)) { teal::teal_nav_item( label = tags$strong("Size by:"), - teal.transform::module_input_ui(id = ns("size_var"), spec = size_var) + teal.transform::picks_ui(id = ns("size_var"), spec = size_var) ) }, ui_decorate_teal_data(ns("decorator"), decorators = decorators), @@ -204,7 +204,7 @@ srv_p_spiderplot <- function(id, filter_panel_api) { moduleServer(id, function(input, output, session) { logger::log_trace("srv_p_spiderplot initializing") - selectors <- teal.transform::module_input_srv( + selectors <- teal.transform::picks_srv( data = data, spec = list( time_var = time_var, value_var = value_var, subject_var = subject_var, diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index 7c15f41ca..0ae0dd29a 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -70,11 +70,11 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Row values"), - teal.transform::module_input_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), spec = x) ), teal::teal_nav_item( label = tags$strong("Column values"), - teal.transform::module_input_ui(id = ns("y"), spec = y) + teal.transform::picks_ui(id = ns("y"), spec = y) ), shinyWidgets::pickerInput( ns("join_fun"), @@ -106,7 +106,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::module_input_srv(spec = list(x = x, y = y), data = data) + selectors <- teal.transform::picks_srv(spec = list(x = x, y = y), data = data) validated_q <- reactive({ validate_input( @@ -156,8 +156,8 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b anl <- merged$data()[["anl"]] # As this is a summary - x_name <- merged$merge_vars()$x - y_name <- merged$merge_vars()$y + x_name <- merged$variables()$x + y_name <- merged$variables()$y teal::validate_has_data(anl, 3) teal::validate_has_data(anl[, c(x_name, y_name)], 3, complete = TRUE, allow_inf = FALSE) From fbab31945019f9aa6d9a99be1e81f5ff2d3b2e2b Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 24 Oct 2025 12:40:30 +0200 Subject: [PATCH 148/158] spec -> picks --- R/tm_a_pca_picks.R | 4 ++-- R/tm_a_regression_picks.R | 8 ++++---- R/tm_g_association.R | 6 +++--- R/tm_g_association_picks.R | 10 +++++----- R/tm_g_bivariate.R | 4 ++-- R/tm_g_bivariate_picks.R | 24 ++++++++++++------------ R/tm_g_distribution.R | 2 +- R/tm_g_distribution_picks.R | 10 +++++----- R/tm_g_response.R | 2 +- R/tm_g_response_picks.R | 10 +++++----- R/tm_g_scatterplot_picks.R | 14 +++++++------- R/tm_g_scatterplotmatrix_picks.R | 6 +++--- R/tm_p_scatterplot.R | 10 +++++----- R/tm_p_spaghetti.R | 10 +++++----- R/tm_p_spiderplot.R | 14 +++++++------- R/tm_t_crosstable_picks.R | 6 +++--- 16 files changed, 70 insertions(+), 70 deletions(-) diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R index 7fc66bc42..25617e8e4 100644 --- a/R/tm_a_pca_picks.R +++ b/R/tm_a_pca_picks.R @@ -127,7 +127,7 @@ ui_a_pca.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Data selection"), - teal.transform::picks_ui(id = ns("dat"), spec = dat) + teal.transform::picks_ui(id = ns("dat"), picks = dat) ), bslib::accordion( open = TRUE, @@ -232,7 +232,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(spec = list(dat = dat), data = data) + selectors <- teal.transform::picks_srv(picks = list(dat = dat), data = data) qenv <- reactive({ validate_input( diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 3f8d14716..40b0be63b 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -150,11 +150,11 @@ ui_a_regression.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$br(), teal::teal_nav_item( label = tags$strong("Response variable"), - teal.transform::picks_ui(id = ns("response"), spec = response) + teal.transform::picks_ui(id = ns("response"), picks = response) ), teal::teal_nav_item( label = tags$strong("Regressor variables"), - teal.transform::picks_ui(id = ns("regressor"), spec = regressor) + teal.transform::picks_ui(id = ns("regressor"), picks = regressor) ), radioButtons( ns("plot_type"), @@ -183,7 +183,7 @@ ui_a_regression.picks <- function(id, ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.transform::picks_ui(id = ns("outlier"), spec = outlier) + teal.transform::picks_ui(id = ns("outlier"), picks = outlier) ), ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( @@ -247,7 +247,7 @@ srv_a_regression.picks <- function(id, ns <- session$ns selectors <- teal.transform::picks_srv( - spec = list(response = response, regressor = regressor, outlier = outlier), + picks = list(response = response, regressor = regressor, outlier = outlier), data = data ) diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 1cd1ca80a..86b43b702 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -135,16 +135,16 @@ tm_g_association <- function(label = "Association", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 + selected = 1L ), - values(selected = tidyselect::everything(), multiple = TRUE) + values() ), vars = picks( datasets(), variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2, # todo: make sure that is doesn't fail in teal.transform + selected = 2L, # todo: make sure that is doesn't fail in teal.transform multiple = TRUE ), values() diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R index 242dda7ef..db6026c75 100644 --- a/R/tm_g_association_picks.R +++ b/R/tm_g_association_picks.R @@ -5,7 +5,7 @@ tm_g_association.picks <- function(label = "Association", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 + selected = 1L ), values() ), @@ -14,7 +14,7 @@ tm_g_association.picks <- function(label = "Association", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2, + selected = 2L, multiple = TRUE ) ), @@ -102,11 +102,11 @@ ui_g_association.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Reference variable"), - teal.transform::picks_ui(id = ns("ref"), spec = ref) + teal.transform::picks_ui(id = ns("ref"), picks = ref) ), teal::teal_nav_item( label = tags$strong("Associated variables"), - teal.transform::picks_ui(id = ns("vars"), spec = vars) + teal.transform::picks_ui(id = ns("vars"), picks = vars) ), checkboxInput(ns("association"), "Association with reference variable", value = show_association), checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), @@ -157,7 +157,7 @@ srv_g_association.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(spec = list(ref = ref, vars = vars), data = data) + selectors <- teal.transform::picks_srv(picks = list(ref = ref, vars = vars), data = data) validated_q <- reactive({ obj <- req(data()) diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 11f9d7465..68e181ab9 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -154,7 +154,7 @@ tm_g_bivariate <- function(label = "Bivariate Plots", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 + selected = 1L ) ), y = picks( @@ -162,7 +162,7 @@ tm_g_bivariate <- function(label = "Bivariate Plots", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2 + selected = 2L ) ), row_facet = NULL, diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 035678542..1602e8d87 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -5,18 +5,18 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 1 + selected = 1L ), - values(selected = tidyselect::everything(), multiple = TRUE) + values() ), y = picks( datasets(), variables( choices = tidyselect::where(is.numeric) | teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2 + selected = 2L ), - values(selected = tidyselect::everything(), multiple = TRUE) + values() ), row_facet = NULL, col_facet = NULL, @@ -151,11 +151,11 @@ ui_g_bivariate.picks <- function(id, encoding = shiny::tagList( teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), picks = x) ), teal::teal_nav_item( label = tags$strong("Y variable"), - teal.transform::picks_ui(id = ns("y"), spec = y) + teal.transform::picks_ui(id = ns("y"), picks = y) ), conditionalPanel( condition = @@ -176,7 +176,7 @@ ui_g_bivariate.picks <- function(id, teal::teal_nav_item( tags$div( tags$strong("Row facetting variable"), - teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet), + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet), checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) ) ) @@ -185,7 +185,7 @@ ui_g_bivariate.picks <- function(id, teal::teal_nav_item( tags$div( tags$strong("Column facetting variable"), - teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet), + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet), checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) ) ) @@ -199,11 +199,11 @@ ui_g_bivariate.picks <- function(id, conditionalPanel( condition = paste0("input['", ns("coloring"), "']"), tags$div( - teal.transform::picks_ui(id = ns("color"), spec = color), # label = "Outline color by variable" - teal.transform::picks_ui(id = ns("fill"), spec = fill), # label = "Outline color by variable" + teal.transform::picks_ui(id = ns("color"), picks = color), # label = "Outline color by variable" + teal.transform::picks_ui(id = ns("fill"), picks = fill), # label = "Outline color by variable" tags$div( id = ns("size_settings"), - teal.transform::picks_ui(id = ns("size"), spec = size) # label = "Size of points by variable (only if x and y are numeric)" + teal.transform::picks_ui(id = ns("size"), picks = size) # label = "Size of points by variable (only if x and y are numeric)" ) ) ) @@ -271,7 +271,7 @@ srv_g_bivariate.picks <- function(id, ns <- session$ns selectors <- teal.transform::picks_srv( - spec = list( + picks = list( x = x, y = y, row_facet = row_facet, diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index 6e0c13827..f3efe87bf 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -74,7 +74,7 @@ #' dist_var = picks( #' datasets("iris"), #' variables(tidyselect::where(is.numeric)), -#' values(selected = "Petal.Length") +#' values() #' ) #' ) #' ) diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R index 454c506d7..e88f2b071 100644 --- a/R/tm_g_distribution_picks.R +++ b/R/tm_g_distribution_picks.R @@ -3,7 +3,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", dist_var = picks( datasets(), variables(where(is.numeric)), - values(selected = tidyselect::everything()) + values() ), strata_var = NULL, group_var = NULL, @@ -121,13 +121,13 @@ ui_g_distribution.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Variable"), - teal.transform::picks_ui(id = ns("dist_var"), spec = dist_var) + teal.transform::picks_ui(id = ns("dist_var"), picks = dist_var) ), if (!is.null(group_var)) { tagList( teal::teal_nav_item( label = tags$strong("Group by:"), - teal.transform::picks_ui(id = ns("group_var"), spec = group_var) + teal.transform::picks_ui(id = ns("group_var"), picks = group_var) ), uiOutput(ns("scales_types_ui")) ) @@ -136,7 +136,7 @@ ui_g_distribution.picks <- function(id, tagList( teal::teal_nav_item( label = tags$strong("Stratify by:"), - teal.transform::picks_ui(id = ns("strata_var"), spec = strata_var) + teal.transform::picks_ui(id = ns("strata_var"), picks = strata_var) ) ) }, @@ -213,7 +213,7 @@ srv_g_distribution.picks <- function(id, selectors <- teal.transform::picks_srv( - spec = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), + picks = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), data = data ) diff --git a/R/tm_g_response.R b/R/tm_g_response.R index acaba1264..ee12dfe5f 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -161,7 +161,7 @@ tm_g_response <- function(label = "Response Plot", datasets(), variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2 + selected = 2L ), values() ), diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R index fad00ee6d..9ad1b1232 100644 --- a/R/tm_g_response_picks.R +++ b/R/tm_g_response_picks.R @@ -98,22 +98,22 @@ ui_g_response.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Response variable"), - teal.transform::picks_ui(id = ns("response"), spec = response) + teal.transform::picks_ui(id = ns("response"), picks = response) ), teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), picks = x) ), if (!is.null(row_facet)) { teal::teal_nav_item( label = tags$strong("Row facetting"), - teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet) + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { teal::teal_nav_item( label = tags$strong("Column facetting"), - teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet) + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, shinyWidgets::radioGroupButtons( @@ -163,7 +163,7 @@ srv_g_response.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") selectors <- teal.transform::picks_srv( - spec = list( + picks = list( response = response, x = x, row_facet = row_facet, diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index 2271cfd4a..47b8a1ccb 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -137,7 +137,7 @@ ui_g_scatterplot.picks <- function(id, tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), spec = x), + teal.transform::picks_ui(id = ns("x"), picks = x), checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_x"), "'] == true"), @@ -151,7 +151,7 @@ ui_g_scatterplot.picks <- function(id, ), teal::teal_nav_item( label = tags$strong("Y variable"), - teal.transform::picks_ui(id = ns("y"), spec = y), + teal.transform::picks_ui(id = ns("y"), picks = y), checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_y"), "'] == true"), @@ -166,25 +166,25 @@ ui_g_scatterplot.picks <- function(id, if (!is.null(color_by)) { teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_by"), spec = color_by) + teal.transform::picks_ui(id = ns("color_by"), picks = color_by) ) }, if (!is.null(size_by)) { teal::teal_nav_item( label = tags$strong("Size by:"), - teal.transform::picks_ui(id = ns("size_by"), spec = size_by) + teal.transform::picks_ui(id = ns("size_by"), picks = size_by) ) }, if (!is.null(row_facet)) { teal::teal_nav_item( label = tags$strong("Row facetting"), - teal.transform::picks_ui(id = ns("row_facet"), spec = row_facet) + teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { teal::teal_nav_item( label = tags$strong("Column facetting"), - teal.transform::picks_ui(id = ns("col_facet"), spec = col_facet) + teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), @@ -271,7 +271,7 @@ srv_g_scatterplot.picks <- function(id, selectors <- teal.transform::picks_srv( - spec = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), + picks = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), data = data ) diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R index 0dbba379d..df10d984a 100644 --- a/R/tm_g_scatterplotmatrix_picks.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -3,7 +3,7 @@ tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", variables = list( picks( datasets(), - variables(selected = 1:5, multiple = TRUE) + variables(selected = seq(1, 5), multiple = TRUE) ) ), plot_height = c(600, 200, 2000), @@ -72,7 +72,7 @@ ui_g_scatterplotmatrix.picks <- function(id, tagList( lapply(names(variables), function(id) { teal::teal_nav_item( - teal.transform::picks_ui(id = ns(id), spec = variables[[id]]) + teal.transform::picks_ui(id = ns(id), picks = variables[[id]]) ) }) ), @@ -121,7 +121,7 @@ srv_g_scatterplotmatrix.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") selectors <- teal.transform::picks_srv( - spec = variables, + picks = variables, data = data ) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 14e63cf43..1975b4597 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -91,19 +91,19 @@ ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Subject Variable:"), - teal.transform::picks_ui(id = ns("subject_var"), spec = subject_var) + teal.transform::picks_ui(id = ns("subject_var"), picks = subject_var) ), teal::teal_nav_item( label = tags$strong("X-axis Variable:"), - teal.transform::picks_ui(id = ns("x_var"), spec = x_var) + teal.transform::picks_ui(id = ns("x_var"), picks = x_var) ), teal::teal_nav_item( label = tags$strong("Y-axis Variable:"), - teal.transform::picks_ui(id = ns("y_var"), spec = y_var) + teal.transform::picks_ui(id = ns("y_var"), picks = y_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), picks = color_var), colour_picker_ui(ns("colors")) ) ), @@ -122,7 +122,7 @@ srv_p_scatterplot_module <- function(id, moduleServer(id, function(input, output, session) { selectors <- teal.transform::picks_srv( data = data, - spec = list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) + picks = list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) ) merged_dataname <- "anl" merged_q <- reactive({ diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index df78ffda4..78ed35f5f 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -99,19 +99,19 @@ ui_p_spaghetti_module <- function(id, group_var, x_var, y_var, color_var, toolti class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Group Variable:"), - teal.transform::picks_ui(id = ns("group_var"), spec = group_var) + teal.transform::picks_ui(id = ns("group_var"), picks = group_var) ), teal::teal_nav_item( label = tags$strong("X-axis Variable:"), - teal.transform::picks_ui(id = ns("x_var"), spec = x_var) + teal.transform::picks_ui(id = ns("x_var"), picks = x_var) ), teal::teal_nav_item( label = tags$strong("Y-axis Variable:"), - teal.transform::picks_ui(id = ns("y_var"), spec = y_var) + teal.transform::picks_ui(id = ns("y_var"), picks = y_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), picks = color_var), colour_picker_ui(ns("colors")) ) ), @@ -130,7 +130,7 @@ srv_p_spaghetti_module <- function(id, moduleServer(id, function(input, output, session) { selectors <- teal.transform::picks_srv( data = data, - spec = list(group_var = group_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) + picks = list(group_var = group_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) ) merged_dataname <- "anl" merged_q <- reactive({ diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 0d7d2cad9..a4ae14677 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -145,31 +145,31 @@ ui_p_spiderplot <- function(id, class = "standard-layout encoding-panel", teal::teal_nav_item( label = tags$strong("Time variable (x-axis):"), - teal.transform::picks_ui(id = ns("time_var"), spec = time_var) + teal.transform::picks_ui(id = ns("time_var"), picks = time_var) ), teal::teal_nav_item( label = tags$strong("Value variable (y-axis):"), - teal.transform::picks_ui(id = ns("value_var"), spec = value_var) + teal.transform::picks_ui(id = ns("value_var"), picks = value_var) ), teal::teal_nav_item( label = tags$strong("Subject variable:"), - teal.transform::picks_ui(id = ns("subject_var"), spec = subject_var) + teal.transform::picks_ui(id = ns("subject_var"), picks = subject_var) ), teal::teal_nav_item( label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), spec = color_var), + teal.transform::picks_ui(id = ns("color_var"), picks = color_var), colour_picker_ui(ns("colors")) ), if (!is.null(tooltip_vars)) { # todo: don't show at all teal::teal_nav_item( label = tags$strong("Tooltip variables:"), - teal.transform::picks_ui(id = ns("tooltip_vars"), spec = tooltip_vars) + teal.transform::picks_ui(id = ns("tooltip_vars"), picks = tooltip_vars) ) }, if (!is.null(size_var)) { teal::teal_nav_item( label = tags$strong("Size by:"), - teal.transform::picks_ui(id = ns("size_var"), spec = size_var) + teal.transform::picks_ui(id = ns("size_var"), picks = size_var) ) }, ui_decorate_teal_data(ns("decorator"), decorators = decorators), @@ -206,7 +206,7 @@ srv_p_spiderplot <- function(id, logger::log_trace("srv_p_spiderplot initializing") selectors <- teal.transform::picks_srv( data = data, - spec = list( + picks = list( time_var = time_var, value_var = value_var, subject_var = subject_var, color_var = color_var, size_var = size_var, tooltip_vars = tooltip_vars ) diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index 0ae0dd29a..25dd92500 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -70,11 +70,11 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ tags$label("Encodings", class = "text-primary"), teal::teal_nav_item( label = tags$strong("Row values"), - teal.transform::picks_ui(id = ns("x"), spec = x) + teal.transform::picks_ui(id = ns("x"), picks = x) ), teal::teal_nav_item( label = tags$strong("Column values"), - teal.transform::picks_ui(id = ns("y"), spec = y) + teal.transform::picks_ui(id = ns("y"), picks = y) ), shinyWidgets::pickerInput( ns("join_fun"), @@ -106,7 +106,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(spec = list(x = x, y = y), data = data) + selectors <- teal.transform::picks_srv(picks = list(x = x, y = y), data = data) validated_q <- reactive({ validate_input( From 53da6a5f7220ab5cff2e7f754e9240c9e42f1e3b Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Wed, 29 Oct 2025 15:08:59 +0100 Subject: [PATCH 149/158] wip --- NAMESPACE | 8 - R/picks-datanames.R | 16 ++ R/tm_a_pca.R | 17 +- R/tm_a_pca_picks.R | 15 +- R/tm_a_regression.R | 30 ++- R/tm_a_regression_picks.R | 43 ++-- R/tm_g_association.R | 41 ++- R/tm_g_association_picks.R | 33 ++- R/tm_g_bivariate.R | 58 ++--- R/tm_g_bivariate_picks.R | 70 ++--- R/tm_g_distribution.R | 24 +- R/tm_g_distribution_picks.R | 45 ++-- R/tm_g_response.R | 37 ++- R/tm_g_response_picks.R | 60 +++-- R/tm_g_scatterplot.R | 78 +++--- R/tm_g_scatterplot_picks.R | 133 ++++++---- R/tm_g_scatterplotmatrix.R | 40 +-- R/tm_g_scatterplotmatrix_picks.R | 22 +- R/tm_markdown.R | 84 ------ R/tm_outliers.R | 20 +- R/tm_p_bargraph.R | 253 ------------------ R/tm_p_lineplot.R | 296 --------------------- R/tm_p_scatterplot.R | 313 ----------------------- R/tm_p_spaghetti.R | 342 ------------------------- R/tm_p_spiderplot.R | 423 ------------------------------- R/tm_p_swimlane.R | 370 --------------------------- R/tm_p_waterfall.R | 287 --------------------- R/tm_t_crosstable.R | 35 ++- R/tm_t_crosstable_picks.R | 33 ++- man/tm_a_pca.Rd | 20 +- man/tm_a_regression.Rd | 38 +-- man/tm_g_association.Rd | 39 ++- man/tm_g_bivariate.Rd | 68 ++--- man/tm_g_distribution.Rd | 29 ++- man/tm_g_response.Rd | 36 +-- man/tm_g_scatterplot.Rd | 83 +++--- man/tm_g_scatterplotmatrix.Rd | 41 +-- man/tm_outliers.Rd | 28 +- man/tm_p_bargraph.Rd | 82 ------ man/tm_p_lineplot.Rd | 87 ------- man/tm_p_scatterplot.Rd | 82 ------ man/tm_p_spaghetti.Rd | 85 ------- man/tm_p_spiderplot.Rd | 129 ---------- man/tm_p_swimlane.Rd | 108 -------- man/tm_p_waterfall.Rd | 94 ------- man/tm_rmarkdown.Rd | 59 ----- man/tm_t_crosstable.Rd | 38 +-- 47 files changed, 689 insertions(+), 3683 deletions(-) create mode 100644 R/picks-datanames.R delete mode 100644 R/tm_markdown.R delete mode 100644 R/tm_p_bargraph.R delete mode 100644 R/tm_p_lineplot.R delete mode 100644 R/tm_p_scatterplot.R delete mode 100644 R/tm_p_spaghetti.R delete mode 100644 R/tm_p_spiderplot.R delete mode 100644 R/tm_p_swimlane.R delete mode 100644 R/tm_p_waterfall.R delete mode 100644 man/tm_p_bargraph.Rd delete mode 100644 man/tm_p_lineplot.Rd delete mode 100644 man/tm_p_scatterplot.Rd delete mode 100644 man/tm_p_spaghetti.Rd delete mode 100644 man/tm_p_spiderplot.Rd delete mode 100644 man/tm_p_swimlane.Rd delete mode 100644 man/tm_p_waterfall.Rd delete mode 100644 man/tm_rmarkdown.Rd diff --git a/NAMESPACE b/NAMESPACE index 7e4ee9213..400e5fe22 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -41,14 +41,6 @@ export(tm_g_scatterplot) export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) -export(tm_p_bargraph) -export(tm_p_lineplot) -export(tm_p_scatterplot) -export(tm_p_spaghetti) -export(tm_p_spiderplot) -export(tm_p_swimlane) -export(tm_p_waterfall) -export(tm_rmarkdown) export(tm_t_crosstable) export(tm_t_reactables) export(tm_variable_browser) diff --git a/R/picks-datanames.R b/R/picks-datanames.R new file mode 100644 index 000000000..10a58fe54 --- /dev/null +++ b/R/picks-datanames.R @@ -0,0 +1,16 @@ +.picks_datanames <- function(x) { + checkmate::assert_list(x, c("picks", "NULL")) + datanames_list <- lapply(x, function(x) { + if (is.character(x$datasets$choices)) { + x$datasets$choices + } else { + NULL + } + }) + + if (any(vapply(datanames_list, is.null, logical(1)))) { + "all" + } else { + unique(unlist(datanames_list)) + } +} diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index 693fcd2d1..a451626dc 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -66,9 +66,9 @@ #' modules = modules( #' tm_a_pca( #' "PCA", -#' dat = picks( +#' dat = teal.transform::picks( #' datasets("USArrests"), -#' variables( +#' teal.transform::variables( #' choices = c("Murder", "Assault", "UrbanPop", "Rape"), #' selected = c("Murder", "Assault"), #' multiple = TRUE @@ -99,9 +99,9 @@ #' data = data, #' modules = modules( #' tm_a_pca( -#' dat = picks( +#' dat = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = c("BMRKR1", "AGE", "EOSDY"), #' selected = c("BMRKR1", "AGE"), #' multiple = TRUE @@ -117,7 +117,14 @@ #' @export #' tm_a_pca <- function(label = "Principal Component Analysis", - dat, + dat = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), + selected = tidyselect::everything(), + multiple = TRUE + ) + ), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R index 25617e8e4..ec0fdd65e 100644 --- a/R/tm_a_pca_picks.R +++ b/R/tm_a_pca_picks.R @@ -1,8 +1,8 @@ #' @export tm_a_pca.picks <- function(label = "Principal Component Analysis", - dat = picks( - datasets(), - variables( + dat = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), selected = tidyselect::everything(), multiple = TRUE @@ -82,10 +82,7 @@ tm_a_pca.picks <- function(label = "Principal Component Analysis", ui_args = args[names(args) %in% names(formals(ui_a_pca.picks))], server_args = args[names(args) %in% names(formals(srv_a_pca.picks))], transformators = transformators, - datanames = { - datanames <- datanames(list(dat)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(dat)) ) attr(ans, "teal_bookmarkable") <- FALSE ans @@ -125,8 +122,8 @@ ui_a_pca.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Data selection"), + tags$div( + tags$strong("Data selection"), teal.transform::picks_ui(id = ns("dat"), picks = dat) ), bslib::accordion( diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index fd7dd4e0e..a793a2fda 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -12,10 +12,10 @@ #' @inheritParams shared_params #' @param regressor (`picks`) Specification for regressor variables selection. #' Created using [teal.transform::picks()], which allows selecting variables -#' to use as regressors in the regression model. `variables(multiple = TRUE)` allowed. +#' to use as regressors in the regression model. `teal.transform::variables(multiple = TRUE)` allowed. #' @param response (`picks`) Specification for response variable selection. #' Created using [teal.transform::picks()], which allows selecting a single numeric variable -#' to use as the response in the regression model. `variables(multiple = TRUE)` not allowed. +#' to use as the response in the regression model. `teal.transform::variables(multiple = TRUE)` not allowed. #' @param outlier (`picks`) Optional specification for outlier label variable selection. #' Created using [teal.transform::picks()], which allows selecting a factor or character variable #' to label outlier points on the plots. @@ -91,13 +91,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = picks( +#' response = teal.transform::picks( #' datasets("CO2"), -#' variables(choices = "uptake", selected = "uptake") +#' teal.transform::variables(choices = "uptake", selected = "uptake") #' ), -#' regressor = picks( +#' regressor = teal.transform::picks( #' datasets("CO2"), -#' variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) +#' teal.transform::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) #' ) #' ) #' ) @@ -124,13 +124,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = picks( +#' response = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = "BMRKR1", selected = "BMRKR1") +#' teal.transform::variables(choices = "BMRKR1", selected = "BMRKR1") #' ), -#' regressor = picks( +#' regressor = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) +#' teal.transform::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) #' ) #' ) #' ) @@ -142,7 +142,15 @@ #' @export #' tm_a_regression <- function(label = "Regression Analysis", - regressor, + regressor = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric, + selected = tidyselect::last_col(), + multiple = TRUE + ), + teal.transform::values() + ), response, plot_height = c(600, 200, 2000), plot_width = NULL, diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 40b0be63b..7ff277c3b 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -1,24 +1,24 @@ #' @export tm_a_regression.picks <- function(label = "Regression Analysis", - regressor = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric), + regressor = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric, selected = tidyselect::last_col(), multiple = TRUE ), - values() + teal.transform::values() ), - response = picks( - datasets(), - variables(choices = tidyselect::where(is.numeric)), - values() + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(choices = is.numeric), + teal.transform::values() ), - outlier = picks( + outlier = teal.transform::picks( regressor$datasets, - variables(choices = where(~ is.factor(.) || is.character(.))), - values() - ), # default should be picks(datasets(), variables(primary_keys()) + teal.transform::variables(choices = tidyselect::where(~ is.factor(.) || is.character(.))), + teal.transform::values() + ), # default should be teal.transform::picks(datasets(), teal.transform::variables(primary_keys()) plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -40,12 +40,12 @@ tm_a_regression.picks <- function(label = "Regression Analysis", checkmate::assert_class(response, "picks") if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } checkmate::assert_class(outlier, "picks", null.ok = TRUE) if (isTRUE(attr(outlier$variables, "multiple"))) { - warning("`outlier` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`outlier` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(outlier$variables, "multiple") <- FALSE } @@ -117,10 +117,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", ui_args = args[names(args) %in% names(formals(ui_a_regression.picks))], server_args = args[names(args) %in% names(formals(srv_a_regression.picks))], , transformators = transformators, - datanames = { - datanames <- datanames(list(regressor, response)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(regressor, response)) ) attr(ans, "teal_bookmarkable") <- FALSE ans @@ -148,12 +145,12 @@ ui_a_regression.picks <- function(id, )), encoding = tags$div( tags$label("Encodings", class = "text-primary"), tags$br(), - teal::teal_nav_item( - label = tags$strong("Response variable"), + tags$div( + tags$strong("Response variable"), teal.transform::picks_ui(id = ns("response"), picks = response) ), - teal::teal_nav_item( - label = tags$strong("Regressor variables"), + tags$div( + tags$strong("Regressor variables"), teal.transform::picks_ui(id = ns("regressor"), picks = regressor) ), radioButtons( diff --git a/R/tm_g_association.R b/R/tm_g_association.R index 3c96e829a..d80f35b02 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -11,9 +11,9 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' @param ref (`picks`) -#' Reference variable specification created using `picks()`. +#' Reference variable specification created using `teal.transform::picks()`. #' @param vars (`picks`) -#' Variables to be associated with the reference variable, specified using `picks()`. +#' Variables to be associated with the reference variable, specified using `teal.transform::picks()`. #' @param show_association (`logical`) optional, whether show association of `vars` #' with reference variable. Defaults to `TRUE`. #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. @@ -67,16 +67,16 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = picks( +#' ref = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = "Plant" #' ) #' ), -#' vars = picks( +#' vars = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = "Treatment", #' multiple = TRUE @@ -106,16 +106,16 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = picks( +#' ref = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "RACE" #' ) #' ), -#' vars = picks( +#' vars = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "BMRKR2", #' multiple = TRUE @@ -130,25 +130,16 @@ #' #' @export tm_g_association <- function(label = "Association", - ref = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + ref = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - values() - ), - vars = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2L, # todo: make sure that is doesn't fail in teal.transform - multiple = TRUE - ), - values() + teal.transform::values() ), + vars, show_association = TRUE, plot_height = c(600, 400, 5000), plot_width = NULL, diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R index db6026c75..4ba372ca7 100644 --- a/R/tm_g_association_picks.R +++ b/R/tm_g_association_picks.R @@ -1,18 +1,18 @@ #' @export tm_g_association.picks <- function(label = "Association", - ref = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + ref = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - values() + teal.transform::values() ), - vars = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + vars = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2L, multiple = TRUE @@ -37,7 +37,7 @@ tm_g_association.picks <- function(label = "Association", checkmate::assert_string(label) checkmate::assert_class(ref, "picks") if (isTRUE(attr(ref$variables, "multiple"))) { - warning("`ref` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`ref` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(ref$variables, "multiple") <- FALSE } checkmate::assert_class(vars, "picks") @@ -71,10 +71,7 @@ tm_g_association.picks <- function(label = "Association", ui_args = args[names(args) %in% names(formals(ui_g_association.picks))], server_args = args[names(args) %in% names(formals(srv_g_association.picks))], transformators = transformators, - datanames = { - datanames <- datanames(list(ref = ref, vars = vars)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(ref = ref, vars = vars)) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -100,12 +97,12 @@ ui_g_association.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Reference variable"), + tags$div( + tags$strong("Reference variable"), teal.transform::picks_ui(id = ns("ref"), picks = ref) ), - teal::teal_nav_item( - label = tags$strong("Associated variables"), + tags$div( + tags$strong("Associated variables"), teal.transform::picks_ui(id = ns("vars"), picks = vars) ), checkboxInput(ns("association"), "Association with reference variable", value = show_association), diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index 6f90f15ca..f14d53f36 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -85,21 +85,21 @@ #' data = data, #' modules = tm_g_bivariate( #' label = "Bivariate Plots", -#' x = picks( +#' x = teal.transform::picks( #' datasets("CO2"), -#' variables(selected = "conc") +#' teal.transform::variables(selected = "conc") #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("CO2"), -#' variables(selected = "uptake") +#' teal.transform::variables(selected = "uptake") #' ), -#' row_facet = picks( +#' row_facet = teal.transform::picks( #' datasets("CO2"), -#' variables(selected = "Type") +#' teal.transform::variables(selected = "Type") #' ), -#' col_facet = picks( +#' col_facet = teal.transform::picks( #' datasets("CO2"), -#' variables(selected = "Treatment") +#' teal.transform::variables(selected = "Treatment") #' ) #' ) #' ) @@ -124,21 +124,21 @@ #' data = data, #' modules = tm_g_bivariate( #' label = "Bivariate Plots", -#' x = picks( +#' x = teal.transform::picks( #' datasets("ADSL"), -#' variables(selected = "AGE") +#' teal.transform::variables(selected = "AGE") #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("ADSL"), -#' variables(selected = "SEX") +#' teal.transform::variables(selected = "SEX") #' ), -#' row_facet = picks( +#' row_facet = teal.transform::picks( #' datasets("ADSL"), -#' variables(selected = "ARM") +#' teal.transform::variables(selected = "ARM") #' ), -#' col_facet = picks( +#' col_facet = teal.transform::picks( #' datasets("ADSL"), -#' variables(selected = "COUNTRY") +#' teal.transform::variables(selected = "COUNTRY") #' ) #' ) #' ) @@ -149,25 +149,19 @@ #' @export #' tm_g_bivariate <- function(label = "Bivariate Plots", - x = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L - ) + ), + teal.transform::values() ), - y = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2L - ) - ), - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), + y, + row_facet, + col_facet, + facet, color = NULL, fill = NULL, size = NULL, diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 1602e8d87..93a16d489 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -1,25 +1,39 @@ #' @export tm_g_bivariate.picks <- function(label = "Bivariate Plots", - x = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - values() + teal.transform::values() ), - y = picks( - datasets(), - variables( - choices = tidyselect::where(is.numeric) | + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2L ), - values() + teal.transform::values() + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() ), - row_facet = NULL, - col_facet = NULL, facet = !is.null(row_facet) || !is.null(col_facet), color = NULL, fill = NULL, @@ -112,10 +126,7 @@ tm_g_bivariate.picks <- function(label = "Bivariate Plots", ui_args = args[names(args) %in% names(formals(ui_g_bivariate.picks))], server_args = args[names(args) %in% names(formals(srv_g_bivariate.picks))], transformators = transformators, - datanames = { - datanames <- teal.transform::datanames(list(x, y, row_facet, col_facet, color, fill, size)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(x, y, row_facet, col_facet, color, fill, size)) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -143,26 +154,25 @@ ui_g_bivariate.picks <- function(id, post_output = NULL, decorators = list()) { ns <- NS(id) - teal::standard_layout2( + teal.widgets::standard_layout( output = bslib::card( teal.widgets::plot_with_settings_ui(id = ns("myplot")), full_screen = TRUE ), encoding = shiny::tagList( - teal::teal_nav_item( - label = tags$strong("X variable"), + tags$div( + tags$strong("X variable"), teal.transform::picks_ui(id = ns("x"), picks = x) ), - teal::teal_nav_item( - label = tags$strong("Y variable"), + tags$div( + tags$strong("Y variable"), teal.transform::picks_ui(id = ns("y"), picks = y) ), conditionalPanel( condition = "$(\"button[data-id*='-x-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' || $(\"button[data-id*='-y-dataset'][data-id$='-select']\").text() == '- Nothing selected - ' ", - teal::teal_nav_item( - label = NULL, + tags$div( shinyWidgets::radioGroupButtons( inputId = ns("use_density"), label = NULL, @@ -173,7 +183,7 @@ ui_g_bivariate.picks <- function(id, ) ), if (!is.null(row_facet)) { - teal::teal_nav_item( + tags$div( tags$div( tags$strong("Row facetting variable"), teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet), @@ -182,7 +192,7 @@ ui_g_bivariate.picks <- function(id, ) }, if (!is.null(col_facet)) { - teal::teal_nav_item( + tags$div( tags$div( tags$strong("Column facetting variable"), teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet), @@ -192,8 +202,8 @@ ui_g_bivariate.picks <- function(id, }, if (color_settings) { # Put a grey border around the coloring settings - teal::teal_nav_item( - label = tags$strong("Color settings"), + tags$div( + tags$strong("Color settings"), tags$div( bslib::input_switch(id = ns("coloring"), label = "Color settings", value = TRUE), conditionalPanel( @@ -210,8 +220,8 @@ ui_g_bivariate.picks <- function(id, ) ) }, - teal::teal_nav_item( - label = NULL, + tags$div( + NULL, teal:::.teal_navbar_menu( id = ns("plot_settings"), label = "Plot settings", @@ -240,7 +250,7 @@ ui_g_bivariate.picks <- function(id, ) ) ), - teal::teal_nav_item( + tags$div( ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")) ) ), diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index f3efe87bf..de88ffc91 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -71,10 +71,10 @@ #' data = data, #' modules = list( #' tm_g_distribution( -#' dist_var = picks( +#' dist_var = teal.transform::picks( #' datasets("iris"), -#' variables(tidyselect::where(is.numeric)), -#' values() +#' teal.transform::variables(is.numeric), +#' teal.transform::values() #' ) #' ) #' ) @@ -101,18 +101,18 @@ #' data = data, #' modules = modules( #' tm_g_distribution( -#' dist_var = picks( +#' dist_var = teal.transform::picks( #' datasets("ADSL"), -#' variables(c("BMRKR1", "AGE")), +#' teal.transform::variables(c("BMRKR1", "AGE")), #' values(multiple = FALSE) #' ), -#' strata_var = picks( +#' strata_var = teal.transform::picks( #' datasets("ADSL"), -#' variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) +#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ), -#' group_var = picks( +#' group_var = teal.transform::picks( #' datasets("ADSL"), -#' variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) +#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ) #' ) #' ) @@ -124,7 +124,11 @@ #' @export #' tm_g_distribution <- function(label = "Distribution Module", - dist_var, + dist_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), strata_var = NULL, group_var = NULL, freq = FALSE, diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R index e88f2b071..242019bef 100644 --- a/R/tm_g_distribution_picks.R +++ b/R/tm_g_distribution_picks.R @@ -1,12 +1,26 @@ #' @export tm_g_distribution.picks <- function(label = "Distribution Module", - dist_var = picks( - datasets(), - variables(where(is.numeric)), - values() + dist_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), + strata_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + group_var = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() ), - strata_var = NULL, - group_var = NULL, freq = FALSE, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), ggplot2_args = teal.widgets::ggplot2_args(), @@ -24,7 +38,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", checkmate::assert_class(dist_var, "picks") if (isTRUE(attr(dist_var$variables, "multiple"))) { - warning("dist_var accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("dist_var accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(dist_var$variables, "multiple") <- FALSE } checkmate::assert_class(strata_var, "picks", null.ok = TRUE) @@ -71,10 +85,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", ui_args = args[names(args) %in% names(formals(ui_g_distribution.picks))], server_args = args[names(args) %in% names(formals(srv_g_distribution.picks))], , transformators = transformators, - datanames = { - datanames <- datanames(list(dist_var, strata_var, group_var)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(dist_var, strata_var, group_var)) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -119,14 +130,14 @@ ui_g_distribution.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Variable"), + tags$div( + tags$strong("Variable"), teal.transform::picks_ui(id = ns("dist_var"), picks = dist_var) ), if (!is.null(group_var)) { tagList( - teal::teal_nav_item( - label = tags$strong("Group by:"), + tags$div( + tags$strong("Group by:"), teal.transform::picks_ui(id = ns("group_var"), picks = group_var) ), uiOutput(ns("scales_types_ui")) @@ -134,8 +145,8 @@ ui_g_distribution.picks <- function(id, }, if (!is.null(strata_var)) { tagList( - teal::teal_nav_item( - label = tags$strong("Stratify by:"), + tags$div( + tags$strong("Stratify by:"), teal.transform::picks_ui(id = ns("strata_var"), picks = strata_var) ) ) diff --git a/R/tm_g_response.R b/R/tm_g_response.R index ee12dfe5f..a83c434e3 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -89,17 +89,17 @@ #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ), -#' x = picks( +#' x = teal.transform::picks( #' datasets("mtcars"), -#' variables( +#' teal.transform::variables( #' choices = c("vs", "am"), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ) #' ) #' ) @@ -126,21 +126,21 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = picks( +#' response = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = c("BMRKR2", "COUNTRY"), #' selected = "BMRKR2" #' ), -#' values() +#' teal.transform::values() #' ), -#' x = picks( +#' x = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = c("SEX", "RACE"), #' selected = "RACE" #' ), -#' values() +#' teal.transform::values() #' ) #' ) #' ) @@ -152,19 +152,12 @@ #' @export #' tm_g_response <- function(label = "Response Plot", - response = picks( - datasets(), - variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10)), - values() - ), - x = picks( - datasets(), - variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2L - ), - values() + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10)), + teal.transform::values() ), + x, row_facet = NULL, col_facet = NULL, coord_flip = FALSE, diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R index 9ad1b1232..0166b0784 100644 --- a/R/tm_g_response_picks.R +++ b/R/tm_g_response_picks.R @@ -1,9 +1,36 @@ #' @export tm_g_response.picks <- function(label = "Response Plot", - response, - x, - row_facet = NULL, - col_facet = NULL, + response = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10) + ), + teal.transform::values() + ), + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L + ), + teal.transform::values() + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL + ), + teal.transform::values() + ), coord_flip = FALSE, count_labels = TRUE, rotate_xaxis_labels = FALSE, @@ -23,13 +50,13 @@ tm_g_response.picks <- function(label = "Response Plot", checkmate::assert_class(response, "picks") if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } checkmate::assert_class(x, "picks") if (isTRUE(attr(x$variables, "multiple"))) { - warning("`x` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`x` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(x$variables, "multiple") <- FALSE } @@ -66,10 +93,7 @@ tm_g_response.picks <- function(label = "Response Plot", ui_args = args[names(args) %in% names(formals(ui_g_response.picks))], server_args = args[names(args) %in% names(formals(srv_g_response.picks))], transformators = transformators, - datanames = { - datanames <- datanames(list(response, x, row_facet, col_facet)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(response, x, row_facet, col_facet)) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -96,23 +120,23 @@ ui_g_response.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Response variable"), + tags$div( + tags$strong("Response variable"), teal.transform::picks_ui(id = ns("response"), picks = response) ), - teal::teal_nav_item( - label = tags$strong("X variable"), + tags$div( + tags$strong("X variable"), teal.transform::picks_ui(id = ns("x"), picks = x) ), if (!is.null(row_facet)) { - teal::teal_nav_item( - label = tags$strong("Row facetting"), + tags$div( + tags$strong("Row facetting"), teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { - teal::teal_nav_item( - label = tags$strong("Column facetting"), + tags$div( + tags$strong("Column facetting"), teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index c6863fad0..a99b0cbb9 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -75,47 +75,47 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = picks( +#' x = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("conc", "uptake"), #' selected = "conc" #' ), -#' values() +#' teal.transform::values() #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("conc", "uptake"), #' selected = "uptake" #' ), -#' values() +#' teal.transform::values() #' ), -#' color_by = picks( +#' color_by = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("Plant", "Type", "Treatment", "conc", "uptake"), #' selected = NULL #' ), -#' values() +#' teal.transform::values() #' ), -#' size_by = picks( +#' size_by = teal.transform::picks( #' datasets("CO2"), -#' variables(choices = c("conc", "uptake"), selected = "uptake"), -#' values() +#' teal.transform::variables(choices = c("conc", "uptake"), selected = "uptake"), +#' teal.transform::values() #' ), -#' row_facet = picks( +#' row_facet = teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = NULL #' ), -#' values() +#' teal.transform::values() #' ), -#' col_facet = picks( +#' col_facet = teal.transform::picks( #' datasets("CO2"), -#' variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), -#' values() +#' teal.transform::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), +#' teal.transform::values() #' ) #' ) #' ) @@ -144,35 +144,35 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = picks( +#' x = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), -#' values() +#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), +#' teal.transform::values() #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), -#' values() +#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), +#' teal.transform::values() #' ), -#' color_by = picks( +#' color_by = teal.transform::picks( #' datasets("ADSL"), -#' variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), -#' values() +#' teal.transform::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ), -#' size_by = picks( +#' size_by = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), -#' values() +#' teal.transform::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), +#' teal.transform::values() #' ), -#' row_facet = picks( +#' row_facet = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), -#' values() +#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ), -#' col_facet = picks( +#' col_facet = teal.transform::picks( #' datasets("ADSL"), -#' variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), -#' values() +#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.transform::values() #' ) #' ) #' ) @@ -184,7 +184,11 @@ #' @export #' tm_g_scatterplot <- function(label = "Scatterplot", - x, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() + ), y, color_by = NULL, size_by = NULL, diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index 47b8a1ccb..be6f8d627 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -1,19 +1,51 @@ #' @export tm_g_scatterplot.picks <- function(label = "Scatterplot", - x = picks( - datasets(), - variables(tidyselect::where(is.numeric)), - values() + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric), + teal.transform::values() ), - y = picks( - datasets(), - variables(tidyselect::where(is.numeric), selected = 2), - values() + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(is.numeric, selected = 2L), + teal.transform::values() + ), + color_by = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL, + multiple = TRUE + ), + teal.transform::values() + ), + size_by = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL, + multiple = TRUE + ), + teal.transform::values() + ), + row_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL, + multiple = TRUE + ), + teal.transform::values() + ), + col_facet = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = NULL, + multiple = TRUE + ), + teal.transform::values() ), - color_by = NULL, - size_by = NULL, - row_facet = NULL, - col_facet = NULL, plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -39,13 +71,13 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", checkmate::assert_class(row_facet, "picks", null.ok = TRUE) if (isTRUE(attr(row_facet$variables, "multiple"))) { - warning("`row_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`row_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(row_facet$variables, "multiple") <- FALSE } checkmate::assert_class(col_facet, "picks", null.ok = TRUE) if (isTRUE(attr(col_facet$variables, "multiple"))) { - warning("`col_facet` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`col_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(col_facet$variables, "multiple") <- FALSE } @@ -96,10 +128,7 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", ui_args = args[names(args) %in% names(formals(ui_g_scatterplot.picks))], server_args = args[names(args) %in% names(formals(srv_g_scatterplot.picks))], transformators = transformators, - datanames = { - datanames <- datanames(list(x, y, color_by, size_by, row_facet, col_facet)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(x, y, color_by, size_by, row_facet, col_facet)) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -135,8 +164,8 @@ ui_g_scatterplot.picks <- function(id, ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("X variable"), + tags$div( + tags$strong("X variable"), teal.transform::picks_ui(id = ns("x"), picks = x), checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), conditionalPanel( @@ -149,8 +178,8 @@ ui_g_scatterplot.picks <- function(id, ) ) ), - teal::teal_nav_item( - label = tags$strong("Y variable"), + tags$div( + tags$strong("Y variable"), teal.transform::picks_ui(id = ns("y"), picks = y), checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), conditionalPanel( @@ -164,26 +193,26 @@ ui_g_scatterplot.picks <- function(id, ) ), if (!is.null(color_by)) { - teal::teal_nav_item( - label = tags$strong("Color by:"), + tags$div( + tags$strong("Color by:"), teal.transform::picks_ui(id = ns("color_by"), picks = color_by) ) }, if (!is.null(size_by)) { - teal::teal_nav_item( - label = tags$strong("Size by:"), + tags$div( + tags$strong("Size by:"), teal.transform::picks_ui(id = ns("size_by"), picks = size_by) ) }, if (!is.null(row_facet)) { - teal::teal_nav_item( - label = tags$strong("Row facetting"), + tags$div( + tags$strong("Row facetting"), teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { - teal::teal_nav_item( - label = tags$strong("Column facetting"), + tags$div( + tags$strong("Column facetting"), teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, @@ -339,19 +368,17 @@ srv_g_scatterplot.picks <- function(id, trend_line_is_applicable() && length(smoothing_degree) > 0 }) - if (!is.null(color_by)) { - observeEvent( - eventExpr = selectors$color_by(), - handlerExpr = { - color_by_var <- merged$variables()$color_by - if (length(color_by_var) > 0) { - shinyjs::hide("color") - } else { - shinyjs::show("color") - } + observeEvent( + eventExpr = selectors$color_by(), + handlerExpr = { + color_by_var <- merged$variables()$color_by + if (length(color_by_var) > 0) { + shinyjs::hide("color") + } else { + shinyjs::show("color") } - ) - } + } + ) output$num_na_removed <- renderUI({ if (add_trend_line()) { @@ -455,13 +482,6 @@ srv_g_scatterplot.picks <- function(id, ) } - facet_cl <- facet_ggplot_call( - row_facet_var, - col_facet_var, - free_x_scales = isTRUE(input$free_scales), - free_y_scales = isTRUE(input$free_scales) - ) - point_sizes <- if (length(size_by_var) > 0) { validate(need(is.numeric(anl[[size_by_var]]), "Variable to size by must be numeric")) substitute( @@ -504,7 +524,7 @@ srv_g_scatterplot.picks <- function(id, ) } - pre_pro_anl <- if (input$show_count) { + group_anl_call <- if (input$show_count) { paste0( "anl %>% dplyr::group_by(", paste( @@ -521,7 +541,10 @@ srv_g_scatterplot.picks <- function(id, "anl" } - plot_call <- substitute(expr = pre_pro_anl %>% ggplot2::ggplot(), env = list(pre_pro_anl = str2lang(pre_pro_anl))) + plot_call <- substitute( + expr = group_anl_call %>% ggplot2::ggplot(), + env = list(group_anl_call = str2lang(group_anl_call)) + ) plot_call <- if (length(color_by_var) == 0) { substitute( @@ -666,7 +689,13 @@ srv_g_scatterplot.picks <- function(id, shinyjs::show("line_msg") } - if (!is.null(facet_cl)) { + if (length(row_facet_var) || length(col_facet_var)) { + facet_cl <- facet_ggplot_call( + row_facet_var, + col_facet_var, + free_x_scales = isTRUE(input$free_scales), + free_y_scales = isTRUE(input$free_scales) + ) plot_call <- substitute(expr = plot_call + facet_cl, env = list(plot_call = plot_call, facet_cl = facet_cl)) } diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 340f8b457..421ab2179 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -13,7 +13,7 @@ #' #' @param variables (`picks` or `list` of `picks`) #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -#' `picks` use `variables(..., ordered = TRUE)` if plot elements should be +#' `picks` use `teal.transform::variables(..., ordered = TRUE)` if plot elements should be #' rendered according to selection order. #' #' @inherit shared_params return @@ -94,19 +94,19 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' picks( +#' teal.transform::picks( #' datasets("countries"), -#' variables( +#' teal.transform::variables( #' choices = tidyselect::everything(), #' selected = c("area", "gdp", "debt"), #' multiple = TRUE, #' ordered = TRUE #' ), -#' values() +#' teal.transform::values() #' ), -#' picks( +#' teal.transform::picks( #' datasets("sales"), -#' variables( +#' teal.transform::variables( #' choices = c("quantity", "costs", "profit"), #' selected = c("quantity", "costs", "profit"), #' multiple = TRUE, @@ -116,10 +116,10 @@ #' ), #' transformators = list( #' teal_transform_filter( -#' picks( +#' teal.transform::picks( #' datasets("sales"), -#' variables("country_id"), -#' values() +#' teal.transform::variables("country_id"), +#' teal.transform::values() #' ) #' ) #' ) @@ -149,20 +149,20 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' picks( +#' teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = tidyselect::everything(), #' selected = c("AGE", "RACE", "SEX"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ), -#' picks( +#' teal.transform::picks( #' datasets("ADRS"), -#' variables( +#' teal.transform::variables( #' choices = tidyselect::everything(), #' selected = c("AGE", "AVAL", "ADY"), #' multiple = TRUE, @@ -172,7 +172,7 @@ #' ) #' ), #' transformators = list( -#' teal_transform_filter(picks(datasets("ADRS"), variables("PARAMCD"), values(selected = "BESRSPI"))) +#' teal_transform_filter(teal.transform::picks(datasets("ADRS"), teal.transform::variables("PARAMCD"), values(selected = "BESRSPI"))) #' ) #' ) #' ) @@ -183,15 +183,19 @@ #' #' @export tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", - variables, + variables = list( + teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) + ) + ), plot_height = c(600, 200, 2000), plot_width = NULL, pre_output = NULL, post_output = NULL, transformators = list(), decorators = list()) { - # `object` just determines a method, but original `variables` is passed - UseMethod("tm_g_scatterplotmatrix", object = variables[[1]]) + UseMethod("tm_g_scatterplotmatrix", variables[[1]]) } #' @export diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R index df10d984a..e4112820c 100644 --- a/R/tm_g_scatterplotmatrix_picks.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -1,9 +1,9 @@ #' @export tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", variables = list( - picks( - datasets(), - variables(selected = seq(1, 5), multiple = TRUE) + teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) ) ), plot_height = c(600, 200, 2000), @@ -13,7 +13,6 @@ tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", transformators = list(), decorators = list()) { message("Initializing tm_g_scatterplotmatrix") - if (is.null(names(variables))) { names(variables) <- sprintf("pick_%s", seq_along(variables)) } @@ -44,10 +43,7 @@ tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", ui_args = args[names(args) %in% names(formals(ui_g_scatterplotmatrix.picks))], server_args = args[names(args) %in% names(formals(srv_g_scatterplotmatrix.picks))], transformators = transformators, - datanames = { - datanames <- datanames(variables) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(variables) ) attr(ans, "teal_bookmarkable") <- TRUE ans @@ -71,7 +67,7 @@ ui_g_scatterplotmatrix.picks <- function(id, tags$label("Encodings", class = "text-primary"), tagList( lapply(names(variables), function(id) { - teal::teal_nav_item( + tags$div( teal.transform::picks_ui(id = ns(id), picks = variables[[id]]) ) }) @@ -117,6 +113,8 @@ srv_g_scatterplotmatrix.picks <- function(id, decorators) { checkmate::assert_class(data, "reactive") checkmate::assert_class(isolate(data()), "teal_data") + checkmate::assert_list(variables, "picks", names = "named") + moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") @@ -127,7 +125,6 @@ srv_g_scatterplotmatrix.picks <- function(id, validated_q <- reactive({ obj <- req(data()) - input_ids <- sprintf("%s-variables-selected", names(variables)) selected_variables <- unname(unlist(lapply(selectors, function(selector) selector()$variables$selected))) validate_input( @@ -145,13 +142,12 @@ srv_g_scatterplotmatrix.picks <- function(id, }) merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") - variables <- reactive(unname(unlist(merged$variables()))) # plot output_q <- reactive({ qenv <- req(merged$data()) anl <- qenv[["anl"]] - cols_names <- variables() + cols_names <- unname(unlist(merged$variables())) alpha <- input$alpha cex <- input$cex add_cor <- input$cor @@ -282,7 +278,7 @@ srv_g_scatterplotmatrix.picks <- function(id, # show a message if conversion to factors took place output$message <- renderText({ - cols_names <- req(variables()) + cols_names <- req(unname(unlist(merged$variables()))) anl <- merged$data()[["anl"]] check_char <- vapply(anl[, cols_names], is.character, logical(1)) if (any(check_char)) { diff --git a/R/tm_markdown.R b/R/tm_markdown.R deleted file mode 100644 index 0e2561c7f..000000000 --- a/R/tm_markdown.R +++ /dev/null @@ -1,84 +0,0 @@ -#' `teal` module: Rmarkdown page -#' -#' Render arbitrary Rmarkdown code. `data` provided to teal application are available in the -#' rendered document. -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @inheritParams rmarkdown::render -#' @param text (`character`) arbitrary Rmd code -#' -#' @inherit shared_params return -#' -#' @examplesShinylive -#' library(teal.modules.general) -#' interactive <- function() TRUE -#' {{ next_example }} -#' @examples -#' data <- teal_data() |> -#' within({ -#' iris <- iris -#' mtcars <- mtcars -#' }) -#' # -#' -#' @export -#' -tm_rmarkdown <- function(label = "App Info", - text = character(0), - params = list(title = "Document"), - datanames = "all") { - message("Initializing tm_rmarkdown") - - # Start of assertions - checkmate::assert_string(label) - checkmate::assert_character(text, min.len = 0, any.missing = FALSE) - checkmate::assert_list(params) - - - ans <- module( - label = label, - server = srv_rmarkdown, - ui = ui_rmarkdown, - server_args = list(text = text, params = params), - datanames = datanames - ) - attr(ans, "teal_bookmarkable") <- TRUE - ans -} - -# UI function for the front page module -ui_rmarkdown <- function(id, ...) { - args <- list(...) - ns <- NS(id) - uiOutput(ns("output")) -} - -# Server function for the front page module -srv_rmarkdown <- function(id, data, text, params) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - rmd_out <- reactive({ - file <- tempfile(fileext = ".Rmd") - if (!file.exists(file)) { - cat(text, file = file) - } - rmarkdown::render( - file, - envir = data(), - params = utils::modifyList( - params, - list(output = list(github_document = list(html_preview = FALSE))) # html_document always as we renderUI below - ) - ) - }) - - output$output <- renderUI({ - on.exit(unlink(rmd_out())) - # todo: includeMarkdown breaks css of the app - # https://stackoverflow.com/questions/42422771/including-markdown-tables-in-shiny-app-seems-to-break-css - shiny::includeMarkdown(rmd_out()) - }) - }) -} diff --git a/R/tm_outliers.R b/R/tm_outliers.R index b0299fbd6..2ab1a84a0 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -66,21 +66,21 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' picks( +#' teal.transform::picks( #' datasets("CO2"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), #' selected = "uptake", #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ) #' ), #' categorical_var = list( -#' picks( +#' teal.transform::picks( #' datasets("CO2"), -#' variables(), +#' teal.transform::variables(), #' values( #' vars = vars, #' choices = value_choices(data[["CO2"]], vars$selected), @@ -118,21 +118,21 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' picks( +#' teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), #' selected = "AGE", #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ) #' ), #' categorical_var = list( -#' picks( +#' teal.transform::picks( #' datasets("ADSL"), -#' variables(), +#' teal.transform::variables(), #' values( #' vars = vars, #' choices = value_choices(data[["ADSL"]], vars$selected), diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R deleted file mode 100644 index 65f8734d6..000000000 --- a/R/tm_p_bargraph.R +++ /dev/null @@ -1,253 +0,0 @@ -#' Bar Graph Module -#' -#' This module creates an interactive horizontal stacked bar chart visualization that -#' displays counts of distinct values grouped by categories. The bars are automatically -#' ordered by total count (ascending) and support color coding by a categorical variable. -#' Users can select bar segments by brushing to filter the underlying data. The plot -#' aggregates data by counting distinct values within each group combination. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param y_var (`character(1)`) Name of the categorical variable to be displayed on y-axis (bar categories). -#' @param color_var (`character(1)`) Name of the categorical variable used for color coding and stacking segments. -#' @param count_var (`character(1)`) Name of the variable whose distinct values will be counted for bar heights. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created. -#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash"), -#' 100, -#' replace = TRUE, prob = c(0.3, 0.25, 0.2, 0.15, 0.1) -#' ), -#' severity = sample(c("Mild", "Moderate", "Severe"), 100, -#' replace = TRUE, -#' prob = c(0.6, 0.3, 0.1) -#' ), -#' subject_id = sample(paste0("S", 1:30), 100, replace = TRUE), -#' treatment = sample(c("Active", "Placebo"), 100, replace = TRUE) -#' ) -#' -#' # Add labels -#' attr(df$adverse_event, "label") <- "Adverse Event Type" -#' attr(df$severity, "label") <- "Severity Grade" -#' attr(df$subject_id, "label") <- "Subject ID" -#' attr(df$treatment, "label") <- "Treatment Group" -#' }) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_bargraph( -#' label = "AE by Treatment", -#' plot_dataname = "df", -#' y_var = "adverse_event", -#' color_var = "treatment", -#' count_var = "subject_id", -#' bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), -#' tooltip_vars = c("adverse_event", "treatment") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_bargraph <- function(label = "Bar Plot", - plot_dataname, - y_var, - color_var, - count_var, - tooltip_vars = NULL, - bar_colors = NULL) { - module( - label = label, - ui = ui_p_bargraph, - server = srv_p_bargraph, - ui_args = list(), - server_args = list( - plot_dataname = plot_dataname, - y_var = y_var, - color_var = color_var, - count_var = count_var, - tooltip_vars = tooltip_vars, - bar_colors = bar_colors - ) - ) -} - -ui_p_bargraph <- function(id) { - ns <- NS(id) - bslib::page_fluid( - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ) - ) -} - -srv_p_bargraph <- function(id, - data, - plot_dataname, - y_var, - color_var, - count_var, - tooltip_vars = NULL, - bar_colors) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - data() |> - within( - { - df[[color_var]] <- as.character(df[[color_var]]) - - plot_data <- df %>% - dplyr::group_by(!!as.name(y_var), !!as.name(color_var)) %>% - dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var))) %>% - dplyr::ungroup() %>% - dplyr::mutate(customdata = dplyr::row_number()) %>% - dplyr::mutate( - tooltip = { - if (is.null(tooltip_vars)) { - # Default tooltip: show y_var, color_var, and count - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - paste( - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - paste("Count:", count), - sep = "
" - ) - } else { - # Custom tooltip: use specified columns - cur_data <- dplyr::cur_data() - - # Map tooltip_vars to actual column names if they are parameter names - actual_cols <- character(0) - for (col in tooltip_vars) { - if (col == "y_var") { - actual_cols <- c(actual_cols, y_var) - } else if (col == "color_var") { - actual_cols <- c(actual_cols, color_var) - } else if (col == "count_var") { - actual_cols <- c(actual_cols, "count") # Use the aggregated count column - } else { - # Assume it's already a column name - actual_cols <- c(actual_cols, col) - } - } - - # Get columns that actually exist in the data - cols <- intersect(actual_cols, names(cur_data)) - - if (!length(cols)) { - # Fallback to default - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - paste( - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - paste("Count:", count), - sep = "
" - ) - } else { - # Create simple tooltip with column names and values - sub <- cur_data[cols] - values <- lapply(sub, as.character) - parts <- Map(function(v, n) paste0(n, ": ", v), values, names(values)) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) - - event_type_order <- plot_data %>% - dplyr::group_by(!!as.name(y_var)) %>% - dplyr::summarize(total = sum(count), .groups = "drop") %>% - dplyr::arrange(total) %>% - dplyr::pull(!!as.name(y_var)) - - plot_data[[y_var]] <- factor(plot_data[[y_var]], levels = event_type_order) - - p <- plotly::plot_ly( - data = plot_data, - y = as.formula(paste0("~", y_var)), - x = ~count, - color = as.formula(paste0("~", color_var)), - colors = bar_colors, - type = "bar", - orientation = "h", - hovertext = ~tooltip, - hoverinfo = "text", - customdata = ~customdata, - source = source - ) %>% - plotly::layout( - barmode = "stack", - xaxis = list(title = "Count"), - yaxis = list(title = "Adverse Event Type"), - legend = list(title = list(text = "AE Type")) - ) %>% - plotly::layout(dragmode = "select") - }, - df = str2lang(plot_dataname), - color_var = color_var, - y_var = y_var, - count_var = count_var, - tooltip_vars = tooltip_vars, - bar_colors = bar_colors, - source = session$ns("bargraph") - ) - }) - - - output$plot <- plotly::renderPlotly({ - plotly_q()$p %>% - set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) |> - plotly::event_register("plotly_selected") - }) - plotly_selected <- reactive( - plotly::event_data("plotly_selected", source = session$ns("bargraph")) - ) - - reactive({ - if (is.null(plotly_selected())) { - plotly_q() - } else { - q <- plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - df <- df |> - dplyr::filter( - !!as.name(y_var_string) %in% selected_plot_data[[y_var_string]], - !!as.name(color_var_string) %in% selected_plot_data[[color_var_string]] - ) - }, - df = str2lang(plot_dataname), - y_var_string = y_var, - color_var_string = color_var, - plotly_selected_customdata = plotly_selected()$customdata - ) - attr(q, "has_brushing") <- TRUE - q - } - }) - }) -} diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R deleted file mode 100644 index 378220c5e..000000000 --- a/R/tm_p_lineplot.R +++ /dev/null @@ -1,296 +0,0 @@ -#' Line Plot Module -#' -#' This module creates an interactive line plot visualization that connects data points -#' within groups to show trends over time. The plot displays both line segments connecting -#' points and individual markers, with support for customizable tooltips and color coding. -#' Optional reference lines can be added to highlight specific values. The plot can be -#' activated by brushing events from other plots when used in combination modules. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param x_var (`character(1)`) Name of the variable to be used for x-axis (typically time). -#' @param y_var (`character(1)`) Name of the variable to be used for y-axis (typically a measurement). -#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines. -#' @param group_var (`character(1)`) Name of the grouping variable that defines which points to connect with lines. -#' @param colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of color_var column. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing group, x, y, and color variables. -#' @param transformators (`list`) Named list of transformator functions. -#' @param reference_lines (`list` or `NULL`) Reference lines specification for adding horizontal reference lines. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' subject_id = rep(paste0("S", 1:8), each = 5), -#' time_week = rep(c(0, 2, 4, 6, 8), 8), -#' measurement = rnorm(40, 20, 4) + rep(c(0, 1, 2, 3, 4), 8), -#' treatment = rep(c("Active", "Placebo"), each = 20), -#' baseline = rep(rnorm(8, 18, 2), each = 5) -#' ) -#' -#' # Add labels -#' attr(df$subject_id, "label") <- "Subject ID" -#' attr(df$time_week, "label") <- "Time (weeks)" -#' attr(df$measurement, "label") <- "Measurement Value" -#' attr(df$treatment, "label") <- "Treatment Group" -#' attr(df$baseline, "label") <- "Baseline Value" -#' }) -#' -#' # Basic line plot example -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_lineplot( -#' label = "Line Plot", -#' plot_dataname = "df", -#' x_var = "time_week", -#' y_var = "measurement", -#' color_var = "treatment", -#' group_var = "subject_id", -#' tooltip_vars = c("subject_id", "time_week") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_lineplot <- function(label = "Line Plot", - x_var, - y_var, - color_var, - group_var, - colors = NULL, - tooltip_vars = NULL, - transformators = list(), - reference_lines = NULL) { - checkmate::assert_string(label) - checkmate::assert_class(x_var, "picks") - checkmate::assert_class(x_var, "picks") - checkmate::assert_class(color_var, "picks") - checkmate::assert_class(group_var, "picks") - checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) - args <- as.list(environment()) - module( - label = label, - ui = ui_p_lineplot, - server = srv_p_lineplot, - ui_args = args[names(args) %in% names(formals(ui_p_lineplot))], - server_args = args[names(args) %in% names(formals(srv_p_lineplot))], - transformators = transformators, - datanames = { - datanames <- datanames(list(x_var = x_var, y_var = y_var, color_var = color_var, group_var)) - if (length(datanames)) datanames else "all" - } - ) -} - -# todo: ui/srv_p_lineplot_module - -ui_p_lineplot <- function(id) { - ns <- NS(id) - tags$div( - class = "standard-layout output-panel", - shinyjs::useShinyjs(), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ) - ) -} - -srv_p_lineplot <- function(id, - data, - dataname, - x_var, - y_var, - color_var, - group_var, - colors, - tooltip_vars = NULL, - reference_lines) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - req(data()) - data() %>% - within( - df = str2lang(dataname), - x_var = x_var(), - y_var = y_var(), - color_var = color_var(), - group_var = group_var(), - colors = colors(), - tooltip_vars = tooltip_vars(), - reference_lines = reference_lines, - { - validate(need(nrow(df) > 0, "No data after applying filters.")) - - # Get label attributes for variables, fallback to column names - group_var_label <- attr(df[[group_var]], "label") - if (!length(group_var_label)) group_var_label <- group_var - - x_var_label <- attr(df[[x_var]], "label") - if (!length(x_var_label)) x_var_label <- x_var - - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var - - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - # Add tooltip to the data - df <- df |> - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::mutate( - tooltip = { - if (is.null(tooltip_vars)) { - # Default tooltip: show group, x, y, color variables with labels - paste( - paste(group_var_label, ":", !!as.name(group_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Custom tooltip: show only specified columns - cur_data <- dplyr::cur_data() - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - # Fallback to default if no valid columns found - paste( - paste(group_var_label, ":", !!as.name(group_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Create tooltip from specified columns - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - if (cn == group_var) { - lb <- group_var_label - } else if (cn == x_var) { - lb <- x_var_label - } else if (cn == y_var) { - lb <- y_var_label - } else if (cn == color_var) { - lb <- color_var_label - } else { - lb <- attr(sub[[cn]], "label") - } - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) - - add_reference_lines <- function(data, - reference_lines, - default_line_color = "red", - default_font_color = "red", - default_font_size = 12) { - shapes <- list() - annotations <- list() - for (i in seq_along(reference_lines)) { - if (is.character(reference_lines[[i]]) && length(reference_lines[[i]]) == 1) { - col <- reference_lines[[i]] - label <- col - line_mode <- "dash" - } else if (is.list(reference_lines[[i]])) { - col <- names(reference_lines)[i] - if (col == "") next - label <- if (!is.null(reference_lines[[col]]$label)) reference_lines[[col]]$label else col - line_mode <- if (!is.null(reference_lines[[col]]$line_mode)) reference_lines[[col]]$line_mode else "dash" - } else { - next - } - if (length(unique(data[[col]])) != 1) { - label <- paste0(label, "
(mean)") - } - y_val <- mean(data[[col]]) - shapes[[length(shapes) + 1]] <- list( - type = "line", - x0 = 0, x1 = 1, - xref = "paper", - y0 = y_val, y1 = y_val, - yref = "y", - line = list(color = default_line_color, dash = line_mode, width = 2) - ) - annotations[[length(annotations) + 1]] <- list( - x = 1, xref = "paper", - y = y_val, yref = "y", - text = label, - showarrow = FALSE, - xanchor = "left", - font = list(color = default_font_color, size = default_font_size) - ) - } - list(shapes = shapes, annotations = annotations) - } - - segments_df <- df %>% - dplyr::arrange(!!as.name(group_var), !!as.name(x_var)) %>% - dplyr::group_by(!!as.name(group_var)) %>% - dplyr::mutate( - xend = dplyr::lead(!!as.name(x_var)), - yend = dplyr::lead(!!as.name(y_var)), - color_var_seg = dplyr::lead(!!as.name(color_var)) - ) %>% - dplyr::filter(!is.na(xend)) - - p <- plotly::plot_ly( - data = segments_df, - source = "spiderplot", - height = 600L - ) %>% - plotly::add_segments( - x = stats::as.formula(sprintf("~%s", x_var)), - y = stats::as.formula(sprintf("~%s", y_var)), - xend = ~xend, - yend = ~yend, - color = ~color_var_seg, - colors = colors - ) %>% - plotly::add_markers( - data = df, - x = stats::as.formula(sprintf("~%s", x_var)), - y = stats::as.formula(sprintf("~%s", y_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - text = ~tooltip, - hoverinfo = "text" - ) - - if (!is.null(reference_lines)) { - ref_lines <- add_reference_lines(df, reference_lines) - p <- p %>% - plotly::layout( - shapes = ref_lines$shapes, - annotations = ref_lines$annotations - ) - } - p - } - ) - }) - - - output$plot <- plotly::renderPlotly({ - req(plotly_q()) - tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> - plotly::event_register("plotly_selected") - }) - }) -} diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R deleted file mode 100644 index 1975b4597..000000000 --- a/R/tm_p_scatterplot.R +++ /dev/null @@ -1,313 +0,0 @@ -#' Scatterplot Module -#' -#' This module creates an interactive scatter plot visualization with customizable tooltips. -#' Users can select points by brushing to filter the underlying data. The plot supports -#' color coding by categorical variables and displays tooltips on hover that can show -#' default variables (subject, x, y, color) or custom columns specified via `tooltip_vars`. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param subject_var (`character(1)`) Name of the subject variable. -#' @param x_var (`character(1)`) Name of the variable to be used for x-axis. -#' @param y_var (`character(1)`) Name of the variable to be used for y-axis. -#' @param color_var (`character(1)`) Name of the variable to be used for coloring points. -#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing x, y, and color variables. -#' @param transformators (`list`) Named list of transformator functions. -#' @param show_widgets (`logical(1)`) Whether to show module widgets. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' subject_id = paste0("S", 1:50), -#' age = sample(20:80, 50, replace = TRUE), -#' response = rnorm(50, 15, 3), -#' treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), -#' gender = sample(c("M", "F"), 50, replace = TRUE) -#' ) -#' -#' # Add labels for better tooltips -#' attr(df$age, "label") <- "Age (years)" -#' attr(df$response, "label") <- "Response Score" -#' attr(df$treatment, "label") <- "Treatment Group" -#' }) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_scatterplot( -#' label = "Scatter Plot with Custom Tooltip", -#' plot_dataname = "df", -#' subject_var = "subject_id", -#' x_var = "age", -#' y_var = "response", -#' color_var = "treatment", -#' tooltip_vars = c("age", "gender") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_scatterplot <- function(label = "Scatter Plot", - subject_var, - x_var, - y_var, - color_var, - point_colors = character(0), - tooltip_vars = NULL, - transformators = list()) { - checkmate::assert_string(label) - checkmate::assert_class(subject_var, "picks") - checkmate::assert_class(x_var, "picks") - checkmate::assert_class(y_var, "picks") - checkmate::assert_class(color_var, "picks") - checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) - - args <- as.list(environment()) - module( - label = label, - ui = ui_p_scatterplot_module, - server = srv_p_scatterplot_module, - ui_args = args[names(args) %in% names(formals(ui_p_scatterplot_module))], - server_args = args[names(args) %in% names(formals(srv_p_scatterplot_module))], - transformators = transformators, - datanames = { - datanames <- datanames(list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var)) - if (length(datanames)) datanames else "all" - } - ) -} - -ui_p_scatterplot_module <- function(id, subject_var, x_var, y_var, color_var) { - ns <- NS(id) - bslib::page_sidebar( - sidebar = div( - class = "standard-layout encoding-panel", - teal::teal_nav_item( - label = tags$strong("Subject Variable:"), - teal.transform::picks_ui(id = ns("subject_var"), picks = subject_var) - ), - teal::teal_nav_item( - label = tags$strong("X-axis Variable:"), - teal.transform::picks_ui(id = ns("x_var"), picks = x_var) - ), - teal::teal_nav_item( - label = tags$strong("Y-axis Variable:"), - teal.transform::picks_ui(id = ns("y_var"), picks = y_var) - ), - teal::teal_nav_item( - label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), picks = color_var), - colour_picker_ui(ns("colors")) - ) - ), - ui_p_scatterplot(ns("output")) - ) -} - -srv_p_scatterplot_module <- function(id, - data, - subject_var, - x_var, - y_var, - color_var, - point_colors, - tooltip_vars = NULL) { - moduleServer(id, function(input, output, session) { - selectors <- teal.transform::picks_srv( - data = data, - picks = list(subject_var = subject_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) - ) - merged_dataname <- "anl" - merged_q <- reactive({ - req(data(), map_merged(selectors)) - obj <- data() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Scatterplot data preparation") - qenv_merge_selectors(x = obj, selectors = selectors, output_name = merged_dataname) - }) - - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - selected_color <- req(map_merged(selectors)$color_var) - merged_q()[[merged_dataname]][[selected_color$variables]] - }), - default_colors = point_colors - ) - - srv_p_scatterplot( - "output", - data = merged_q, - dataname = merged_dataname, - x_var = reactive(map_merged(selectors)$x_var$variables), - y_var = reactive(map_merged(selectors)$y_var$variables), - color_var = reactive(map_merged(selectors)$color_var$variables), - color_inputs = color_inputs, - subject_var = reactive(map_merged(selectors)$subject_var$variables), - tooltip_vars = reactive(map_merged(selectors)$tooltip_vars$variables) - ) - }) -} - -ui_p_scatterplot <- function(id) { - ns <- NS(id) - tags$div( - class = "standard-layout output-panel", - shinyjs::useShinyjs(), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ) - ) -} - -srv_p_scatterplot <- function(id, - data, - dataname, - subject_var, - x_var, - y_var, - color_var, - color_inputs, - tooltip_vars = NULL) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - obj <- req(data(), x_var(), y_var(), subject_var(), color_var()) - within( - data(), - df = str2lang(dataname), - x_var = x_var(), - y_var = y_var(), - color_var = color_var(), - subject_var = subject_var(), - colors = color_inputs(), - source = session$ns("scatterplot"), - tooltip_vars = tooltip_vars(), - expr = { - # Get label attributes for variables, fallback to column names - subject_var_label <- attr(df[[subject_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - - x_var_label <- attr(df[[x_var]], "label") - if (!length(x_var_label)) x_var_label <- x_var - - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var - - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - plot_data <- df |> - dplyr::mutate(!!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors))) |> - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::mutate( - tooltip = { - if (is.null(tooltip_vars)) { - # Default tooltip: show subject, x, y, color variables with labels - paste( - paste(subject_var_label, ":", !!as.name(subject_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Custom tooltip: show only specified columns - cur_data <- dplyr::cur_data() - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - # Fallback to default if no valid columns found - paste( - paste(subject_var_label, ":", !!as.name(subject_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Create tooltip from specified columns - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - if (cn == subject_var) { - lb <- subject_var_label - } else if (cn == x_var) { - lb <- x_var_label - } else if (cn == y_var) { - lb <- y_var_label - } else if (cn == color_var) { - lb <- color_var_label - } else { - lb <- attr(sub[[cn]], "label") - } - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) - - plotly::plot_ly( - data = plot_data, - source = source, - colors = colors, - customdata = ~customdata - ) |> - plotly::add_markers( - x = stats::as.formula(sprintf("~%s", x_var)), - y = stats::as.formula(sprintf("~%s", y_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - text = ~tooltip, - hoverinfo = "text" - ) |> - plotly::layout(dragmode = "select") |> - plotly::event_register("plotly_selected") - } - ) - }) - - output$plot <- plotly::renderPlotly({ - req(plotly_q()) - tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> - setup_trigger_tooltips(session$ns) |> - set_plot_data(session$ns("plot_data")) |> - plotly::event_register("plotly_selected") - }) - - - plotly_selected <- reactive( - plotly::event_data("plotly_selected", source = session$ns("scatterplot")) - ) - reactive({ - if (is.null(plotly_selected()) || is.null(subject_var())) { - plotly_q() - } else { - q <- plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - df <- df |> - dplyr::filter(!!as.name(subject_var_string) %in% selected_plot_data[[subject_var_string]]) - }, - df = str2lang(dataname), - subject_var_string = subject_var(), - plotly_selected_customdata = plotly_selected()$customdata - ) - attr(q, "has_brushing") <- TRUE - q - } - }) - }) -} diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R deleted file mode 100644 index 78ed35f5f..000000000 --- a/R/tm_p_spaghetti.R +++ /dev/null @@ -1,342 +0,0 @@ -#' Spaghetti Plot Module -#' -#' This module creates an interactive spaghetti plot visualization that shows individual -#' trajectories for each group over time. Each trajectory is represented by connected -#' points and lines, creating a "spaghetti-like" appearance. The plot supports customizable -#' tooltips and color coding by categorical variables. Users can select points by brushing -#' to filter the underlying data. -#' -#' @param label (`character(1)`) Label shown in the navigation item for the module. -#' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param group_var (`character(1)`) Name of the grouping variable that defines individual trajectories. -#' @param x_var (`character(1)`) Name of the variable to be used for x-axis (typically time). -#' @param y_var (`character(1)`) Name of the variable to be used for y-axis (typically a measurement). -#' @param color_var (`character(1)`) Name of the variable to be used for coloring points and lines. -#' @param point_colors (`named character`) Valid color names or hex-colors named by levels of color_var column. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing group, x, y, and color variables. -#' @param transformators (`list`) Named list of transformator functions. -#' @param show_widgets (`logical(1)`) Whether to show module widgets. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' df <- data.frame( -#' subject_id = rep(paste0("S", 1:10), each = 4), -#' time_point = rep(c(0, 30, 60, 90), 10), -#' response = rnorm(40, 15, 3) + rep(c(0, 2, 4, 6), 10), -#' treatment = rep(c("Active", "Placebo"), each = 20), -#' age_group = rep(c("Young", "Old"), 20) -#' ) -#' -#' # Add labels -#' attr(df$subject_id, "label") <- "Subject ID" -#' attr(df$time_point, "label") <- "Time Point (days)" -#' attr(df$response, "label") <- "Response Score" -#' attr(df$treatment, "label") <- "Treatment Group" -#' }) -#' -#' # Default tooltip example -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_spaghetti( -#' label = "Spaghetti Plot", -#' plot_dataname = "df", -#' group_var = "subject_id", -#' x_var = "time_point", -#' y_var = "response", -#' color_var = "treatment", -#' tooltip_vars = c("subject_id", "treatment") -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_spaghetti <- function(label = "Scatter Plot", - group_var, - x_var, - y_var, - color_var, - point_colors = character(0), - tooltip_vars = NULL, - transformators = list()) { - checkmate::assert_string(label) - checkmate::assert_class(group_var, "picks") - checkmate::assert_class(x_var, "picks") - checkmate::assert_class(y_var, "picks") - checkmate::assert_class(color_var, "picks") - checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) - - args <- as.list(environment()) - module( - label = label, - ui = ui_p_spaghetti_module, - server = srv_p_spaghetti_module, - ui_args = args[names(args) %in% names(formals(ui_p_spaghetti_module))], - server_args = args[names(args) %in% names(formals(srv_p_spaghetti_module))], - transformators = transformators, - datanames = { - datanames <- datanames( - list( - group_var = group_var, x_var = x_var, y_var = y_var, - color_var = color_var, tooltip_vars = tooltip_vars - ) - ) - if (length(datanames)) datanames else "all" - } - ) -} - -ui_p_spaghetti_module <- function(id, group_var, x_var, y_var, color_var, tooltip_vars) { - ns <- NS(id) - bslib::page_sidebar( - sidebar = div( - class = "standard-layout encoding-panel", - teal::teal_nav_item( - label = tags$strong("Group Variable:"), - teal.transform::picks_ui(id = ns("group_var"), picks = group_var) - ), - teal::teal_nav_item( - label = tags$strong("X-axis Variable:"), - teal.transform::picks_ui(id = ns("x_var"), picks = x_var) - ), - teal::teal_nav_item( - label = tags$strong("Y-axis Variable:"), - teal.transform::picks_ui(id = ns("y_var"), picks = y_var) - ), - teal::teal_nav_item( - label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), picks = color_var), - colour_picker_ui(ns("colors")) - ) - ), - ui_p_spaghetti(ns("output")) - ) -} - -srv_p_spaghetti_module <- function(id, - data, - group_var, - x_var, - y_var, - color_var, - point_colors, - tooltip_vars = NULL) { - moduleServer(id, function(input, output, session) { - selectors <- teal.transform::picks_srv( - data = data, - picks = list(group_var = group_var, x_var = x_var, y_var = y_var, color_var = color_var, tooltip_vars = tooltip_vars) - ) - merged_dataname <- "anl" - merged_q <- reactive({ - req(data(), map_merged(selectors)) - obj <- data() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spaghetti plot data preparation") - qenv_merge_selectors(x = obj, selectors = selectors, output_name = merged_dataname) - }) - - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - selected_color <- req(map_merged(selectors)$color_var) - merged_q()[[merged_dataname]][[selected_color$variables]] - }), - default_colors = point_colors - ) - - srv_p_spaghetti( - "output", - data = merged_q, - dataname = merged_dataname, - x_var = reactive(map_merged(selectors)$x_var$variables), - y_var = reactive(map_merged(selectors)$y_var$variables), - color_var = reactive(map_merged(selectors)$color_var$variables), - color_inputs = color_inputs, - group_var = reactive(map_merged(selectors)$group_var$variables), - tooltip_vars = reactive(map_merged(selectors)$tooltip_vars$variables) - ) - }) -} - -ui_p_spaghetti <- function(id) { - ns <- NS(id) - tags$div( - class = "standard-layout output-panel", - shinyjs::useShinyjs(), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ) - ) -} - -srv_p_spaghetti <- function(id, - data, - dataname, - group_var, - x_var, - y_var, - color_var, - color_inputs, - tooltip_vars = NULL) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - req(data(), color_inputs(), group_var(), x_var(), y_var(), color_var()) - within( - data(), - df = str2lang(dataname), - group_var = group_var(), - x_var = x_var(), - y_var = y_var(), - color_var = color_var(), - colors = color_inputs(), - source = session$ns("spaghetti"), - tooltip_vars = tooltip_vars(), - expr = { - # Get label attributes for variables, fallback to column names - group_var_label <- attr(df[[group_var]], "label") - if (!length(group_var_label)) group_var_label <- group_var - - x_var_label <- attr(df[[x_var]], "label") - if (!length(x_var_label)) x_var_label <- x_var - - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var - - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - plot_data <- df |> - dplyr::select(!!as.name(group_var), !!as.name(x_var), !!as.name(y_var), !!as.name(color_var)) |> - dplyr::mutate(!!as.name(color_var) := factor(!!as.name(color_var), levels = names(colors))) %>% - dplyr::mutate(customdata = dplyr::row_number()) |> - dplyr::mutate( - tooltip = { - if (is.null(tooltip_vars)) { - # Default tooltip: show group, x, y, color variables with labels - paste( - paste(group_var_label, ":", !!as.name(group_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Custom tooltip: show only specified columns - cur_data <- dplyr::cur_data() - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - # Fallback to default if no valid columns found - paste( - paste(group_var_label, ":", !!as.name(group_var)), - paste(x_var_label, ":", !!as.name(x_var)), - paste(y_var_label, ":", !!as.name(y_var)), - paste(color_var_label, ":", !!as.name(color_var)), - sep = "
" - ) - } else { - # Create tooltip from specified columns - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - if (cn == group_var) { - lb <- group_var_label - } else if (cn == x_var) { - lb <- x_var_label - } else if (cn == y_var) { - lb <- y_var_label - } else if (cn == color_var) { - lb <- color_var_label - } else { - lb <- attr(sub[[cn]], "label") - } - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) - - segments_df <- plot_data %>% - dplyr::arrange(!!as.name(group_var), !!as.name(x_var)) %>% - dplyr::group_by(!!as.name(group_var)) %>% - dplyr::mutate( - x = !!as.name(x_var), - y = !!as.name(y_var), - xend = dplyr::lead(!!as.name(x_var)), - yend = dplyr::lead(!!as.name(y_var)), - color_var_seg = dplyr::lead(!!as.name(color_var)) - ) %>% - dplyr::filter(!is.na(xend)) - - plotly::plot_ly( - data = segments_df, - customdata = ~customdata, - source = source - ) %>% - plotly::add_segments( - x = ~x, y = ~y, - xend = ~xend, yend = ~yend, - color = ~color_var_seg, - colors = colors, - showlegend = TRUE - ) %>% - plotly::add_markers( - data = plot_data, - x = stats::as.formula(sprintf("~%s", x_var)), - y = stats::as.formula(sprintf("~%s", y_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - text = ~tooltip, - hoverinfo = "text" - ) |> - plotly::layout(dragmode = "select") - } - ) - }) - - - output$plot <- plotly::renderPlotly({ - req(plotly_q()) - tail(teal.code::get_outputs(plotly_q()), 1)[[1]] |> - setup_trigger_tooltips(session$ns) |> - set_plot_data(session$ns("plot_data")) |> - plotly::event_register("plotly_selected") - }) - - plotly_selected <- reactive( - plotly::event_data("plotly_selected", source = session$ns("spaghetti")) - ) - reactive({ - req(plotly_selected(), plotly_q(), group_var()) - if (is.null(plotly_selected()) || is.null(group_var())) { - plotly_q() - } else { - q <- plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - df <- df |> - dplyr::filter(!!as.name(group_var_string) %in% selected_plot_data[[group_var_string]]) - }, - df = str2lang(dataname), - group_var_string = group_var(), - plotly_selected_customdata = plotly_selected()$customdata - ) - attr(q, "has_brushing") <- TRUE - q - } - }) - }) -} diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R deleted file mode 100644 index a4ae14677..000000000 --- a/R/tm_p_spiderplot.R +++ /dev/null @@ -1,423 +0,0 @@ -#' `teal` module: Spider Plot -#' -#' Module visualizes value development in time grouped by subjects. -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @param time_var (`character(1)` or `variables`) name of the `numeric` column -#' in `plot_dataname` to be used as x-axis. -#' @param value_var (`character(1)` or `variables`) name of the `numeric` column -#' in `plot_dataname` to be used as y-axis. -#' @param subject_var (`character(1)` or `variables`) name of the `factor` or `character` column -#' in `plot_dataname` to be used as grouping variable for displayed lines/points. -#' @param color_var (`character(1)` or `variables`) name of the `factor` or `character` column in `plot_dataname` -#' to be used to differentiate colors and symbols. -#' @param size_var (`character(1)` or `variables` or `NULL`) If provided, this numeric column from the `plot_dataname` -#' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named -#' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var`column. -#' -#' @examples -#' library(teal.transform) -#' data <- teal_data() |> -#' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") -#' ) -#' -#' swimlane_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' time_var = sample(1:100, 10, replace = TRUE), -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) -#' ) -#' -#' spiderplot_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' time_var = 1:10, -#' filter_event_var = "response", -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), -#' value_var = sample(-50:100, 10, replace = TRUE) -#' ) -#' -#' waterfall_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' value_var = sample(-20:90, 10, replace = TRUE), -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) -#' ) -#' }) -#' join_keys(data) <- join_keys( -#' join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) -#' ) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_spiderplot( -#' plot_dataname = "spiderplot_ds", -#' table_datanames = "subjects", -#' time_var = picks(datasets("spiderplot_ds"), variables("time_var")), -#' value_var = picks(datasets("spiderplot_ds"), variables("value_var")), -#' subject_var = picks(datasets("spiderplot_ds"), variables("subject_var")), -#' color_var = picks(datasets("spiderplot_ds"), variables("color_var")), -#' transformators = list( -#' teal_transform_filter( -#' picks( -#' datasets("spiderplot_ds"), variables("filter_event_var"), values() -#' ) -#' ) -#' ), -#' point_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" -#' ), -#' point_symbols = c( -#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" -#' ), -#' tooltip_vars = c("subject_var") -#' ) -#' ) -#' ) - -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_spiderplot <- function(label = "Spiderplot", - time_var, - value_var, - subject_var, - color_var, - size_var = NULL, - tooltip_vars = NULL, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(600, 400, 1200), - transformators = list(), - decorators = list()) { - # todo: filter_event_var shouldn't in arguments as it is not a dimension of the plot - # title based on arbitrary filter is not an accepted solution. - # additional filters should be passed to trasformers - checkmate::assert_string(label) - checkmate::assert_class(time_var, "picks") - checkmate::assert_class(subject_var, "picks") - checkmate::assert_class(color_var, "picks") - checkmate::assert_class(size_var, "picks", null.ok = TRUE) - checkmate::assert_class(tooltip_vars, "picks", null.ok = TRUE) - - args <- as.list(environment()) - module( - label = label, - ui = ui_p_spiderplot, - server = srv_p_spiderplot, - ui_args = args[names(args) %in% names(formals(ui_p_spiderplot))], - server_args = args[names(args) %in% names(formals(srv_p_spiderplot))], - transformators = transformators, - datanames = { - datanames <- datanames( - list( - time_var = time_var, value_var = value_var, subject_var = subject_var, - color_var = color_var, size_var = size_var - ) - ) - if (length(datanames)) datanames else "all" - } - ) -} - -ui_p_spiderplot <- function(id, - time_var, - value_var, - subject_var, - color_var, - size_var, - tooltip_vars, - plot_height, - decorators) { - ns <- NS(id) - bslib::page_sidebar( - sidebar = div( - class = "standard-layout encoding-panel", - teal::teal_nav_item( - label = tags$strong("Time variable (x-axis):"), - teal.transform::picks_ui(id = ns("time_var"), picks = time_var) - ), - teal::teal_nav_item( - label = tags$strong("Value variable (y-axis):"), - teal.transform::picks_ui(id = ns("value_var"), picks = value_var) - ), - teal::teal_nav_item( - label = tags$strong("Subject variable:"), - teal.transform::picks_ui(id = ns("subject_var"), picks = subject_var) - ), - teal::teal_nav_item( - label = tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_var"), picks = color_var), - colour_picker_ui(ns("colors")) - ), - if (!is.null(tooltip_vars)) { # todo: don't show at all - teal::teal_nav_item( - label = tags$strong("Tooltip variables:"), - teal.transform::picks_ui(id = ns("tooltip_vars"), picks = tooltip_vars) - ) - }, - if (!is.null(size_var)) { - teal::teal_nav_item( - label = tags$strong("Size by:"), - teal.transform::picks_ui(id = ns("size_var"), picks = size_var) - ) - }, - ui_decorate_teal_data(ns("decorator"), decorators = decorators), - sliderInput(ns("plot_height"), "Plot Height (px)", plot_height[2], plot_height[3], plot_height[1]) - ), - tags$div( - class = "standard-layout output-panel", - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ), - ui_t_reactables(ns("subtables")) - ) - ) -} - -srv_p_spiderplot <- function(id, - data, - time_var, - value_var, - subject_var, - color_var, - size_var = NULL, - tooltip_vars = NULL, - point_colors, - point_symbols, - plot_height = 600, - decorators = list(), - filter_panel_api) { - moduleServer(id, function(input, output, session) { - logger::log_trace("srv_p_spiderplot initializing") - selectors <- teal.transform::picks_srv( - data = data, - picks = list( - time_var = time_var, value_var = value_var, subject_var = subject_var, - color_var = color_var, size_var = size_var, tooltip_vars = tooltip_vars - ) - ) - - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - selected_color <- req(map_merged(selectors)$color_var) - data()[[selected_color$datasets]][[selected_color$variables]] - }), - default_colors = point_colors - ) - - merged_q <- reactive({ - req(data(), map_merged(selectors)) - obj <- data() - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spiderplot data preparation") - qenv_merge_selectors(x = obj, selectors = selectors, output_name = "anl") - }) - - plot_data_q <- reactive({ - obj <- req(merged_q()) - within(obj, - { - anl <- anl %>% - dplyr::mutate(customdata = dplyr::row_number()) %>% - dplyr::arrange(subject_var_lang, time_var_lang) %>% - dplyr::group_by(subject_var_lang) - }, - subject_var_lang = str2lang(map_merged(selectors)$subject_var$variables), - time_var_lang = str2lang(map_merged(selectors)$time_var$variables) - ) - }) - - output_q <- reactive({ - obj <- req(plot_data_q()) - logger::log_debug("Plotting spiderplot") - teal.reporter::teal_card(obj) <- c(teal.reporter::teal_card(obj), "## Spiderplot Visualization") - adjusted_symbols <- .shape_palette_discrete( - levels = unique(obj$anl[[map_merged(selectors)$color_var$variables]]), - symbol = point_symbols - ) - - within( - obj, - dataname = str2lang("anl"), - time_var_lang = str2lang(map_merged(selectors)$time_var$variables), - value_var_lang = str2lang(map_merged(selectors)$value_var$variables), - subject_var_lang = str2lang(map_merged(selectors)$subject_var$variables), - color_var_lang = str2lang(map_merged(selectors)$color_var$variables), - time_var = map_merged(selectors)$time_var$variables, - value_var = map_merged(selectors)$value_var$variables, - subject_var = map_merged(selectors)$subject_var$variables, - color_var = map_merged(selectors)$color_var$variables, - colors = color_inputs(), - symbols = adjusted_symbols, - size_var = if (!is.null(size_var)) map_merged(selectors)$size_var$variables, - tooltip_vars = if (!is.null(tooltip_vars)) map_merged(selectors)$tooltip_vars$variables, - height = input$plot_height, - point_size = 10, - source = session$ns("spiderplot"), - expr = { - subject_var_label <- attr(anl[[subject_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - - time_var_label <- attr(anl[[time_var]], "label") - if (!length(time_var_label)) time_var_label <- time_var - - value_var_label <- attr(anl[[value_var]], "label") - if (!length(value_var_label)) value_var_label <- value_var - color_var_label <- attr(plot_data[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - if (is.null(size_var)) { - size <- point_size - } else { - size <- stats::as.formula(sprintf("~%s", size_var)) - } - - plot <- anl %>% - dplyr::ungroup() %>% - dplyr::mutate( - x = dplyr::lag(time_var_lang, default = 0), - y = dplyr:::lag(value_var_lang, default = 0), - tooltip = { - if (is.null(tooltip_vars)) { - # Default tooltip: show subject, x, y, color variables with labels - sprintf( - "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, subject_var_lang, - time_var_label, time_var_lang, - value_var_label, value_var_lang * 100 - ) - } else { - # Custom tooltip: show only specified columns - cur_data <- dplyr::cur_data() - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - # Fallback to default if no valid columns found - sprintf( - "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var), - time_var_label, !!as.name(time_var), - value_var_label, !!as.name(value_var) * 100 - ) - } else { - # Create tooltip from specified columns - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - if (cn == subject_var) { - lb <- subject_var_label - } else if (cn == time_var) { - lb <- time_var_label - } else if (cn == value_var) { - lb <- value_var_label - } else if (cn == color_var) { - lb <- color_var_label - } else { - lb <- attr(sub[[cn]], "label") - } - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) %>% - dplyr::ungroup() %>% - plotly::plot_ly( - source = source, - height = height, - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - symbols = symbols - ) %>% - plotly::add_segments( - x = ~x, - y = ~y, - xend = stats::as.formula(sprintf("~%s", time_var)), - yend = stats::as.formula(sprintf("~%s", value_var)), - customdata = NULL - ) %>% - plotly::add_markers( - x = stats::as.formula(sprintf("~%s", time_var)), - y = stats::as.formula(sprintf("~%s", value_var)), - symbol = stats::as.formula(sprintf("~%s", color_var)), - size = size, - # text = ~tooltip, - hoverinfo = "text", - customdata = ~customdata - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = value_var_label), - title = "Spiderplot", - dragmode = "select" - ) %>% - plotly::config(displaylogo = FALSE) - } - ) - }) - - decorated_output_plot_q <- srv_decorate_teal_data( - id = "decorator", - data = output_q, - decorators = decorators, - expr = quote(plot) - ) - - output$plot <- plotly::renderPlotly({ - req(decorated_output_plot_q()) - logger::log_debug("srv_p_spiderplot rendering plot") - plotly::event_register( - { - rev(teal.code::get_outputs(decorated_output_plot_q()))[[1]] |> - set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) - }, - "plotly_selected" - ) - }) - - plotly_data <- reactive({ - data.frame( - x = unlist(input$plot_data$x), - y = unlist(input$plot_data$y), - customdata = unlist(input$plot_data$customdata), - curve = unlist(input$plot_data$curveNumber), - index = unlist(input$plot_data$pointNumber) - ) - }) - - plotly_selected <- reactive( - plotly::event_data("plotly_selected", source = session$ns("spiderplot")) - ) - - - reactive({ - req(decorated_output_plot_q()) - if (length(plotly_selected()) && nrow(plotly_selected())) { - within( - decorated_output_plot_q(), - anl <- dplyr::filter(anl, customdata %in% selected), - selected = unique(plotly_selected()$customdata) - ) - } else { - decorated_output_plot_q() - } - }) - }) -} diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R deleted file mode 100644 index 1d1c1fed0..000000000 --- a/R/tm_p_swimlane.R +++ /dev/null @@ -1,370 +0,0 @@ -#' `teal` module: Swimlane plot -#' -#' Module visualizes subjects' events in time. -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @param plot_dataname (`character(1)` or `choices_selected`) name of the dataset which visualization is builded on. -#' @param time_var (`character(1)` or `choices_selected`) name of the `numeric` column -#' in `plot_dataname` to be used as x-axis. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to be used as y-axis. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to name and color subject events in time. -#' @param group_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to categorize type of event. -#' (legend is sorted according to this variable, and used in toolip to display type of the event) -#' todo: this can be fixed by ordering factor levels -#' @param sort_var (`character(1)` or `choices_selected`) name(s) of the column in `plot_dataname` which -#' value determines order of the subjects displayed on the y-axis. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created. -#' @param point_size (`numeric(1)` or `named numeric`) Default point size of the points in the plot. -#' If `point_size` is a named numeric vector, it should be named by levels of `color_var` column. -#' @param point_colors (`named character`) valid color names (see [colors()]) or hex-colors named -#' by levels of `color_var` column. -#' @param point_symbols (`named character`) valid plotly symbol name named by levels of `color_var` column. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") -#' ) -#' -#' swimlane_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' time_var = sample(1:100, 10, replace = TRUE), -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) -#' ) -#' }) -#' join_keys(data) <- join_keys( -#' join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) -#' ) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_swimlane( -#' plot_dataname = "swimlane_ds", -#' time_var = "time_var", -#' subject_var = "subject_var", -#' color_var = "color_var", -#' group_var = "color_var", -#' sort_var = "time_var", -#' plot_height = c(700, 400, 1200), -#' tooltip_vars = c("subject_var", "color_var"), -#' point_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" -#' ), -#' point_symbols = c( -#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" -#' ) -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_swimlane <- function(label = "Swimlane", - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var = time_var, - tooltip_vars = NULL, - point_size = 10, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(700, 400, 1200), - show_widgets = TRUE) { - checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) - checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") - if (is.character(time_var)) { - time_var <- choices_selected(choices = time_var, selected = time_var) - } - if (is.character(subject_var)) { - subject_var <- choices_selected(choices = subject_var, selected = subject_var) - } - if (is.character(color_var)) { - color_var <- choices_selected(choices = color_var, selected = color_var) - } - if (is.character(group_var)) { - group_var <- choices_selected(choices = group_var, selected = group_var) - } - if (is.character(sort_var)) { - sort_var <- choices_selected(choices = sort_var, selected = sort_var) - } - module( - label = label, - ui = ui_p_swimlane, - server = srv_p_swimlane, - datanames = c(plot_dataname), - ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - time_var = time_var, - subject_var = subject_var, - color_var = color_var, - group_var = group_var, - sort_var = sort_var, - point_size = point_size, - point_colors = point_colors, - point_symbols = point_symbols, - tooltip_vars = tooltip_vars, - show_widgets = show_widgets - ) - ) -} - -ui_p_swimlane <- function(id, height) { - ns <- NS(id) - bslib::page_fluid( - tags$div( - shinyjs::useShinyjs(), - tags$div( - id = ns("top_widgets"), - style = "display: flex;", - selectInput(ns("subject_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("group_var"), label = "Group by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), - colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) - ), - bslib::card( - full_screen = TRUE, - tags$div( - trigger_tooltips_deps(), - plotly::plotlyOutput(ns("plot"), height = "100%"), - ) - ), - tags$div( - id = ns("bottom_widgets"), - selectInput(ns("time_var"), label = "Time variable:", choices = NULL, selected = NULL, multiple = FALSE) - ) - ) - ) -} -srv_p_swimlane <- function(id, - data, - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var, - point_size = 10, - point_colors, - point_symbols, - tooltip_vars = NULL, - filter_panel_api, - show_widgets) { - moduleServer(id, function(input, output, session) { - .update_cs_input(inputId = "time_var", data = reactive(data()[[dataname]]), cs = time_var) - .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) - .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) - .update_cs_input(inputId = "group_var", data = reactive(data()[[dataname]]), cs = group_var) - .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) - - if (!show_widgets) { - shinyjs::hide("top_widgets") - shinyjs::hide("bottom_widgets") - } - - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - req(input$color_var) - data()[[plot_dataname]][[input$color_var]] - }), - default_colors = point_colors - ) - - plotly_q <- reactive({ - req(data(), input$time_var, input$subject_var, input$color_var, input$group_var, input$sort_var, color_inputs()) - adjusted_symbols <- .shape_palette_discrete( - levels = unique(data()[[plot_dataname]][[input$color_var]]), - symbol = point_symbols - ) - within( - data(), - dataname = str2lang(plot_dataname), - time_var = input$time_var, - subject_var = input$subject_var, - color_var = input$color_var, - group_var = input$group_var, - sort_var = input$sort_var, - point_size = point_size, - colors = color_inputs(), - symbols = adjusted_symbols, - height = input$plot_height, - tooltip_vars = tooltip_vars, - source = session$ns("swimlane"), - expr = { - subject_var_label <- attr(dataname[[subject_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - time_var_label <- attr(dataname[[time_var]], "label") - if (!length(time_var_label)) time_var_label <- time_var - plot_data <- dataname |> - dplyr::mutate(customdata = dplyr::row_number()) - - # forcats::fct_reorder doesn't seem to work here - subject_levels <- plot_data %>% - dplyr::group_by(!!as.name(subject_var)) %>% - dplyr::summarize(v = max(!!as.name(sort_var))) %>% - dplyr::ungroup() %>% - dplyr::arrange(v) %>% - dplyr::pull(!!as.name(subject_var)) - plot_data[[subject_var]] <- factor(plot_data[[subject_var]], levels = subject_levels) - - min_size <- min(point_size, na.rm = TRUE) - - if (length(point_size) > 1) { - plot_data <- plot_data %>% - dplyr::mutate( - size_var = ifelse( - as.character(color_var) %in% names(point_size), - point_size[as.character(color_var)], - min_size - ) - ) - } else { - plot_data <- plot_data %>% - dplyr::mutate(size_var = point_size) - } - - p <- plot_data %>% - dplyr::mutate( - !!as.name(color_var) := { - # Store the original label - original_label <- attr(.data[[color_var]], "label") - # Create the factor - new_factor <- factor(.data[[color_var]], levels = names(colors)) - # Restore the label - attr(new_factor, "label") <- original_label - new_factor - } - ) %>% - dplyr::group_by(!!as.name(subject_var), !!as.name(time_var)) %>% - dplyr::mutate( - tooltip = { - default_tip <- paste( - unique( - c( - paste(subject_var_label, !!as.name(subject_var)), - paste(time_var_label, !!as.name(time_var)), - sprintf( - "%s: %s", - tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var))), - !!as.name(color_var) - ) - ) - ), - collapse = "
" - ) - if (is.null(tooltip_vars)) { - default_tip - } else { - cur_data <- dplyr::cur_data() - grouping_vars <- list() - grouping_vars[[subject_var]] <- dplyr::cur_group()[[subject_var]] - grouping_vars[[time_var]] <- dplyr::cur_group()[[time_var]] - cur_data <- c(cur_data, grouping_vars) - - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - default_tip - } else { - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - if (cn == subject_var) { - lb <- subject_var_label - } else if (cn == time_var) { - lb <- time_var_label - } else { - lb <- attr(sub[[cn]], "label") - } - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) %>% - dplyr::ungroup() %>% - plotly::plot_ly( - source = source, - colors = colors, - symbols = symbols, - height = height, - customdata = ~customdata - ) %>% - plotly::add_markers( - x = stats::as.formula(sprintf("~%s", time_var)), - y = stats::as.formula(sprintf("~%s", subject_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - symbol = stats::as.formula(sprintf("~%s", color_var)), - size = ~size_var, - text = ~tooltip, - hoverinfo = "text" - ) %>% - plotly::add_segments( - x = ~0, - xend = ~study_day, - y = stats::as.formula(sprintf("~%s", subject_var)), - yend = stats::as.formula(sprintf("~%s", subject_var)), - data = plot_data |> - dplyr::group_by(!!as.name(subject_var), !!as.name(group_var)) |> - dplyr::summarise(study_day = max(!!as.name(time_var))), - line = list(width = 2, color = "grey"), - showlegend = FALSE, - customdata = NULL - ) %>% - plotly::layout( - xaxis = list(title = time_var_label), - yaxis = list(title = subject_var_label) - ) %>% - plotly::layout(dragmode = "select", title = title) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::layout(title = title) - } - ) - }) - - output$plot <- plotly::renderPlotly({ - plotly_q()$p |> - set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) |> - plotly::event_register("plotly_selected") - }) - - plotly_selected <- reactive({ - plotly::event_data("plotly_selected", source = session$ns("swimlane")) - }) - - reactive({ - req(plotly_selected()) - plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - dataname <- dataname |> - dplyr::filter(!!sym(subject_var) %in% selected_plot_data[[subject_var]]) - }, - dataname = str2lang(plot_dataname), - subject_var = input$subject_var, - plotly_selected_customdata = plotly_selected()$customdata - ) - }) - }) -} diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R deleted file mode 100644 index b5a37bf7e..000000000 --- a/R/tm_p_waterfall.R +++ /dev/null @@ -1,287 +0,0 @@ -#' `teal` module: Waterfall plot -#' -#' Module visualizes subjects sorted decreasingly by y-values. -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @param plot_dataname (`character(1)`) name of the dataset which visualization is builded on. -#' @param subject_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column -#' in `plot_dataname` to be used as x-axis. -#' @param value_var (`character(1)` or `choices_selected`) name of the `numeric` column -#' in `plot_dataname` to be used as y-axis. -#' @param color_var (`character(1)` or `choices_selected`) name of the `factor` or `character` column in `plot_dataname` -#' to be used to differentiate bar colors. -#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created. -#' @param bar_colors (`named character`) valid color names (see [colors()]) or hex-colors named -#' by levels of `color_var` column. -#' @param value_arbitrary_hlines (`numeric`) values in the same scale as `value_var` to horizontal -#' lines on the plot. -#' @param plot_title (`character`) Title of the plot. -#' -#' @examples -#' data <- teal_data() |> -#' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") -#' ) -#' -#' waterfall_ds <- data.frame( -#' subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), -#' value_var = sample(-20:90, 10, replace = TRUE), -#' color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) -#' ) -#' }) -#' join_keys(data) <- join_keys( -#' join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) -#' ) -#' -#' app <- init( -#' data = data, -#' modules = modules( -#' tm_p_waterfall( -#' plot_dataname = "waterfall_ds", -#' subject_var = "subject_var", -#' value_var = "value_var", -#' sort_var = "value_var", -#' color_var = "color_var", -#' tooltip_vars = c("value_var", "subjects"), -#' value_arbitrary_hlines = c(20, -30), -#' bar_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" -#' ) -#' ) -#' ) -#' ) -#' -#' if (interactive()) { -#' shinyApp(app$ui, app$server) -#' } -#' -#' @export -tm_p_waterfall <- function(label = "Waterfall", - plot_dataname, - subject_var, - value_var, - sort_var = NULL, - color_var = NULL, - tooltip_vars = NULL, - bar_colors = character(0), - value_arbitrary_hlines = c(0.2, -0.3), - plot_title = "Waterfall plot", - plot_height = c(600, 400, 1200)) { - if (is.character(subject_var)) { - subject_var <- choices_selected(choices = subject_var, selected = subject_var) - } - if (is.character(value_var)) { - value_var <- choices_selected(choices = value_var, selected = value_var) - } - if (is.character(sort_var)) { - sort_var <- choices_selected(choices = sort_var, selected = sort_var) - } - if (is.character(color_var)) { - color_var <- choices_selected(choices = color_var, selected = color_var) - } - - module( - label = label, - ui = ui_p_waterfall, - server = srv_p_waterfall, - datanames = plot_dataname, - ui_args = list(height = plot_height), - server_args = list( - plot_dataname = plot_dataname, - subject_var = subject_var, - value_var = value_var, - sort_var = sort_var, - color_var = color_var, - bar_colors = bar_colors, - value_arbitrary_hlines = value_arbitrary_hlines, - plot_title = plot_title, - tooltip_vars = tooltip_vars - ) - ) -} - -ui_p_waterfall <- function(id, height) { - ns <- NS(id) - - bslib::page_fluid( - div( - style = "display: flex;", - selectInput( - ns("subject_var"), - label = "Subject variable (x-axis):", - choices = NULL, selected = NULL, multiple = FALSE - ), - selectInput( - ns("value_var"), - label = "Value variable (y-axis):", - choices = NULL, selected = NULL, multiple = FALSE - ), - selectInput(ns("sort_var"), label = "Sort by:", choices = NULL, selected = NULL, multiple = FALSE), - selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), - colour_picker_ui(ns("colors")), - sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) - ), - tags$div( - bslib::card( - full_screen = TRUE, - tags$div( - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ) - ) - ) -} -srv_p_waterfall <- function(id, - data, - plot_dataname, - subject_var, - value_var, - sort_var, - color_var, - bar_colors, - value_arbitrary_hlines, - plot_title, - plot_height = c(600, 400, 1200), - tooltip_vars, - filter_panel_api) { - moduleServer(id, function(input, output, session) { - .update_cs_input(inputId = "subject_var", data = reactive(data()[[dataname]]), cs = subject_var) - .update_cs_input(inputId = "value_var", data = reactive(data()[[dataname]]), cs = value_var) - .update_cs_input(inputId = "sort_var", data = reactive(data()[[dataname]]), cs = sort_var) - .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) - - color_inputs <- colour_picker_srv( - "colors", - x = reactive({ - req(data(), input$color_var) - data()[[plot_dataname]][[input$color_var]] - }), - default_colors = bar_colors - ) - - plotly_q <- reactive({ - req(data(), input$subject_var, input$value_var, input$sort_var, input$color_var, color_inputs()) - - within( - data(), - dataname = str2lang(plot_dataname), - subject_var = input$subject_var, - value_var = input$value_var, - sort_var = input$sort_var, - color_var = input$color_var, - colors = color_inputs(), - value_arbitrary_hlines = value_arbitrary_hlines, - height = input$plot_height, - title = sprintf("Waterfall plot"), - tooltip_vars = tooltip_vars, - source = session$ns("waterfall"), - expr = { - subject_var_label <- attr(dataname[[subject_var]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var - value_var_label <- attr(dataname[[value_var]], "label") - if (!length(value_var_label)) value_var_label <- value_var - color_var_label <- attr(dataname[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var - - - plot_data <- dplyr::mutate( - if (identical(sort_var, value_var) || is.null(sort_var)) { - dplyr::arrange(dataname, desc(!!as.name(value_var))) - } else { - dplyr::arrange(dataname, !!as.name(sort_var), desc(!!as.name(value_var))) - }, - !!as.name(subject_var) := factor(!!as.name(subject_var), levels = unique(!!as.name(subject_var))), - tooltip = { - default_tip <- sprintf( - "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var), - value_var_label, !!as.name(value_var), - color_var_label, !!as.name(color_var) - ) - if (is.null(tooltip_vars)) { - default_tip - } else { - cur_data <- dplyr::pick(dplyr::everything()) - cols <- intersect(tooltip_vars, names(cur_data)) - if (!length(cols)) { - default_tip - } else { - sub <- cur_data[cols] - labels <- vapply(cols, function(cn) { - lb <- attr(sub[[cn]], "label") - if (length(lb) && !is.null(lb) && !is.na(lb)) as.character(lb) else cn - }, character(1)) - values <- lapply(sub, as.character) - parts <- Map(function(v, l) paste0(l, ": ", v), values, labels) - do.call(paste, c(parts, sep = "
")) - } - } - } - ) %>% - dplyr::filter(!duplicated(!!as.name(subject_var))) %>% - dplyr::mutate(customdata = dplyr::row_number()) - p <- plotly::plot_ly( - data = plot_data, - source = source, - customdata = ~customdata, - height = height - ) %>% - plotly::add_bars( - x = stats::as.formula(sprintf("~%s", subject_var)), - y = stats::as.formula(sprintf("~%s", value_var)), - color = stats::as.formula(sprintf("~%s", color_var)), - colors = colors, - text = ~tooltip, - hoverinfo = "text" - ) %>% - plotly::layout( - shapes = lapply(value_arbitrary_hlines, function(y) { - list( - type = "line", - x0 = 0, - x1 = 1, - xref = "paper", - y0 = y, - y1 = y, - line = list(color = "black", dash = "dot") - ) - }), - xaxis = list(title = subject_var_label, tickangle = -45), - yaxis = list(title = value_var_label), - legend = list(title = list(text = "Color by:")), - barmode = "relative" - ) %>% - plotly::layout(dragmode = "select") %>% - plotly::config(displaylogo = FALSE) %>% - plotly::layout(title = title) - }, - height = input$plot_height - ) - }) - - output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) - - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = session$ns("waterfall"))) - - reactive({ - req(plotly_selected()) - plotly_q() |> - within( - { - selected_plot_data <- plot_data |> - dplyr::filter(customdata %in% plotly_selected_customdata) - dataname <- dataname |> - dplyr::filter(!!sym(subject_var) %in% selected_plot_data[[subject_var]]) - }, - dataname = str2lang(plot_dataname), - subject_var = input$subject_var, - plotly_selected_customdata = plotly_selected()$customdata - ) - }) - }) -} diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index d062c4da1..ae64b892b 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -7,7 +7,7 @@ #' @inheritParams shared_params #' @param x (`picks` or `list` of `picks`) #' Object with all available choices with pre-selected option for variable X - row values. -#' In case of `picks` use `variables(..., ordered = TRUE)` if table elements should be +#' In case of `picks` use `teal.transform::variables(..., ordered = TRUE)` if table elements should be #' rendered according to selection order. #' @param y (`picks` or `list` of multiple `picks`) #' Object with all available choices with pre-selected option for variable Y - column values. @@ -82,26 +82,26 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = picks( +#' x = teal.transform::picks( #' datasets("mtcars"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = c("cyl", "gear"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("mtcars"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ) #' ) #' ) @@ -127,9 +127,9 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = picks( +#' x = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) #' return(names(data)[idx]) @@ -139,11 +139,11 @@ #' ordered = TRUE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ), -#' y = picks( +#' y = teal.transform::picks( #' datasets("ADSL"), -#' variables( +#' teal.transform::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- vapply(data, is.factor, logical(1)) #' return(names(data)[idx]) @@ -152,7 +152,7 @@ #' multiple = FALSE, #' fixed = FALSE #' ), -#' values() +#' teal.transform::values() #' ) #' ) #' ) @@ -164,7 +164,14 @@ #' @export #' tm_t_crosstable <- function(label = "Cross Table", - x, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L, multiple = TRUE, ordered = TRUE + ), + teal.transform::values() + ), y, show_percentage = TRUE, show_total = TRUE, diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index 25dd92500..c5eb85423 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -1,7 +1,21 @@ #' @export tm_t_crosstable.picks <- function(label = "Cross Table", - x, - y, + x = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 1L, multiple = TRUE, ordered = TRUE + ), + teal.transform::values() + ), + y = teal.transform::picks( + teal.transform::datasets(), + teal.transform::variables( + choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + selected = 2L, multiple = TRUE, ordered = TRUE + ), + teal.transform::values() + ), show_percentage = TRUE, show_total = TRUE, remove_zero_columns = FALSE, @@ -18,7 +32,7 @@ tm_t_crosstable.picks <- function(label = "Cross Table", checkmate::assert_class(y, "picks") if (isTRUE(attr(y$variables, "multiple"))) { - warning("`y` accepts only a single variable selection. Forcing `variables(multiple) to FALSE`") + warning("`y` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") attr(y$variables, "multiple") <- FALSE } @@ -40,10 +54,7 @@ tm_t_crosstable.picks <- function(label = "Cross Table", ui_args = args[names(args) %in% names(formals(ui_t_crosstable.picks))], server_args = args[names(args) %in% names(formals(srv_t_crosstable.picks))], transformators = transformators, - datanames = { - datanames <- datanames(list(x, y)) - if (length(datanames)) datanames else "all" - } + datanames = .picks_datanames(list(x, y)) ) attr(ans, "teal_bookmarkable") <- TRUE @@ -68,12 +79,12 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ ), encoding = tags$div( tags$label("Encodings", class = "text-primary"), - teal::teal_nav_item( - label = tags$strong("Row values"), + tags$div( + tags$strong("Row values"), teal.transform::picks_ui(id = ns("x"), picks = x) ), - teal::teal_nav_item( - label = tags$strong("Column values"), + tags$div( + tags$strong("Column values"), teal.transform::picks_ui(id = ns("y"), picks = y) ), shinyWidgets::pickerInput( diff --git a/man/tm_a_pca.Rd b/man/tm_a_pca.Rd index 911a2fd70..6b1c1068d 100644 --- a/man/tm_a_pca.Rd +++ b/man/tm_a_pca.Rd @@ -6,7 +6,9 @@ \usage{ tm_a_pca( label = "Principal Component Analysis", - dat, + dat = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = tidyselect::where(~is.numeric(.x) && + all(!is.na(.x))), selected = tidyselect::everything(), multiple = TRUE)), plot_height = c(600, 200, 2000), plot_width = NULL, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -136,9 +138,9 @@ app <- init( modules = modules( tm_a_pca( "PCA", - dat = picks( + dat = teal.transform::picks( datasets("USArrests"), - variables( + teal.transform::variables( choices = c("Murder", "Assault", "UrbanPop", "Rape"), selected = c("Murder", "Assault"), multiple = TRUE @@ -164,9 +166,9 @@ app <- init( data = data, modules = modules( tm_a_pca( - dat = picks( + dat = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = c("BMRKR1", "AGE", "EOSDY"), selected = c("BMRKR1", "AGE"), multiple = TRUE @@ -183,13 +185,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2ulQtAIAGtRNcPiDMqI4DMNmBJsMxDMvnIgfDbloWLQoPRTnC8bcCAUiJCxGCCKiALKCRj8GSAz5gAaiURQYSkdlfRyMehQCDfIioAVgLBoODY3HkqpIkQaOD8OmM5msxhSrk8vny97kmB82hRPR7BwuI0fbp4u23B3dbq0Ey6dgqcjMSw6Gy2Co3URFCCsAbodjLAAkDTKUaRjB0XXmSjAcwAukA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFWOAMoAgow1raLxuv1DI6SiSgC+3UpoqOMq+eyVAZm6ALxbwbibfEIiY3vHwmIbPVW6pDBJUEmoBGmbt7oKYAAKAMIDX0ONw+sV2dzg3AwpGYEFEJk6MEQiFQtAIAGtRNcPiDMqI4DMNmBJsMxDMvnIgdjbokoTC4QikVoWLQoPRTliqbcCAUiKixGCCISALKCRj8GSAz5gAaiURQYSkSVfRyMehQCDfIioJVgLBoODkymcqp4kQaOD8AXC0Xixg6mVyhWG96cmAK2hRPR7BwuF0fbpUgO3IPdbq0Ey6dgqcjMSw6Gy2Co3URFCCsAbodjLAAkDTKObxjB0XXmSjAcwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY6HI1C0AjbA7EknQqCiOCkalgRZjBRgOSwzG03RaFi0KD0REYnkkgilTYEMTIgggsAAIQAslgANJYACM7Oq7KGAHFXHhdOznAB5QK+ACa7M5NJ5DJEGjg-BlcqVqo1WqNLP11q5oqxMEutHieihDhctqxAx50ajoIGA1oJl07BU5GYlh0NlstUxonKEFYQ3Q7H+ABJWtVywzGDp+islGBlt8gA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKurqMcACOgrSN7BBipMTURIyKEPUAgr6BADIpumkYWYiIjCPjSgC+AwBWRCrpANZwrKKVebYF-HAmUMKk6QT8tKIE6Rtbu-vA0PAHWXIAuu5oqJMVCV2HVQnldABeMERXCgvhCESiSG6eHCMQgwb1KYwdJQdKoAjZUFY6HI6akZgQUQmPowOaoWgEbYHYkk6FQURwUgssCLMYKMByWGYtlTODcDAUqBUmmMOmILQsWhQeiIjGikkEUqbAhiZEEEFgABCAFksABpLAARgF1QFQwA4q48LoBc4APKBXwATQFQtZos5Ig0cH4+sNpot1ttrt5Tr9wo1WJgl1o8T0UIcLgDWIGorzudBAwGtBMunYKnIzEsOhstlqmNE5QgrCG6HY-wAJK1ql3OYwdP0VkowMtvkA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 463541f08..18a53477b 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -6,7 +6,9 @@ \usage{ tm_a_regression( label = "Regression Analysis", - regressor, + regressor = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = is.numeric, selected = tidyselect::last_col(), + multiple = TRUE), teal.transform::values()), response, plot_height = c(600, 200, 2000), plot_width = NULL, @@ -28,12 +30,12 @@ tm_a_regression( For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{regressor}{(\code{picks}) Specification for regressor variables selection. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting variables -to use as regressors in the regression model. \code{variables(multiple = TRUE)} allowed.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting variables +to use as regressors in the regression model. \code{teal.transform::variables(multiple = TRUE)} allowed.} \item{response}{(\code{picks}) Specification for response variable selection. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting a single numeric variable -to use as the response in the regression model. \code{variables(multiple = TRUE)} not allowed.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a single numeric variable +to use as the response in the regression model. \code{teal.transform::variables(multiple = TRUE)} not allowed.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of \code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} @@ -106,7 +108,7 @@ decorator for tables or plots included in the module output reported. The decorators are applied to the respective output objects.} \item{outlier}{(\code{picks}) Optional specification for outlier label variable selection. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}, which allows selecting a factor or character variable +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}, which allows selecting a factor or character variable to label outlier points on the plots.} } \value{ @@ -163,13 +165,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = picks( + response = teal.transform::picks( datasets("CO2"), - variables(choices = "uptake", selected = "uptake") + teal.transform::variables(choices = "uptake", selected = "uptake") ), - regressor = picks( + regressor = teal.transform::picks( datasets("CO2"), - variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) + teal.transform::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) ) ) ) @@ -191,13 +193,13 @@ app <- init( modules = modules( tm_a_regression( label = "Regression", - response = picks( + response = teal.transform::picks( datasets("ADSL"), - variables(choices = "BMRKR1", selected = "BMRKR1") + teal.transform::variables(choices = "BMRKR1", selected = "BMRKR1") ), - regressor = picks( + regressor = teal.transform::picks( datasets("ADSL"), - variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) + teal.transform::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) ) ) ) @@ -210,13 +212,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2qFoBAA1qI3u8Lqk4aQ0f8xv85BCMRctCxaF99uwCAUiEixId-oJUMFkXBwbo4SINHB+AywEyWWywN1iYTllCgY9RJ1DoiUbjIRisXAcUswPjhUTibpSYxyfRKdTaQR6RsCGriBZ2f87DUgvAyASypy4NzeX9CCQCOyYMJNFF4fYnM4RRjQ1VQ91urQTLp2CpyMxLDobLYKudREUIKwAILodizAAkDTKRbhjB0XUmSjAEwAukA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKurqMcACOgrQ17L6ipMTURIyKEFUAwgDyAEzxugODSgC+3UpoqCMq+eyVAZm6ALwrwbjLfEIiouu6u8JiSz1VuqQwSVBJNRI1oqJWEGcXF9RQ9HD+GwpgWDgDzEzxI-2253ej1QJFEeg2iQwpGYEFEJk6MEQiFQtAIAGtRG93hdUnDSIT-mN-nIIcSLojkVBUejGJjEFoWLQvvt2AQCkRcWJDv9BKhgni4ODdHCRBo4PxhWBReLJWBunSacsoUDHqJOocGSi0RisTj8RTIcTSXByUswFS1bS6Zc4NwkUaWWyOYwufQeXyBQQhRsCHbiBYpf87DUgvAyNSyjK4HKFX9CCQCFKYMJNFF4fYnM51cTi1Vi91urQTLp2CpyMxLDobLYKudREUIKwAILodizAAkDTKA7hjB0XUmSjAEwAukA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIahaAQtvsQeS6pk+aRRWAFqN6XIOeLMVoWLQqQj2AQShsCGI6WAAEIAWSwAGksABGdm6PkiDRwfgGk3mq0KsWYxUeur4wmiXpIwXC0Wc8WSuDS4GykbysBe0Pk1WMdX0TXa3X6yEEKODADirjwunpAWcAA0bfSsIMvAXFbaaXAHU7IfS8wWqjALrQ4vz7E5nP1lYPPSD+v1aCZdOwVORmJYdDZbDUMaIyhBWIN0Ow0KgACQtKo73d8xg6PrLJRgJZfIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0lA0g0JA1RKIrBB0ZjMdQoPQ4NQkQowFg4ASxMSSPSYRjyYTUCRRHpIVNSMwIKITL0YLNULQCFt9iDyXVMnzSHKwAtRvS5ByFZjBcLReLZloWLQqQj2AQShsCGI6WAAEIAWSwAGksABGdm6PkiDRwfh2p2uj2a+WYrVhur4wmiXpIvVQEVixgSxBSmVyzkKpVwFXAtUjDVgCNZ8kJpOGxDGxim+jmy3W22Qgj5wYAcVceF09ICzgAGl76VhBl5O1rvTS4H6A5D6e3O1UYBdaHF+fYnM5+jqt+GQf1+rQTLp2CpyMxLDobLYahjRGUIKxBuh2GhUAASFpVV9vvmMHR9ZYlDAJYviAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_association.Rd b/man/tm_g_association.Rd index 39f80f394..b9332a587 100644 --- a/man/tm_g_association.Rd +++ b/man/tm_g_association.Rd @@ -6,12 +6,11 @@ \usage{ tm_g_association( label = "Association", - ref = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1), - values(selected = tidyselect::everything(), multiple = TRUE)), - vars = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2, multiple = - TRUE), values()), + ref = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = is.numeric | + teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L), + teal.transform::values()), + vars, show_association = TRUE, plot_height = c(600, 400, 5000), plot_width = NULL, @@ -31,10 +30,10 @@ tm_g_association( For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{ref}{(\code{picks}) -Reference variable specification created using \code{picks()}.} +Reference variable specification created using \code{teal.transform::picks()}.} \item{vars}{(\code{picks}) -Variables to be associated with the reference variable, specified using \code{picks()}.} +Variables to be associated with the reference variable, specified using \code{teal.transform::picks()}.} \item{show_association}{(\code{logical}) optional, whether show association of \code{vars} with reference variable. Defaults to \code{TRUE}.} @@ -122,16 +121,16 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = picks( + ref = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("Plant", "Type", "Treatment"), selected = "Plant" ) ), - vars = picks( + vars = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("Plant", "Type", "Treatment"), selected = "Treatment", multiple = TRUE @@ -156,16 +155,16 @@ app <- init( data = data, modules = modules( tm_g_association( - ref = picks( + ref = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), selected = "RACE" ) ), - vars = picks( + vars = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), selected = "BMRKR2", multiple = TRUE @@ -182,13 +181,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz43SoG4AawW435lRSojgpElYFGCjAcmJdOluj2jC59HJfM19NhRBuYmFBGxYAACgCyCrSiq7KxUHB7bpHdVAvA7ar1Yb6XKRBo4PxhSqbVAfVLpW8Y37pdqKSLxZKNdLZfLFcrfdH+drdfrc9Ljaakxbw7bSG7Hc7XXh3WA7J7GRQqzm05rA3Bg6GCR64F7W-ai-yYMJNJE9ATtq4O-TY-yF7pY10urQhRtVMxLDobLZynTRIUIKwAILodj7AAk9Sh6CvcsYOk6SiRSjASJ+QA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QMVpuqkHaLD0PCi7ABitNTkjOy0og4upVpokRyjpZsYJpMdpe0StATc7ACMADJyL129g8BnGtMAusPU+2ohw+XymjFEP1KUHEBHyLEmMi6AF8ukp9sMVHl2OMUroALz+DK4cZ8IQiGYE0nCMTY7qVXSkGCJCSJaGiIgEWiBKwQWn0+nVEz4hlwbgYUjMCCiEwdGCIRCoG4AawW435lRSojgpFVYFGCjAcmJdPVIrFEqgUpljDliD2jC59HJfNN9NhRBuYmFBGxYAACgCyAbSga7KxUHBg7pQ9VAvAg4bja76VqRBo4PxhQaA5bSAa1eq3oWk+r7RSzTwLVbZfLFQQVS7TZrtbr9YmC-yEuLJdKa3aWI7nR31e7PeWfdnA3m8NGwGGI1GY6LGRRp0bh-zU3B05mCUu46vgxv6TBhJpInoCdtXCbC8Oi5Ui10urQhRtVMxLDobLZynTRIUECsAAgug7D7AAJPUULoBBWqMDonRKEiShgEiPxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEjULQCFt9iDKXVMqI4KQmWAFqMFGA5DCMSzdFoWCT6AiKcLMQQShsCGIkQRgWAAs4ABp8qp8rCDLyuPC6PleADyjgAcg4AJpao3crAAWVtfICDkGdkGAEZnaq3R6AEw+vx2OwAMV5hr5ACEHVgANJYQP8wXSzHskQaOD8JE6vUG5ks-rCgUFuqixiIyF0hlMoUstkcrk8vkluuU8viyWllmy+WKyHKl0an26-U+00W60+waOn2u3Ue72R30LwZJ7VgYNhiMbmPxxMtlOp3TpuCZ7OQ6OxhPr7uUmAXWhxPSQhwuO+6IuFgtf-r9Wg0uwKjkMwlg6DYtg1BiohlBArCDOg7BoKgAAkLRVMhKHsowOh9MsShgEsXxAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0lBRKIiARaGErBB0ZjMQ0TEipqRmBBRCZejBZqhaAQtvsQZS6plRHBSNywAtRgowHIYRjeZM4NwMPSoIzmYxWYgtCwSfQERSZZiCCUNgQxEiCMCwAFnAANcVVcVYQZeVx4XTirwAeUcADkHABNW2ukVYACyAfFAQcgzsgwAjGGLZHowAmeN+Ox2ABiYpd4oAQsGsABpLApiVSvWYgUiDRwfhI+2O5083n9GWS5t1DWMRGQukMpkstkcrm6mX8wXC0Xi9vS3l9pUD1WzLtanUd3kGo0myFm8PW+MOp3xj3ev3xwYh+MRh3RuM5hM3walu1gNOZ7Mv-NFkvT8sV3RVnANZ1pCeYFsWz7rpSMAXLQcR6JCDguFBuiti2zZof0-S0DS7AqOQzCWDoNi2DUGKiGUECsIM6DsGgqAACQtFU9EMQKjA6H0yxKGASxfEAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_bivariate.Rd b/man/tm_g_bivariate.Rd index 5b4c67096..e583af210 100644 --- a/man/tm_g_bivariate.Rd +++ b/man/tm_g_bivariate.Rd @@ -6,13 +6,13 @@ \usage{ tm_g_bivariate( label = "Bivariate Plots", - x = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1)), - y = picks(datasets(), variables(choices = tidyselect::where(is.numeric) | - teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 2)), - row_facet = NULL, - col_facet = NULL, - facet = !is.null(row_facet) || !is.null(col_facet), + x = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices + = is.numeric | teal.transform::is_categorical(min.len = 2, max.len = 10), selected = + 1L), teal.transform::values()), + y, + row_facet, + col_facet, + facet, color = NULL, fill = NULL, size = NULL, @@ -36,17 +36,17 @@ tm_g_bivariate( \item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. For \code{modules()} defaults to \code{"root"}. See \code{Details}.} -\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}. +\item{x}{(\code{picks}) Variable specification for the x-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. Can be numeric, factor or character. No empty selections are allowed.} -\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:types]{teal.transform::picks()}}. +\item{y}{(\code{picks}) Variable specification for the y-axis. Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}. Can be numeric, factor or character.} \item{row_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting rows. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{col_facet}{(\code{picks}) optional, specification of the data variable(s) to use for faceting columns. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{facet}{(\code{logical}) optional, specifies whether the facet encodings \code{ui} elements are toggled on and shown to the user by default. Defaults to \code{TRUE} if either \code{row_facet} or \code{column_facet} @@ -54,15 +54,15 @@ are supplied.} \item{color}{(\code{picks}) optional, specification of the data variable(s) selected for the outline color inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{fill}{(\code{picks}) optional, specification of the data variable(s) selected for the fill color inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{size}{(\code{picks}) optional, specification of the data variable(s) selected for the size of \code{geom_point} plots inside the coloring settings. It will be applied when \code{color_settings} is set to \code{TRUE}. -Created using \code{\link[teal.transform:types]{teal.transform::picks()}}.} +Created using \code{\link[teal.transform:picks]{teal.transform::picks()}}.} \item{use_density}{(\code{logical}) optional, indicates whether to plot density (\code{TRUE}) or frequency (\code{FALSE}). Defaults to frequency (\code{FALSE}).} @@ -163,21 +163,21 @@ app <- init( data = data, modules = tm_g_bivariate( label = "Bivariate Plots", - x = picks( + x = teal.transform::picks( datasets("CO2"), - variables(selected = "conc") + teal.transform::variables(selected = "conc") ), - y = picks( + y = teal.transform::picks( datasets("CO2"), - variables(selected = "uptake") + teal.transform::variables(selected = "uptake") ), - row_facet = picks( + row_facet = teal.transform::picks( datasets("CO2"), - variables(selected = "Type") + teal.transform::variables(selected = "Type") ), - col_facet = picks( + col_facet = teal.transform::picks( datasets("CO2"), - variables(selected = "Treatment") + teal.transform::variables(selected = "Treatment") ) ) ) @@ -197,21 +197,21 @@ app <- init( data = data, modules = tm_g_bivariate( label = "Bivariate Plots", - x = picks( + x = teal.transform::picks( datasets("ADSL"), - variables(selected = "AGE") + teal.transform::variables(selected = "AGE") ), - y = picks( + y = teal.transform::picks( datasets("ADSL"), - variables(selected = "SEX") + teal.transform::variables(selected = "SEX") ), - row_facet = picks( + row_facet = teal.transform::picks( datasets("ADSL"), - variables(selected = "ARM") + teal.transform::variables(selected = "ARM") ), - col_facet = picks( + col_facet = teal.transform::picks( datasets("ADSL"), - variables(selected = "COUNTRY") + teal.transform::variables(selected = "COUNTRY") ) ) ) @@ -223,13 +223,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VutRQ9HB+OwpgAEK3jHu5F0AAV2qRRD99s9KqFTrpULQCABrURPF4vFKiOAQ9ZgaY-OTQjGVLR3d7HdjYkQaOD8eE-YgWQkbSpE1m6VjwxEotEcypYnF8-GDQnEklkwEUsRUz5wWn075gQSoILIuAsmG6dlaxhEbKJEzqHHcpGo9EkwW4n4EsA6km6SX3eiU6ny8iK3Q-OysVAau0c+0vNqG42kU28i0Yq3C21BjFO6Vot0KhlgOzVQLwMiajFdNlKLq0Ey6dgqcjMSw6Gy2crPUSFCCsACC6HYSwAJPVSp3sYwdJ0lLMlGBZgBdIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHH+GRgmzPDs-QNdAL5dSmiowyp57BUjsQC8m1C4G3xCIqK6O6QwiRKJ9NostIFw692VutRQ9HB+OwpgAEK3jHu5F0AAV2qRRD99s9KqFTroEhhSMwIKITB0YIhEKhaAQANaiJ4vF4pURwCHrMDTH5yaHEyqI5FQVHoxiYxBaO7vY7sMkiDRwfjwn7ECw0jaVWkS3SseGMlFojFYnH4wnSyqk8lqqmDGl0+ny5mKtlYzmA7liXmfOACoXfMCCVBBPFwcUw3RS92MIjZRImdTkuVwbhIhWs9kqglE+maik-algT30hHBnhMllKjlc+g8vk28h23Q-OysVCuxPSpMvNp+gOkIMh9PGiO4qPq3ZkuM6gZ69uGjMmrPmnOWvO24VgOzVQLwMhu4ldSVKLq0Ey6dgqcjMSw6Gy2crPUSFCCsACC6HYSwAJPVSteyYwdJ0lLMlGBZgBdIA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rpqFB6HBqEiFGAAEKYxjY8i6AAKPVIogpMPxdSiSNQtAIW32IIJUKgojgLOBYAWowpcnZQrqWixxIR7FFIg0cH45MlAHFXGB+kLZYLdKxubz+Xj5cLReKKVKZXL5YracqxKrSXANVrIRSAs4ABoyk3Gjn1IgFNJnAhi818gVhuqZW0CyUjaUGp1Cl3Y+gqtVe8g+3T2rAAWWDYdDQu6UfUschPPjVvlybFqYdmZNCqVefdBe92q8AHlHAA5BwATUrRpB-X6tBMunYKnIzEsOhsthq+NEZQgrEG6HYaFQABIWlVT2fRYwdH1lkowEsvkA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIZMYGkJGl6NoWLQwnBgQM6rpqFB6HBqEiFGAAEKYxjY8i6AAKPVIogpMPxdSiSKmpGYEFEJl6MFmqFoBC2+xBBKhUFEcBZwLAC1GFLk7OldR5fIFQtmWixxIR7DlIg0cH45KVAHFXGB+tK1VLdKxuXBuBheVB+YLGMLEKLxZKOQTMnKFRTlar1RqtV6db69Qb6EaTXAzRbIRSAs4ABqqp2O4OMIgFNJnAjy13uz3e3X+sUSvEamVhyVKkYqu3R6Wx2sJxD62mGsTG0lp8gZ3QRrAAWXzwcL0u6ZfUlchvfjfoDjaddVD8rbka7u8mbp4Nc3iaHyZHqfTlq8AHlHAA5BwATXnDpB-X6tBMujsCo5DMJYOg2LYNT4qIZQQKwgzoOwaCoAAJC0VTIShcqMDofTLEoYBLF8QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_distribution.Rd b/man/tm_g_distribution.Rd index d643998f4..ad3391d66 100644 --- a/man/tm_g_distribution.Rd +++ b/man/tm_g_distribution.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_distribution( label = "Distribution Module", - dist_var, + dist_var = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(is.numeric), teal.transform::values()), strata_var = NULL, group_var = NULL, freq = FALSE, @@ -121,10 +122,10 @@ app <- init( data = data, modules = list( tm_g_distribution( - dist_var = picks( + dist_var = teal.transform::picks( datasets("iris"), - variables(tidyselect::where(is.numeric)), - values(selected = "Petal.Length") + teal.transform::variables(is.numeric), + teal.transform::values() ) ) ) @@ -144,18 +145,18 @@ app <- init( data = data, modules = modules( tm_g_distribution( - dist_var = picks( + dist_var = teal.transform::picks( datasets("ADSL"), - variables(c("BMRKR1", "AGE")), + teal.transform::variables(c("BMRKR1", "AGE")), values(multiple = FALSE) ), - strata_var = picks( + strata_var = teal.transform::picks( datasets("ADSL"), - variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) + teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ), - group_var = picks( + group_var = teal.transform::picks( datasets("ADSL"), - variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) + teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) ) ) ) @@ -168,13 +169,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDuqi0BADWootHRymicKT3CmDVtR9y40uPlTONSg9GmnFo-FYLxEGkQiGy+RkcHYtQwEEE8BqBDkv0OjzO1EEYnY0LgGjg-AuHwACq9uBgADIUCQFH54yptI6c3RtNq0Ey6FGqZiWHQ2Wzlf6iQoQVgAQXQ7E6ABJBLRSiqXowdIw2s0lGBmgBdIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6urSMtKJxVTWiSgC+ihBKaKj1KnnsFf4ZugC8A0G4-XxCInUjdKKkfRCVlaQwiRLJtaQ19IKa1v3L-luJWizDugkY21AQoiZEjDCIiKi0BADWootHRymicFI3wUYGqtRBcnGS1+Kzg3GuzDuDyeLzONSg9Gm7FqGAggngNQIkMOvyuNyRj2eiDO1EEYjS0KObSZ-TabVoJl02NUzEsOhstnK0NEhQgrAAguh2J0ACSCWilWUAxg6RhtZpKMDNAC6QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQkGR2pEYDEEmmszwhIXhaS0LEBqFoBEmczR6M+UFEcFIRLAfWaCjAcm+4JJdWxiKg9H+7AITzAACEALJYADSWAAjHSqnT6gBxVz0hnE9HY6iCUEwda0OJ6D4AMXqzQCzmGzIVTPRogRuSxOI+eIJRLNJMy5MpPJpdNNzJZLFo7M53KlWH5Et0dK8AHlHAA5BwATRDdMNAA0PVVySINHB+ICo45ms1jSTPSSJIwiIJUNbGLj8YSwV7SS6qe76YyG6zfRzQQHqUGE2AI9G4-3k6ndOm4Jnsx9c-nC+j57pC8NhrQTLp2CpyMxLDobLYakzRGUIKx6uh2GhUAASQS0KpX6-kxg6RjDAZKMADS5AA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQkGR2pEYDEEmmszwhIXhaS0LEBHQRUAgohMREYMG6qFoBEmczR6M+UFEcFINLAfWaCjAcm+4LpkLg3Aw+MJxNJ3WxiKg9H+7AITzAACEALJYADSWAAjByqhz6gBxVycrm09HY6iCUEwda0OJ6D4AMXqzQCzmGvKNPPRonx4SxOI+eOYwpJZMQFKpNI9dMyjOZcrZHPdvL5AqFRODYpYtEl0tlOqwiq1ug5XgA8o4AHIOACahY5zoAGgmqoyRBo4PxAeXHM1mq66Ym6RJGERBKhfYxcfyeKmRSGw9SwUn6TGWfHOdylwGCWnRYhxVmpaDc6z87WwKWK9Wzw2m7oW3A2x2Pl2e330W-dH3hsNaCZdOwVHIZhLB0GxbBqHlRDKCBWHqdB2DQVAABJBFoKpEKQxlGB0RhhgGJQwAGS4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_response.Rd b/man/tm_g_response.Rd index 3432183de..dae81ab32 100644 --- a/man/tm_g_response.Rd +++ b/man/tm_g_response.Rd @@ -6,10 +6,10 @@ \usage{ tm_g_response( label = "Response Plot", - response = picks(datasets(), variables(choices = teal.transform::is_categorical(min.len - = 2, max.len = 10)), values()), - x = picks(datasets(), variables(choices = teal.transform::is_categorical(min.len = 2, - max.len = 10), selected = 2), values()), + response = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, + max.len = 10)), teal.transform::values()), + x, row_facet = NULL, col_facet = NULL, coord_flip = FALSE, @@ -155,17 +155,17 @@ app <- init( multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ), - x = picks( + x = teal.transform::picks( datasets("mtcars"), - variables( + teal.transform::variables( choices = c("vs", "am"), selected = "vs", multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ) ) ) @@ -187,21 +187,21 @@ app <- init( modules = modules( tm_g_response( label = "Response Plots", - response = picks( + response = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = c("BMRKR2", "COUNTRY"), selected = "BMRKR2" ), - values() + teal.transform::values() ), - x = picks( + x = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = c("SEX", "RACE"), selected = "RACE" ), - values() + teal.transform::values() ) ) ) @@ -214,13 +214,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRqFoBAA1qIabSkUEqfyFmAvlcjiizvKtCxaAyMXL5XN8kRJWIEXMVQRlnswAdGBqhUaqSINHB+BbFtaVoKtUaYMJNJE9IiAGIAQQAMgBlZyao3nEy0ULui0RmOuP34uTxo066iCXH-Wk5p2VUIWiXS2Vl84pJU11WXAWlrPnHWMPX0A21-EEE1mzGW9YCtYoGCOtv4l1wN0ellgDarXvnAPUIMiNNR2O5hNJlPz3Tp2Mr1sJ-OF2XF7NO4tdLq0EyTFTkZiWHQ2E5jUSFCCscPoOw4IACT1KUIFUowOidMCShgACdxAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlTCtLKJxur0E-RWmHbrsWroqugTsCoSs1Iuli1qiq7qLsFuLUiyLcrbl3ZVDfYyiwMBaALp3g1DiJuqkHezD-Tf3d12VAF8lACuko0KhBio8gszildABefwZXBjPhCEQDRFo4RiGHnXSkGCJCSJaqiVAkURwPH43TUKD0OB+RGLLBiCkQKm6AAK7VImzwY3xZI5XMRqFoBAA1qIabSkUEqfyFmAvlcjiizvKtCxaAyMXL5XN8kRJWIEXMVQRlnswAdGBqhUaqSINHB+BbFtaVoKtUaYMJNJE9IiAGIAQQAMgBlZyao3nEy0ULui0RmOuP34uTxo0JDCkZickwdGCIRA66iCXH-Wk5p2VUIW-OFqDF0vliXS2UN84pJU91WXAX1rPnFtF0Qlxhliu6-W43v4ggms2Yy3rAVrFAwR1j-EuuBuj0ssAbVZL84B6hBkRpqOx3MJpMpk+6dOxy+jhMTttTjtzlWNa9rWlS1l0XS0CYkwqOQzCWDoNgnGMoiFBArDhug7DggAJPUpS4VSjA6J0wJKGAAJ3EAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQ1C0AhbfYgsl1TLEznAsALUZ0uQ8yWYrQsWiUhGk1WYgglDYEMRIghygBCAFksABpLAAJm5ujpXgA8o4AHIOACaSpVurqxJEGjg-FpYEtNvtdIlkuVMbJ6uogjR-VVcd5mKiSOFovFGbJ0rgsrpCt98bVGq1aPLZP1huNkNNdICzgAGo66VhBl5XGB0-6A9S4MHQ5DO93ezXdP3dYnk-tU7GY4v+v1aCZdOwVORmJYdDZbDUMaIyhBWIN0Ow0KgACQtKrXm-Exg6PrLJRgJZfIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0g1RKgSKI4OjMZjqFB6HBqEiFGAsGJCRBiboAAo9UiiOkwjFk-FMlmQqakZjMky9GCzVC0AhbfYgsl1TLEznAsALUZ0uQ8xWY4Wi0TixiSxBaFi0SkI0m6zEEEobAhiJEENUAIQAslgANJYABM3N0dK8AHlHAA5BwATS1OptdWJIg0cH4tLAHu9frpCsV2uzZP1UDFEtmZuogjR-V1ud5mKiSILReNUplcutuuVcFVdI1Mbzerg3AwIsLhuLpvNlrRfbJdodTshLrpAWcAA0A3SsIMvK4wNW4-HqXAkynIRutzvp7o9zaG6Om+OyxW+5XMS-+v1aCZdOwVORmJYdBsWwagxUQyggVhBnQdg0FQAASFoqlguDiUYHQ+mWJQwCWL4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplot.Rd b/man/tm_g_scatterplot.Rd index c50559e74..0327ff83b 100644 --- a/man/tm_g_scatterplot.Rd +++ b/man/tm_g_scatterplot.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_scatterplot( label = "Scatterplot", - x, + x = teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(is.numeric), teal.transform::values()), y, color_by = NULL, size_by = NULL, @@ -157,47 +158,47 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = picks( + x = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("conc", "uptake"), selected = "conc" ), - values() + teal.transform::values() ), - y = picks( + y = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("conc", "uptake"), selected = "uptake" ), - values() + teal.transform::values() ), - color_by = picks( + color_by = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("Plant", "Type", "Treatment", "conc", "uptake"), selected = NULL ), - values() + teal.transform::values() ), - size_by = picks( + size_by = teal.transform::picks( datasets("CO2"), - variables(choices = c("conc", "uptake"), selected = "uptake"), - values() + teal.transform::variables(choices = c("conc", "uptake"), selected = "uptake"), + teal.transform::values() ), - row_facet = picks( + row_facet = teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = c("Plant", "Type", "Treatment"), selected = NULL ), - values() + teal.transform::values() ), - col_facet = picks( + col_facet = teal.transform::picks( datasets("CO2"), - variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), - values() + teal.transform::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), + teal.transform::values() ) ) ) @@ -219,35 +220,35 @@ app <- init( modules = modules( tm_g_scatterplot( label = "Scatterplot Choices", - x = picks( + x = teal.transform::picks( datasets("ADSL"), - variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), - values() + teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), + teal.transform::values() ), - y = picks( + y = teal.transform::picks( datasets("ADSL"), - variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), - values() + teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), + teal.transform::values() ), - color_by = picks( + color_by = teal.transform::picks( datasets("ADSL"), - variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), - values() + teal.transform::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ), - size_by = picks( + size_by = teal.transform::picks( datasets("ADSL"), - variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), - values() + teal.transform::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), + teal.transform::values() ), - row_facet = picks( + row_facet = teal.transform::picks( datasets("ADSL"), - variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), - values() + teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ), - col_facet = picks( + col_facet = teal.transform::picks( datasets("ADSL"), - variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), - values() + teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), + teal.transform::values() ) ) ) @@ -260,13 +261,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDqhoQBrURvd7nFKiOCkDH-Ub-OTwrHnLQsWhfPaYsmVAiQ6FiA4ERaEEgEOG6f6CVBBVFwYmkumVXEiDRwfgHf7ECz-JZkkkKrEU6iCE5dRXC96sZFogkIrE4vEEsBEsBKw3vCmMKn0GnKskMqEw-brVkyjlcnl8qACoWOrFiuASqV-MC8-mCsCByqWkWq9UYzVY+NYtodRL0XXrFEEdG0o0ZXH4tnmtNkm12h1W9OM10stkABU+ZG9YDsrFQ0dK-zs1UC8DbeG57LlI59UYDtfewdDBwAco4ADLL2O6Csq7hJtK1zei2gALzgWZzujzBfXxtLhMG04TlOpJ2dTLdug9Y85E4jvv9FtKc7kGGo6Rn60b7uS24aoGEGMEQ2SJCY6h4nq+YGiK16muW2pbraT7oSK771sy7rNq2pDtp23aUQOlwUBR-7rqKPwhkBi4rmuM4bjh1pQcmME8e+RBJEhMLgrm+qFu8mFlnejFcVW+HsC+Dakf8LZQMOvYdl2Pajv2cCDvRQq6IBkrsauEGVIm0F7sqKZdF0tAmLo7AqI86iaDoNi2OUZyiIUECsAAgug7AzAAJPUpSRbijA6J0ExKGA4wALpAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6uoxwAI6CtNXsPqKkxNREjIoQlQDCAPIATHG6-QNKAL5dSmiowyp57BX+GboAvMtBuEt8QiKia7o7wmKL3ZW6pDCJEomiBIHkjJFEpKfn59RQ9HB+6wpgAGV7qRHs9SCN8kRaAQxP8tmd3qEDgkMKRmBBRCYOjBEIhUNCANaiN7vc4pURwUjE-6jf5yeGk84otFQDFYxg4xBaFi0L57EmMyoESHQsQHAiLQgkAhw3T-QSoIIEuB0hmCyoUkQaOD8A7-YgWf5LRn042k5nozHY3Hc6iCE5dE1q96sZFwbioy3szn4ghEgWk8mU6lgWlgU0I83ungstnWrk8vknM2M4VQmH7dYS-XS2XyxVQZWqlOkzVwbW6v5gBVKlVgEuVCPqi2sq0cm3ce3Ex2kpuktodRL0V3rFtx9t4wnUyPvINUyVhvuMsdtzncxi8+j8hvnNOizO6bNgAAKnzIebAdlYqDrpX+dmqgXg57wcqlhtf+drxZnpZ+5fIStdAAOUcAAZMCdyXKMPVjVcOztB0S2gjVaAALzgIcRwuaNPVbb1cV9f0dznENF2dGCYy9eN103fk9wzcVJQNGVP2rAsi3DUoywrPV2O-LidxXAiE0Q7tkIoypGCIbJEhMdRKTdWDqInIjp3VUiF0GH9m1wuCRNopN1PVQ8RUYrNJVPVlSAvK8b1sx9LgoGzBN-d4eMAg5QIgqDJKZPSVLXTskN-FDDyIJJ5JhcFRwC-D4zUgNZwyCl5xpbTXN05T4onQytxOBixQs-4rJfO9L2vW83wfd0nJfeldA8nUvPAsCwsqYSaOC8TQrNHsui6WgTF0dgVEedRNB0GxbHKM5REKCBWAAQXQdgZgAEnqUoNopRgdE6CYlDAcYAF0gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokjULQCFt9iDyXVMqI4KQxWAFqN6XJeRLMVoWLQqQj2AQOcKxEiCMD5QBxVx4XT0gBCAFksABpLAARh5lrAtodWAATEqqtKRBo4Pw6abzcrxRL1dRBGj+qrw3zMaxBcLRWTVVCoNLZcaFb6I+T1YxNfRtbrOQbIUb6YMza7rXbHS6LQ3PT6wMrdP64IHg5DW0384nC9wY-s4xKE6rur00vRk5ChSKxcPMVKZXK8x2VRmiyWy7m6y33Y3nfWT23z1hBl5zVV6VhnCa-AB5AByzc73d7SLfjlGoxTruo6xgWuhAeSoi0AAXnAc4LroS5pmBkq5Nmm4jIq24oboe5ami5b6oiVaHneboeoO25djSPbkH2bq1mGO6qlGY7ZKuEGYowRAFGkZxcmyi6piuGaZuhuaYUOol4aWBF6lyxG6NWF6Ou295gNet5Xk+r4fr61EBnRv7-oBzGRiB45gZxdTdHx6gyimy7pqq645jWknYaudQyWW8mVkpxoUd6V43mRD46e+n5+jRP6Qn+AHWWqFnsfGEYTv0-S0CYujsCohLqJoOg2LYNQYqIZQQKwgzoOwaCoAAJC0VR1fV0qMDofTLEoYBLF8QA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXUY4AEdBWgb2CDFSYmoiRkUIOoBBHwCAGWTdVIxMxERGYbGlAF9+gCsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI09c2dveBoeH3MuQBdN2h0CZUxXYtRCuV0AF5QeFcCC+EIRKIIbo4cIxMCBnVJjA0hI0ncwuRGHEiKR0ZjMdQoPQ4NQkQowAECASZMTSN4ShsCGJ6TCMeSokipqRmBBRCZejBZqhaAQtvsQeS6plRHBSPKwAtRvS5LzFZihSKxRLZloWLQqQj2AQOTKxEiCMCNQBxVx4XT0gBCAFksABpLAARh57rA3r9WAATNqqiqRBo4Pw6c7XTqFYqDVBReLGJLEKbqII0f09am+ZjWIK4NwMMLM0ac1KZXKyXqoVAVWrHZro2nyRms8a82aLWjrZy7ZCHfTBi7g56ff6g275+Go2AdbpY3B44nISvFz2y32qzxawOG0OC0Xe7pS3rur00vQK5D+-Xc9LZfKj5jlar1d2666q2b7ZrmpqMOa9CWlOyZzqGC6BvBYb+muVT0lggxeK66FgFgzhOn4ADyAByS4bluO5IiRjijKMd4gSeNaGmBJrcIW+zFoqDHkqItAAF5wE+L6TExZ7vo2X4tnqf6dtOIxakBN51KBg4QVBME2lyiKTl2s7Lgh4bkTGNLbuQu4hjOKbAXqqkXvmHHZD+PGYowRAFGkZxcmyr5iSxg6fs2ylth2AEKYeraidW4msUOkEjvsY62jpuiwShkbwZh2GZQRxFkdGm6mVRkI0XRLnHtF-n2ex17OTZmLdJ56iqpWlV1rFgXfpFslhYsSk-ipfntWpw7QaOWkTqljrpWhIZZThc25aRxmFXG5nUbR9H1RVp5VeBNWcTeXF1Fx-T9LQJi6OwKiEuomg6DYtg1BiohlBArCDOg7BoKgAAkLRVD9v0qowOh9MsShgEsXxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_g_scatterplotmatrix.Rd b/man/tm_g_scatterplotmatrix.Rd index 5bc2a681f..7d56ea982 100644 --- a/man/tm_g_scatterplotmatrix.Rd +++ b/man/tm_g_scatterplotmatrix.Rd @@ -6,7 +6,8 @@ \usage{ tm_g_scatterplotmatrix( label = "Scatterplot Matrix", - variables, + variables = list(teal.transform::picks(teal.transform::datasets(), + teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE))), plot_height = c(600, 200, 2000), plot_width = NULL, pre_output = NULL, @@ -21,7 +22,7 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{variables}{(\code{picks} or \code{list} of \code{picks}) Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -\code{picks} use \code{variables(..., ordered = TRUE)} if plot elements should be +\code{picks} use \code{teal.transform::variables(..., ordered = TRUE)} if plot elements should be rendered according to selection order.} \item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of @@ -130,19 +131,19 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - picks( + teal.transform::picks( datasets("countries"), - variables( + teal.transform::variables( choices = tidyselect::everything(), selected = c("area", "gdp", "debt"), multiple = TRUE, ordered = TRUE ), - values() + teal.transform::values() ), - picks( + teal.transform::picks( datasets("sales"), - variables( + teal.transform::variables( choices = c("quantity", "costs", "profit"), selected = c("quantity", "costs", "profit"), multiple = TRUE, @@ -152,10 +153,10 @@ app <- init( ), transformators = list( teal_transform_filter( - picks( + teal.transform::picks( datasets("sales"), - variables("country_id"), - values() + teal.transform::variables("country_id"), + teal.transform::values() ) ) ) @@ -180,20 +181,20 @@ app <- init( tm_g_scatterplotmatrix( label = "Scatterplot matrix", variables = list( - picks( + teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = tidyselect::everything(), selected = c("AGE", "RACE", "SEX"), multiple = TRUE, ordered = TRUE, fixed = FALSE ), - values() + teal.transform::values() ), - picks( + teal.transform::picks( datasets("ADRS"), - variables( + teal.transform::variables( choices = tidyselect::everything(), selected = c("AGE", "AVAL", "ADY"), multiple = TRUE, @@ -203,7 +204,7 @@ app <- init( ) ), transformators = list( - teal_transform_filter(picks(datasets("ADRS"), variables("PARAMCD"), values(selected = "BESRSPI"))) + teal_transform_filter(teal.transform::picks(datasets("ADRS"), teal.transform::variables("PARAMCD"), values(selected = "BESRSPI"))) ) ) ) @@ -216,13 +217,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQqgtAECNk20VCKSiHAJWvaBH2PSRhpdNzdR8xjUuKnSQ1MaVuiaPwE0knAGiIIgcC-KwBQqBINgq6rXSyyIGi+WakzFlAVwSAOVxbjux1AU7MDCJoMGuaxjtO7oYJbvRfksS42v3tHhrc9QamTQ+hp9iLYsS8Lioy3Lks6c+1154q6u82yWvB6rutiw0ZZDEl1qaKQDInMQxXfas9WNXkQcx87ptu4n2ntylXc7UVJVXIPTWkCPo+6KH1DhyIkcuGnqtxzI7sDG5Ke6Dnirn6ntG1NaogmJlgRggbgv8drCSJDfEB35lYqSsTRf53FpLBuhoS7ywuhXVeo8a6azLoDVg4F+BQJjhnLOaQQE8m1pfM+XpOhci5LQEwuh2AqGJiCbQn4lJlE6KIQoEBWDPHQOwCGAASQQtBSisNlowX4vUlBgB6gAXSAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6usTmpIy0YnH+GRgmzPDsFZW6tPy6ALxVHWAAIq54ugpgAGJYk6WTAJJ2cxNgzgDKK5MACsvjkwDis-tgAHIAMltgAEJj82DnjlcAgntyuJ2VEkQ6jBDwZH6pnUpCIjA6EC6XQI7AATKV4bpEQBGBFo3SojGlTGw96fLrUKD0ODUURAmGTACyJBYBHyrCuWDgqEE9DoBEmikhXTx3MqhIgEkEUCkiRMsFo1FYQPFGjBEKhlRhmIAzKU1boNRqUdj1djeYrdITiaTyUMDjIYFBlByTgAJEkiG2MohWixwTn4g1dVBEFmEzQkM0ADg1ADYAOylMMABlKABYoxi4xjMcik8jMTGMGHSgBOb2VFhwYIDGEqgCsSYrFdVMcxFZjFfzKJViPjdYROdKocLXn4qDNKow8a7SdhGDTI9K2Y12cR2aT2ebumzWZHff4cHopDNE5xGG106R3ZPR9HZ67F4n565lTvulE3AaWRSLTacAVXR6QORiEbHx8lURA1GwiQ-gMT4wJEn74kqQyjFcMxXEsVwbFcuxXEcVwXFctxXI8LxvIBhqiLQABeegDABcG6IwzKEgQVH2E4rhAX2rAlowQKiGCpDsFBMFwvWMaILCMbiaUAF0Qx6jMQ4LhyH2OgQIIzGCSI7AUmAohWtQ1BXPA-C0IIMBXISjBSFcJB0D4nJSSm9GRHJQIKc4fYENaTH6XAvSQREmkwm5pRTM85zrO5DmlE5jHyaxfYAI7CmQeTSgMfxgjA7DSciMYpuJHlEKIpBkulECZdlKbBvlMZ9qgjBECYeRAhljBZdJknJg+XIAL5cgAVkQKiJAA1nArCiMUGS2Fkg3DWNE1fnNECjeNQzVGQdRiFcG21PUohXD09mdMtq0cJMT4iAdJyXdtJxHWA3qnQt60gZt+1XLd12lNpD1ApMu1gQ9SlKFyShoIOWQqHkX4pECJSdHwQhXUCSPCGIX6VKQMCJBIiSiJ5pDkIwkRENjgR1KEmMEkSJL-WA6yE8TpO7lae2hHMtFaCwtBEijAx0MV1NQgkGC1NaogmJliCIKgtAECNk20VCKSiHAJWvaBH2PSRhpdKL4sQJL0uINzdR8xjyuKnSQ1MaVuiaPwE0knAGgy3AvysAUKgSDYut610asiBovlmpMxZQFcEgDlcW47sdQEBzAwiaDBrmsf7Ae6GCW70X5LEuFb96Z4aBvMEbUttTL3PUGpk0PoafYiyWPCG8bVey-LivC4qqvq0rOnPtdTeKmXEuVzA1c8xbSuJ3rNvyw0ZZDEl1qaKQDInMQxXfas9WNXkCdZ4HLsh-n2mrylG87UVJVXPvTWkEfx+6Mn1CpyI6cuCXes5zIocDDckXXQDdFSgOLrRNuE9AhgntoLfiVsEiJCgZlMUkpiY92btwMW5d26T07grWeL8mhBDVhrC6Q9n7HzHhXE2ZteZsktoQN6tRWDgX4FQrONC8FT1rhjcBYCrYCNAd1UGShaAmF0OwFQxMQTaE-EpMonRRCFAgKwZ46B2AQwACSCFoKUHRatGC-F6koMAPUAC6QA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdy6qhaAQVpsBuK6plRHBSLKwH1mrS5Jz5UjeYSBfC5TrdAQSksCGJoZp+BsqXANN04Do2KUVBIbNrjXUlSINHB+NCCL81QBxVx4XS0rD1Lzhqq0gLOAAams9XpgR1ocT0QIcLjTxqIjD2jH90LzzgLOpMRLLQIAYvVmomjeKta3ubzqIJ4XMde2ueLJdLZYP5YrlarJgFUx3SXr+fRIWKvabzZagdbbb7SI7naxXRB3QOvd67X6A0Cg7T6mGOZG1QA1Jv3m8+ACas7HOoz1E02fLJxKznbkixLOt7CAqt5RrKIIMbZtXG-bk+3lVDSRPblSGYCBRBMIsYDCIsoSBYVRRA1I0mwqBcPwxhURrP8ZHYYcZS2cIlRVYNp1THk+QNVUAAV6mjABZXxeK7HtNh9e1yEvB8ACFnACYZBL8TU5HQpFtNQuY5loExdHYFRsXUTQdBsWwai5UQyggVh6nQdg0FQAASQRaCqVy3KVRhnTmaYlDAaYXiAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpbahp8sALaOrp7G4aUAX0UIACsiFTSAazhWUQrc23z+OBMoYVI0gn5aUQI0xeW1jeBoeE3MuQBdN2h0NpVi9gHM3QAvCFcrgBnwhCJRIDdODhGJfhA6nVSDA0hI0hcwuRGHEiCiwoxaFEEUikdQoPQ4NRoQowAECFiZLjSDCCUTaaDEaTdFoWLQKZDoXRRKQSdzkXBuBhSMwIKITERGDBuqhaAQVpsBuK6plRHBSJqwH1mrS5JztUiOjKoHKFUrurzCQL4VqLboCCUlgQxNDNPwNlS4BpunAdGxSioJDZzW66nqRBo4PxoQRfkaAOKuPC6WlYepeLNVWkBZwADVNMdjMCOtDieiBDhclbdir2jCT0MbzmbFpMRI7QIAYvVmiXXeKzePuVbZfLFcrELzqIJ4XMLZOueKZza5-bEKr1ZrN9rdfrDZMAhWp6Tt7b5w6+c6j7G6h6vT6gX6AwnSCGw6wIwgKMNxfXR4yDchkyBVNaXqTMORzI0ADURwQ2CfAATSvY8LWrahNDrTsnG7a9uVbGQB3sYie21Psoko4dR1cHDuTXbU2NJEDp1nO0YDCRUoSBYVRVI1I0mtO8lTSPt8JkThJR4CTdwXA8NS2cI9QNNMLwrdoFOlHj70XR96EhNMAAV6jzABZXxdKXFdNnAxMoMQgAhZwAmGcy-FNOQOKRAK2LmOZaBMXR2BUbF1E0HQbFsGouVEMoIFYep0HYNBUAAEkEWgqiy7K9UYMM5mmJQwGmF4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_outliers.Rd b/man/tm_outliers.Rd index 4feff6ffc..7978df5cc 100644 --- a/man/tm_outliers.Rd +++ b/man/tm_outliers.Rd @@ -113,21 +113,21 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - picks( + teal.transform::picks( datasets("CO2"), - variables( + teal.transform::variables( choices = variable_choices(data[["CO2"]], c("conc", "uptake")), selected = "uptake", multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ) ), categorical_var = list( - picks( + teal.transform::picks( datasets("CO2"), - variables(), + teal.transform::variables(), values( vars = vars, choices = value_choices(data[["CO2"]], vars$selected), @@ -160,21 +160,21 @@ app <- init( modules = modules( tm_outliers( outlier_var = list( - picks( + teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), selected = "AGE", multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ) ), categorical_var = list( - picks( + teal.transform::picks( datasets("ADSL"), - variables(), + teal.transform::variables(), values( vars = vars, choices = value_choices(data[["ADSL"]], vars$selected), @@ -194,13 +194,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm526VC0AhDY3il3O1IzUjGsBvXny70+qqo2jo5VO8PO7HusS2yPRuBYqGJ86pAlBr6TUnkwgkAissCCVDBEZAuShuPO+FwRH8W1dcuVll4E1xmDCTRRPQygBiAEEADIAZWctbrVRMtDCSNtI4nrjD4ZrXZdoOoglxOzj+5dG7XVQIQTgEiIvTPyRtMvtjs3VTdHq9M79cADheDx5nKYxe7TnG267m+M66KiKoQWCQF1gmMJQSBabwbi2adLmRJgPm0GMKIAAkDZNr+4GEeQzYykh6Y4lmmQ5sG2GQQRcAImRxEzj21B9iItoOC4T6moePqCQJJqHjsOy0CYujsCo5DMJYOg2LYFTeqIRQQKww7oOwgp4YItBlLpMyMDojA7LsShgLs4xAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLqkQ11XfxQpFC6cAAesKgiSoHBBsZc1AD6sVA2MUEhRroA7rSkABYq7Km4uiBKuroAwgDyAEzxNQ2VzfXAwApgqIy0MCysSQDWcKxdALrjTaJwAI5JIhDsEIxEOex19XKKEAC+OwBWRCrDo6IlmbbZRycjrOc3EKccXZtdZa8teLpdPX0Dzy623cWhYoiaBAKxwIYiSMxEGjg-HYoN6UHoIiSkOhYguwQ6n3qE3GZQI7C6AAVqFAyO8fmA7KxUHA6V07Iw4EF4LSwNsdko0Kgmip8uSIFVUroALwBTK4Vp8IQicEyxXCXGtKqkGBJIiCUh0GTnTVVXR6g20GRJVHS3R0USkMWm526RIYUjMCCiExERgwRCIVC0AhDY3il3O1IzUjGsBvXny8MRrWcngemne33+xCo2jo5VO5PO7HBsS23P5uBYqGl86pAlxr6TUnkwgkAissCCVDBEZAuSJovO+FwRH8W1dbu9ll4E1FmDCTRRPQygBiAEEADIAZWcg6HVRMtDCSNtG53riTyYHc5dbvTXp9foDoOoglxOyLn5dN6vVQIQRwBIvrBtw1osLa9qOreKbcO6nqZs+gbBqGhZFlGcAxq28a-ge94IU+2YVhiH77kWr7vmGB5VKiKq6LRZFDiWMJ0RRVbMbi9adI2RJgM29FggAJCOY64dRInkOOMpsdWOJ1pkDbxvxtHCXACKSWJB4LtQS4iLaDguDBprfhGJnGSa347DstAmLo7AqOQzCWDoNi2BU4aiEUECsOu6DsIKgmCLQZQBTMjA6IwOy7EoYC7OMQA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3JD2ioSuw6qE8roALyKiK4BV8IQiImqrXCb4K+qkGDpIiCUh0GTzI31XTmy20GQPFgq3R0USkeUQO2+3SoDlTG0+v2+rJU0g2hHNJFgOQakOh+qM5k671Jv0ksliN0pllwNnZrkRHnRgZgFHVAjyhEAcVceF08IAQgBZLAAaSwAEZ4biExnfVSaeR+G7efX4QPB-UYBtaPE9Kqfg0WoFnNOZyZaNE6W6V2vXImk-HbaHHtRBN8Rhmb37T8f6gRwnAJNiOdwXYw3R6vWe7QGBBBumg7hnAkY1nycabkmeZpg+M4XlewYzsmTy5k8MEZlmHI5qqSEFjhnILCWcJlrGla6CKAAkw5wLS-AIahdEMRhl6EeyxEwmRUGUTRLGjkxM5zgCC4iG6oJHjOd6hjJdpyXeIwjLQJi6MCqjMJYOg2LYtQhqI5QQKwDToOwkLUYItDVOZVKMDoOJDEoYCDFcQA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokrcQAxLoDCAEQCSAMreuvxQpFC6cAAesKgiSmERBsZc1AD6SVA2ieGRRroA7rSkABYq7Fm4uiBKuroAgr6BADIpumkYWYiIjE2tSgC+ihAAVkQq6QDWcKyilXm2BfxwJlDCpOkE-LSiBOnjkzNzwNDw81lyALruaxrpWiyi6VD8otTtZ2LsAGK01ORGOxdg4XNVRGh4hwssBgAowP0WvCrldqrsMHdSERGHJcUpHoxRO0CKUJgQxOlRHARBo4Px2ATaFB6CItqTaOSLnlYfDEcjUaZ1JsCc9Xu88RB3JD2ioSuw6qE8roALyKiK4BV8IQiImqrXCb4K+qkGDpIiCUh0GTzI31XTmy20GQPFgq3R0USkeUQO2+jpwbgYUjMCCiEzYmA9VAcqY2n1+31ZKmkG0I5pIsByDXxhPGgM8YNQUPhxiRxCM5k6725v0ksliN0VllwNn1rkRHlpgZgFHVAjyhEAcVceF08IAQgBZLAAaSwAEZ4bjszXfVSaeR+G7ecP4SvV-UYBtaPE9Kqfg0WoFnPuDyZaNE6W6L1fXDnc1nbQnOoXixGeo81CCN8Iw1qBfqfu+9QEOEcASNiHLcC6jBuh6XpfnaP4hmG-6INGBCxtWq5JnAKYDnyma3rmWFFjhpYASwTLNvMkEHoBwFxge9Qio2TxUTWdYcg2qrsS2gmcgsHZwl2Ga9roIoACTrnAtL8KxXHKapvFAWJ7ISTC0kUXJimaZu6kHkeAIniIbqgm+B7gQmjl2s54EjCMtAmLowKqMwlg6DYti1PGojlBArANOg7CQgpgi0NUMVUowOg4kMShgIMVxAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } diff --git a/man/tm_p_bargraph.Rd b/man/tm_p_bargraph.Rd deleted file mode 100644 index 921e24e8e..000000000 --- a/man/tm_p_bargraph.Rd +++ /dev/null @@ -1,82 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_bargraph.R -\name{tm_p_bargraph} -\alias{tm_p_bargraph} -\title{Bar Graph Module} -\usage{ -tm_p_bargraph( - label = "Bar Plot", - plot_dataname, - y_var, - color_var, - count_var, - tooltip_vars = NULL, - bar_colors = NULL -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{y_var}{(\code{character(1)}) Name of the categorical variable to be displayed on y-axis (bar categories).} - -\item{color_var}{(\code{character(1)}) Name of the categorical variable used for color coding and stacking segments.} - -\item{count_var}{(\code{character(1)}) Name of the variable whose distinct values will be counted for bar heights.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} -} -\description{ -This module creates an interactive horizontal stacked bar chart visualization that -displays counts of distinct values grouped by categories. The bars are automatically -ordered by total count (ascending) and support color coding by a categorical variable. -Users can select bar segments by brushing to filter the underlying data. The plot -aggregates data by counting distinct values within each group combination. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - adverse_event = sample(c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash"), - 100, - replace = TRUE, prob = c(0.3, 0.25, 0.2, 0.15, 0.1) - ), - severity = sample(c("Mild", "Moderate", "Severe"), 100, - replace = TRUE, - prob = c(0.6, 0.3, 0.1) - ), - subject_id = sample(paste0("S", 1:30), 100, replace = TRUE), - treatment = sample(c("Active", "Placebo"), 100, replace = TRUE) - ) - - # Add labels - attr(df$adverse_event, "label") <- "Adverse Event Type" - attr(df$severity, "label") <- "Severity Grade" - attr(df$subject_id, "label") <- "Subject ID" - attr(df$treatment, "label") <- "Treatment Group" - }) - -app <- init( - data = data, - modules = modules( - tm_p_bargraph( - label = "AE by Treatment", - plot_dataname = "df", - y_var = "adverse_event", - color_var = "treatment", - count_var = "subject_id", - bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), - tooltip_vars = c("adverse_event", "treatment") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd deleted file mode 100644 index a81bb4f77..000000000 --- a/man/tm_p_lineplot.Rd +++ /dev/null @@ -1,87 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_lineplot.R -\name{tm_p_lineplot} -\alias{tm_p_lineplot} -\title{Line Plot Module} -\usage{ -tm_p_lineplot( - label = "Line Plot", - x_var, - y_var, - color_var, - group_var, - colors = NULL, - tooltip_vars = NULL, - transformators = list(), - reference_lines = NULL -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} - -\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis (typically a measurement).} - -\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines.} - -\item{group_var}{(\code{character(1)}) Name of the grouping variable that defines which points to connect with lines.} - -\item{colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created showing group, x, y, and color variables.} - -\item{transformators}{(\code{list}) Named list of transformator functions.} - -\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification for adding horizontal reference lines.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} -} -\description{ -This module creates an interactive line plot visualization that connects data points -within groups to show trends over time. The plot displays both line segments connecting -points and individual markers, with support for customizable tooltips and color coding. -Optional reference lines can be added to highlight specific values. The plot can be -activated by brushing events from other plots when used in combination modules. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - subject_id = rep(paste0("S", 1:8), each = 5), - time_week = rep(c(0, 2, 4, 6, 8), 8), - measurement = rnorm(40, 20, 4) + rep(c(0, 1, 2, 3, 4), 8), - treatment = rep(c("Active", "Placebo"), each = 20), - baseline = rep(rnorm(8, 18, 2), each = 5) - ) - - # Add labels - attr(df$subject_id, "label") <- "Subject ID" - attr(df$time_week, "label") <- "Time (weeks)" - attr(df$measurement, "label") <- "Measurement Value" - attr(df$treatment, "label") <- "Treatment Group" - attr(df$baseline, "label") <- "Baseline Value" - }) - -# Basic line plot example -app <- init( - data = data, - modules = modules( - tm_p_lineplot( - label = "Line Plot", - plot_dataname = "df", - x_var = "time_week", - y_var = "measurement", - color_var = "treatment", - group_var = "subject_id", - tooltip_vars = c("subject_id", "time_week") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd deleted file mode 100644 index 7826bc4a8..000000000 --- a/man/tm_p_scatterplot.Rd +++ /dev/null @@ -1,82 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_scatterplot.R -\name{tm_p_scatterplot} -\alias{tm_p_scatterplot} -\title{Scatterplot Module} -\usage{ -tm_p_scatterplot( - label = "Scatter Plot", - subject_var, - x_var, - y_var, - color_var, - point_colors = character(0), - tooltip_vars = NULL, - transformators = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{subject_var}{(\code{character(1)}) Name of the subject variable.} - -\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis.} - -\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis.} - -\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points.} - -\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created showing x, y, and color variables.} - -\item{transformators}{(\code{list}) Named list of transformator functions.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} -} -\description{ -This module creates an interactive scatter plot visualization with customizable tooltips. -Users can select points by brushing to filter the underlying data. The plot supports -color coding by categorical variables and displays tooltips on hover that can show -default variables (subject, x, y, color) or custom columns specified via \code{tooltip_vars}. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - subject_id = paste0("S", 1:50), - age = sample(20:80, 50, replace = TRUE), - response = rnorm(50, 15, 3), - treatment = sample(c("Active", "Placebo"), 50, replace = TRUE), - gender = sample(c("M", "F"), 50, replace = TRUE) - ) - - # Add labels for better tooltips - attr(df$age, "label") <- "Age (years)" - attr(df$response, "label") <- "Response Score" - attr(df$treatment, "label") <- "Treatment Group" - }) - -app <- init( - data = data, - modules = modules( - tm_p_scatterplot( - label = "Scatter Plot with Custom Tooltip", - plot_dataname = "df", - subject_var = "subject_id", - x_var = "age", - y_var = "response", - color_var = "treatment", - tooltip_vars = c("age", "gender") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd deleted file mode 100644 index a65916807..000000000 --- a/man/tm_p_spaghetti.Rd +++ /dev/null @@ -1,85 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_spaghetti.R -\name{tm_p_spaghetti} -\alias{tm_p_spaghetti} -\title{Spaghetti Plot Module} -\usage{ -tm_p_spaghetti( - label = "Scatter Plot", - group_var, - x_var, - y_var, - color_var, - point_colors = character(0), - tooltip_vars = NULL, - transformators = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} - -\item{group_var}{(\code{character(1)}) Name of the grouping variable that defines individual trajectories.} - -\item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis (typically time).} - -\item{y_var}{(\code{character(1)}) Name of the variable to be used for y-axis (typically a measurement).} - -\item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points and lines.} - -\item{point_colors}{(\verb{named character}) Valid color names or hex-colors named by levels of color_var column.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created showing group, x, y, and color variables.} - -\item{transformators}{(\code{list}) Named list of transformator functions.} - -\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} - -\item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} -} -\description{ -This module creates an interactive spaghetti plot visualization that shows individual -trajectories for each group over time. Each trajectory is represented by connected -points and lines, creating a "spaghetti-like" appearance. The plot supports customizable -tooltips and color coding by categorical variables. Users can select points by brushing -to filter the underlying data. -} -\examples{ -data <- teal_data() |> - within({ - df <- data.frame( - subject_id = rep(paste0("S", 1:10), each = 4), - time_point = rep(c(0, 30, 60, 90), 10), - response = rnorm(40, 15, 3) + rep(c(0, 2, 4, 6), 10), - treatment = rep(c("Active", "Placebo"), each = 20), - age_group = rep(c("Young", "Old"), 20) - ) - - # Add labels - attr(df$subject_id, "label") <- "Subject ID" - attr(df$time_point, "label") <- "Time Point (days)" - attr(df$response, "label") <- "Response Score" - attr(df$treatment, "label") <- "Treatment Group" - }) - -# Default tooltip example -app <- init( - data = data, - modules = modules( - tm_p_spaghetti( - label = "Spaghetti Plot", - plot_dataname = "df", - group_var = "subject_id", - x_var = "time_point", - y_var = "response", - color_var = "treatment", - tooltip_vars = c("subject_id", "treatment") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd deleted file mode 100644 index 1f8cdcce3..000000000 --- a/man/tm_p_spiderplot.Rd +++ /dev/null @@ -1,129 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_spiderplot.R -\name{tm_p_spiderplot} -\alias{tm_p_spiderplot} -\title{\code{teal} module: Spider Plot} -\usage{ -tm_p_spiderplot( - label = "Spiderplot", - time_var, - value_var, - subject_var, - color_var, - size_var = NULL, - tooltip_vars = NULL, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(600, 400, 1200), - transformators = list(), - decorators = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{time_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column -in \code{plot_dataname} to be used as x-axis.} - -\item{value_var}{(\code{character(1)} or \code{variables}) name of the \code{numeric} column -in \code{plot_dataname} to be used as y-axis.} - -\item{subject_var}{(\code{character(1)} or \code{variables}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as grouping variable for displayed lines/points.} - -\item{color_var}{(\code{character(1)} or \code{variables}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used to differentiate colors and symbols.} - -\item{size_var}{(\code{character(1)} or \code{variables} or \code{NULL}) If provided, this numeric column from the \code{plot_dataname} -will be used to determine the size of the points. If \code{NULL}, a fixed size based on the \code{point_size} is used.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var}column.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - -\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -(named \code{list} of lists of \code{teal_transform_module}) optional, -decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects.} -} -\description{ -Module visualizes value development in time grouped by subjects. -} -\examples{ -library(teal.transform) -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - swimlane_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = sample(1:100, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - - spiderplot_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = 1:10, - filter_event_var = "response", - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE), - value_var = sample(-50:100, 10, replace = TRUE) - ) - - waterfall_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - value_var = sample(-20:90, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_p_spiderplot( - plot_dataname = "spiderplot_ds", - table_datanames = "subjects", - time_var = picks(datasets("spiderplot_ds"), variables("time_var")), - value_var = picks(datasets("spiderplot_ds"), variables("value_var")), - subject_var = picks(datasets("spiderplot_ds"), variables("subject_var")), - color_var = picks(datasets("spiderplot_ds"), variables("color_var")), - transformators = list( - teal_transform_filter( - picks( - datasets("spiderplot_ds"), variables("filter_event_var"), values() - ) - ) - ), - point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ), - point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ), - tooltip_vars = c("subject_var") - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd deleted file mode 100644 index 85f7598fc..000000000 --- a/man/tm_p_swimlane.Rd +++ /dev/null @@ -1,108 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_swimlane.R -\name{tm_p_swimlane} -\alias{tm_p_swimlane} -\title{\code{teal} module: Swimlane plot} -\usage{ -tm_p_swimlane( - label = "Swimlane", - plot_dataname, - time_var, - subject_var, - color_var, - group_var, - sort_var = time_var, - tooltip_vars = NULL, - point_size = 10, - point_colors = character(0), - point_symbols = character(0), - plot_height = c(700, 400, 1200), - show_widgets = TRUE -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)} or \code{choices_selected}) name of the dataset which visualization is builded on.} - -\item{time_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as x-axis.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as y-axis.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to name and color subject events in time.} - -\item{group_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to categorize type of event. -(legend is sorted according to this variable, and used in toolip to display type of the event) -todo: this can be fixed by ordering factor levels} - -\item{sort_var}{(\code{character(1)} or \code{choices_selected}) name(s) of the column in \code{plot_dataname} which -value determines order of the subjects displayed on the y-axis.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size of the points in the plot. -If \code{point_size} is a named numeric vector, it should be named by levels of \code{color_var} column.} - -\item{point_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -} -\description{ -Module visualizes subjects' events in time. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - swimlane_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - time_var = sample(1:100, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "swimlane_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_p_swimlane( - plot_dataname = "swimlane_ds", - time_var = "time_var", - subject_var = "subject_var", - color_var = "color_var", - group_var = "color_var", - sort_var = "time_var", - plot_height = c(700, 400, 1200), - tooltip_vars = c("subject_var", "color_var"), - point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ), - point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd deleted file mode 100644 index eabdeea88..000000000 --- a/man/tm_p_waterfall.Rd +++ /dev/null @@ -1,94 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_p_waterfall.R -\name{tm_p_waterfall} -\alias{tm_p_waterfall} -\title{\code{teal} module: Waterfall plot} -\usage{ -tm_p_waterfall( - label = "Waterfall", - plot_dataname, - subject_var, - value_var, - sort_var = NULL, - color_var = NULL, - tooltip_vars = NULL, - bar_colors = character(0), - value_arbitrary_hlines = c(0.2, -0.3), - plot_title = "Waterfall plot", - plot_height = c(600, 400, 1200) -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{plot_dataname}{(\code{character(1)}) name of the dataset which visualization is builded on.} - -\item{subject_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column -in \code{plot_dataname} to be used as x-axis.} - -\item{value_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{numeric} column -in \code{plot_dataname} to be used as y-axis.} - -\item{color_var}{(\code{character(1)} or \code{choices_selected}) name of the \code{factor} or \code{character} column in \code{plot_dataname} -to be used to differentiate bar colors.} - -\item{tooltip_vars}{(\code{character} or \code{NULL}) A vector of column names to be displayed in the tooltip. -If \code{NULL}, default tooltip is created.} - -\item{bar_colors}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named -by levels of \code{color_var} column.} - -\item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal -lines on the plot.} - -\item{plot_title}{(\code{character}) Title of the plot.} - -\item{plot_height}{(\code{numeric}) optional, specifies the plot height as a three-element vector of -\code{value}, \code{min}, and \code{max} intended for use with a slider UI element.} -} -\description{ -Module visualizes subjects sorted decreasingly by y-values. -} -\examples{ -data <- teal_data() |> - within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") - ) - - waterfall_ds <- data.frame( - subject_var = sample(c("A", "B", "C"), 10, replace = TRUE), - value_var = sample(-20:90, 10, replace = TRUE), - color_var = sample(c("CR", "PR", "SD", "PD"), 10, replace = TRUE) - ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "waterfall_ds", keys = c(subject_var = "subject_var")) -) - -app <- init( - data = data, - modules = modules( - tm_p_waterfall( - plot_dataname = "waterfall_ds", - subject_var = "subject_var", - value_var = "value_var", - sort_var = "value_var", - color_var = "color_var", - tooltip_vars = c("value_var", "subjects"), - value_arbitrary_hlines = c(20, -30), - bar_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ) - ) - ) -) - -if (interactive()) { - shinyApp(app$ui, app$server) -} - -} diff --git a/man/tm_rmarkdown.Rd b/man/tm_rmarkdown.Rd deleted file mode 100644 index 7b0c159ab..000000000 --- a/man/tm_rmarkdown.Rd +++ /dev/null @@ -1,59 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_markdown.R -\name{tm_rmarkdown} -\alias{tm_rmarkdown} -\title{\code{teal} module: Rmarkdown page} -\usage{ -tm_rmarkdown( - label = "App Info", - text = character(0), - params = list(title = "Document"), - datanames = "all" -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{text}{(\code{character}) arbitrary Rmd code} - -\item{params}{A list of named parameters that override custom params -specified within the YAML front-matter (e.g. specifying a dataset to read or -a date range to confine output to). Pass \code{"ask"} to start an -application that helps guide parameter configuration.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} -} -\value{ -Object of class \code{teal_module} to be used in \code{teal} applications. -} -\description{ -Render arbitrary Rmarkdown code. \code{data} provided to teal application are available in the -rendered document. -} -\examples{ -data <- teal_data() |> - within({ - iris <- iris - mtcars <- mtcars - }) -# - -} -\section{Examples in Shinylive}{ -\describe{ - \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqX8opKAeNdqAfQ8vG10AHwA+JV1dAHdaUgALFXYQKOjdWkZaUR8MrNE06JhSAhYco11i0sYCiGiAX0UIAGIlMHqAXSA}{Open in Shinylive} - \if{html}{\out{}} - \if{html}{\out{}} - } -} -} - diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index d939f1401..ccce911e0 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -6,7 +6,9 @@ \usage{ tm_t_crosstable( label = "Cross Table", - x, + x = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices + = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple + = TRUE, ordered = TRUE), teal.transform::values()), y, show_percentage = TRUE, show_total = TRUE, @@ -24,7 +26,7 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{x}{(\code{picks} or \code{list} of \code{picks}) Object with all available choices with pre-selected option for variable X - row values. -In case of \code{picks} use \code{variables(..., ordered = TRUE)} if table elements should be +In case of \code{picks} use \code{teal.transform::variables(..., ordered = TRUE)} if table elements should be rendered according to selection order.} \item{y}{(\code{picks} or \code{list} of multiple \code{picks}) @@ -130,26 +132,26 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = picks( + x = teal.transform::picks( datasets("mtcars"), - variables( + teal.transform::variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = c("cyl", "gear"), multiple = TRUE, ordered = TRUE, fixed = FALSE ), - values() + teal.transform::values() ), - y = picks( + y = teal.transform::picks( datasets("mtcars"), - variables( + teal.transform::variables( choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), selected = "vs", multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ) ) ) @@ -170,9 +172,9 @@ app <- init( modules = modules( tm_t_crosstable( label = "Cross Table", - x = picks( + x = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) return(names(data)[idx]) @@ -182,11 +184,11 @@ app <- init( ordered = TRUE, fixed = FALSE ), - values() + teal.transform::values() ), - y = picks( + y = teal.transform::picks( datasets("ADSL"), - variables( + teal.transform::variables( choices = variable_choices(data[["ADSL"]], subset = function(data) { idx <- vapply(data, is.factor, logical(1)) return(names(data)[idx]) @@ -195,7 +197,7 @@ app <- init( multiple = FALSE, fixed = FALSE ), - values() + teal.transform::values() ) ) ) @@ -208,13 +210,13 @@ if (interactive()) { \section{Examples in Shinylive}{ \describe{ \item{example-1}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIK1C0Aj-FUPE2VFLg0gq5kohlyaV+-1aFi0J1iY3+k0EfI4gjyiUxr7x7Wpr0JlLvUObBkHUp9AYEIas8asmaMuZwBZgJaRpMm8EiDRwfgKiuDYYNsDzRiLNvt9bCTSRPQShwuccTtr8GQ9hXz5yL9smWihNcSgBiAEEADIAZVcUZNEddJpj1EECfuSZvV90rA9Xp9iaTgbgwf6YtmhbLc71jeNfQnSoUzTDNdCzONDTgXNYIJQtgDpMMQT2ctAKrQdRjAWsh3rQiR25UD-U7OBu17a0iIZSiTRgKdaBnBVj3PTdb39Hc9zo3ROIvHjKlfCd70fAln39aTRJae57loEwOhUchmEsHQbGWFpREKCBWCPdB2D5AASQRaFKUzwUYHRGHuZ4IDAR49iAA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXVIhrqu-lCkULpwAB6wqCJKAUEGxlzUAPoxUDbRgcFGugDutKQAFirsKbi6IEq6ujCkBCyicVU1dRWmRIy67Fq6KroE7AqErNQDpQNaoiO6A7CTA1IsA3K25RCVldW1jKLAwFoAunsNUOIm6qRt7Bt1O-t7iqu6AL4tV1s7A6iMtDAsrIkA1nBWAMDg1RHAAI6JEQQdgQRhEbKXJpbJZKR73ABWRBUAKBomKGVsWWxuMBrAJpIgeI4A1eEzwUzA9NmYE+31+NMW9yUaFQDRUeX6DxSugAvP4MrgXgJhGJxVVZSICS1KqQYIlSIkCAjRKIgvQRMK1mtqFB6HA-BKBgBhXX1OzmqJ4VVrUIKhIYUjMCCiExtGCIRCoWgEf4qh4myopcGkFXMlEMuTSyNRz3eqC+-2MQOILQsWhOsTGqMmgj5HEEeUS-NfIvaiuh4spd4JzYMg6lPoDAhDVnjVkzRlzOALMBLFOlk3gkQaOD8BXdwbDYdgeaMRaTqfrYSaSJ6CUOFxb7dtfgyecKo-OE9Tky0UKXiUAMQAggAZADKrlTJuTrpNdMfT9AMg3zahBGLe5S3-X9dFYD1Rx4DMs1A4NQ3DEtSxjOA436NtmnHW9AKQr1gOzXNa0LQ1iwAqNy0ratdCo+sGKbAkW2AOlExBPYu3w3sV1GMAB1XIdhPXbliKjGc4DnBdrREhlpJNGBd1ofcFTfL8bzok170fBTdG0789N0WDtyAzMQJzMDuEggloKjJzKic+57loEwOhUchmEsHQbGWFpREKCBWFfdB2D5AASQRaFKGLwUYHRGHuZ4IDAR49iAA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } \item{example-2}{ - \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBqFoBEmcwp6M+UFEcFIDLAfWa+Lk33BTLqWhYtFJoMZAoIJXGBDEgKFjBFKLgmyltNBmWAwHxXPxl0uVVEgnorNIgLMFk01gu1XFAt0tH4VPyAEIhehqBxKvaICUZMVRFVqEQJLTuOwAIy83QEJ5gHxhOD4qr4gAKAHkAn4ABoaJO6VMZ7PUUg84Z2pmMNmCRgQdindULYAOqKXMvl3RDPnt3SskQaOD8PEEtOOAByDgAmknbeiYOtaHE9B8HC4u+2iIxlpXB8unM41+WTLQogPAQAxerNAKufkC3kz3RC6iCUFt9H328Q1jU2n0tF2zITQ5HUwA-ct5UVf5-3LSVpVlD4INFFU4POXJNW1JpuTAPUDSNE0zXMSwrQWG1P3LZs2jdOJPVyKodgwVYNA3QNg1DagIzkN920rUhq1retUPCOQm0dVsHzqTtxJ7HE4H7Hd8zAa8s2nMimTnYsFxEc9L2vA87SPE95IvK8b3LMC7SfF85i4uouLbYZhloExdHYFRyGYSwdBsWwan5UQyggVh6nQdg0FQAASQRaCqMLwtZRgdEYYYBiUMABkuIA}{Open in Shinylive} - \if{html}{\out{}} + \href{https://shinylive.io/r/app/#code=NobwRAdghgtgpmAXGKAHVA6ASmANGAYwHsIAXOMpMAGwEsAjAJykYE8AKcqajGIgEwCu1OAGcMAcwpxm1AJQAdCLTIyoBUrQBucAAQAeALS6AZoIgbaJdnN0AVLAFUAokqUBiXQGEAIgEkAZS9dfihSKF04AA9YVBElUPCDYy5qAH1EqBsEsIijXQB3WlIACxV2TNxdECVdXQBBHwCAGWTdVIxMxERGRpalAF9FCAArIhU0gGs4VlEK3Nt8-jgTKGFSNIJ+WlECNLGJ6dngaHg5zLkAXTdodDaVYvZakNzdAF4X8NxnviERUXeul+wjETwgdTqpBgaQ2BEYRFEonC9BEYIhEOoUHocGogIUYC88MR9ix8Twz3RUUBHVIzAgohMREYMG6qFoBEmcwp6M+UFEcFIXLAfWa+Lk33BPMhcG4GFpUHpjOZ3S0LFopNB3KlBBK4wIYkBqsY6pRcE2uvZoMywGA+JF+MulyqokE9H5pEBZgsmmsF2qWqlulo-Cp+QAhKr0NQOJUgxASjJiqIqtQiBJ2dx2ABGcW6AhPMA+MJwfFVfEABQA8gE-AANDSl3QV6t16ikMXDQM8xgCwSMCDsU5WhbAYNRS6dru6IYSqe6fkiDRwfh4gmVxwAOQcAE1SwH0TB1rQ4noPg4XLOp0zlj2V2enM5L12TLQosvAQAxerNAKuSVS8V93aGUeHlRUmRZRBVWoQRQUndFAP-CFWGpEC5TpBkINZdlOTRQNMndIV7TARCuxpDClUgo0TX+PCux1PUDQ+aiNXNRjzlyG07SaUUwEdZ1XXdT1zEsX0Fn9JCuzHNpIziGNciqHYMFWDQmRTNMM2obM5Hgqce1IPsByHDjwjkUcQwnIC6hnKz5xxOAlzvJswF-Ws90knlDzbY8RE-b9fyfQMXzfJyvx-P8u1IwNyIVTDlSg7hYLmXS6l0ydhmGWgTF0dgVHIZhLB0GxbBqSVRDKCBWHqdB2DQVAABJBFoKo6vq-lGB0RhhgGJQwAGS4gA}{Open in Shinylive} + \if{html}{\out{}} \if{html}{\out{}} } } From f8b884f35add91bab3ca940c82d418aefd0a2497 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Thu, 30 Oct 2025 14:58:14 +0000 Subject: [PATCH 150/158] [skip style] [skip vbump] Restyle files --- R/module_colur_picker.R | 1 - R/tm_g_bivariate_picks.R | 1 - R/tm_t_reactable.R | 5 +++-- R/utils.R | 3 ++- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 06fbe2b94..8667f3bba 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -58,7 +58,6 @@ colour_picker_srv <- function(id, x, default_colors) { } - #' Color palette discrete #' #' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 93a16d489..103411b93 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -386,7 +386,6 @@ srv_g_bivariate.picks <- function(id, teal::validate_has_data(anl[, c(x_name, y_name), drop = FALSE], 3, complete = TRUE, allow_inf = FALSE) - cl <- bivariate_plot_call( data_name = "anl", x = x_name, diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index bba18b681..d19a5c39d 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -34,8 +34,9 @@ ui_t_reactables <- function(id, decorators = list()) { } srv_t_reactables <- function( - id, data, filter_panel_api, datanames, - colnames = list(), decorators = list(), reactable_args = list()) { + id, data, filter_panel_api, datanames, + colnames = list(), decorators = list(), reactable_args = list() +) { moduleServer(id, function(input, output, session) { datanames_r <- .validate_datanames(datanames = datanames, data = data) colnames_r <- reactive({ diff --git a/R/utils.R b/R/utils.R index 8e2026ed8..548862f67 100644 --- a/R/utils.R +++ b/R/utils.R @@ -450,7 +450,8 @@ children <- function(x, dataset_name = character(0)) { #' @param plotly_selected (`reactive`) #' @param children_datanames (`character`) .plotly_selected_filter_children <- function( - data, plot_dataname, xvar, yvar, plotly_selected, children_datanames) { + data, plot_dataname, xvar, yvar, plotly_selected, children_datanames +) { xvar_r <- if (is.reactive(xvar)) xvar else reactive(xvar) yvar_r <- if (is.reactive(yvar)) yvar else reactive(yvar) From f7b6c2c60d059ee3c68448ad99da0188e60ad134 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Fri, 31 Oct 2025 09:10:16 +0100 Subject: [PATCH 151/158] cleanup fix defaults --- DESCRIPTION | 9 +- NAMESPACE | 1 - R/module_colur_picker.R | 128 - R/tm_g_scatterplot_picks.R | 6 +- R/tm_t_crosstable_picks.R | 6 +- R/tm_t_reactable.R | 316 -- R/utils.R | 184 - inst/css/reactable.css | 7 - inst/poc_adam.r | 69 - inst/poc_adam_plotly.r | 43 - inst/poc_crf.R | 533 -- inst/poc_crf2.R | 765 --- inst/poc_osprey.R | 75 - inst/swimlane_poc.R | 71 - inst/teal_app.lock | 5853 -------------------- inst/triggerTooltips/triggerTooltips.css | 43 - inst/triggerTooltips/triggerTooltips.js | 31 - man/dot-color_palette_discrete.Rd | 21 - man/dot-make_reactable_columns_call.Rd | 24 - man/dot-plotly_selected_filter_children.Rd | 35 - man/tm_t_reactables.Rd | 41 - 21 files changed, 6 insertions(+), 8255 deletions(-) delete mode 100644 R/module_colur_picker.R delete mode 100644 R/tm_t_reactable.R delete mode 100644 inst/css/reactable.css delete mode 100644 inst/poc_adam.r delete mode 100644 inst/poc_adam_plotly.r delete mode 100644 inst/poc_crf.R delete mode 100644 inst/poc_crf2.R delete mode 100644 inst/poc_osprey.R delete mode 100644 inst/swimlane_poc.R delete mode 100644 inst/teal_app.lock delete mode 100644 inst/triggerTooltips/triggerTooltips.css delete mode 100644 inst/triggerTooltips/triggerTooltips.js delete mode 100644 man/dot-color_palette_discrete.Rd delete mode 100644 man/dot-make_reactable_columns_call.Rd delete mode 100644 man/dot-plotly_selected_filter_children.Rd delete mode 100644 man/tm_t_reactables.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 9b57341f6..7ba3e4dea 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,6 @@ Depends: Imports: bslib (>= 0.8.0), checkmate (>= 2.1.0), - colorspace, colourpicker (>= 1.3.0), dplyr (>= 1.0.5), DT (>= 0.13), @@ -42,20 +41,14 @@ Imports: ggpp (>= 0.5.8-1), ggrepel (>= 0.9.6), goftest (>= 1.2-3), - graphics, - grDevices, grid, gridExtra (>= 2.3), - htmltools, htmlwidgets (>= 1.6.4), jsonlite (>= 1.8.9), lattice (>= 0.18-4), lifecycle (>= 0.2.0), MASS (>= 7.3-60), - plotly, - reactable, - rlang (>= 1.0.0), - rmarkdown (>= 2.23), + rlang, rtables (>= 0.6.11), scales (>= 1.3.0), shinyjs (>= 2.1.0), diff --git a/NAMESPACE b/NAMESPACE index 400e5fe22..a400bd6c3 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,7 +42,6 @@ export(tm_g_scatterplotmatrix) export(tm_missing_data) export(tm_outliers) export(tm_t_crosstable) -export(tm_t_reactables) export(tm_variable_browser) import(ggplot2) import(shiny) diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R deleted file mode 100644 index 8667f3bba..000000000 --- a/R/module_colur_picker.R +++ /dev/null @@ -1,128 +0,0 @@ -# todo: to teal widgets? - -colour_picker_ui <- function(id) { - ns <- NS(id) - bslib::popover( - actionButton(ns("toggle"), "Edit colors"), - uiOutput(ns("module")) - ) -} - -colour_picker_srv <- function(id, x, default_colors) { - moduleServer(id, function(input, output, session) { - default_colors_adjusted <- reactive({ - req(x()) - .color_palette_discrete( - levels = unique(x()), - color = default_colors - ) - }) - - color_values <- reactiveVal() - observeEvent(default_colors_adjusted(), { - if (!identical(default_colors_adjusted(), color_values())) { - color_values(default_colors_adjusted()) - } - }) - - output$module <- renderUI({ - tagList( - lapply( - names(color_values()), - function(level) { - div( - colourpicker::colourInput( - inputId = session$ns(.name_to_id(level)), - label = level, - value = color_values()[level] - ) - ) - } - ) - ) - }) - - color_input_values <- reactiveVal() - observe({ - req(color_values()) - new_input_values <- sapply(names(color_values()), function(level) { - c(input[[.name_to_id(level)]], color_values()[[level]])[1] - }) - if (!identical(new_input_values, isolate(color_input_values()))) { - isolate(color_input_values(new_input_values)) - } - }) - - color_input_values - }) -} - - -#' Color palette discrete -#' -#' To specify custom discrete colors to `plotly` or `ggplot` elements one needs to specify a vector named by -#' levels of variable used for coloring. This function allows to specify only some or none of the colors/levels -#' as the rest will be filled automatically. -#' @param levels (`character`) values of possible variable levels -#' @param color (`named character`) valid color names (see [colors()]) or hex-colors named by `levels`. -#' @return `character` with hex colors named by `levels`. -.color_palette_discrete <- function(levels, color) { - p <- color[names(color) %in% levels] - - if (length(p) > 0) { - p_rgb_num <- grDevices::col2rgb(p) - p_hex <- grDevices::rgb(p_rgb_num[1, ] / 255, p_rgb_num[2, ] / 255, p_rgb_num[3, ] / 255) - p <- stats::setNames(p_hex, names(p)) - } - - missing_levels <- setdiff(levels, names(p)) - N <- length(levels) - n <- length(p) - m <- N - n - - if (m > 0 && n > 0) { - all_colors <- colorspace::qualitative_hcl(N) - - if (n == 1) { - current_color_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(p)) - all_colors_hsv <- grDevices::rgb2hsv(grDevices::col2rgb(all_colors)) - - distances <- numeric(length(all_colors)) - for (i in seq_along(all_colors)) { - h_diff <- min( - abs(current_color_hsv[1] - all_colors_hsv[1, i]), - 1 - abs(current_color_hsv[1] - all_colors_hsv[1, i]) - ) - s_diff <- abs(current_color_hsv[2] - all_colors_hsv[2, i]) - v_diff <- abs(current_color_hsv[3] - all_colors_hsv[3, i]) - distances[i] <- sqrt(h_diff^2 + s_diff^2 + v_diff^2) - } - - idx <- order(distances, decreasing = TRUE)[seq_len(m)] - missing_colors <- all_colors[idx] - } else { - remaining_colors <- all_colors[seq_len(m)] - missing_colors <- remaining_colors - } - - p <- c(p, stats::setNames(missing_colors, missing_levels)) - } else if (m > 0) { - missing_colors <- colorspace::qualitative_hcl(m) - p <- stats::setNames(missing_colors, missing_levels) - } - - result <- p[match(levels, names(p))] - stats::setNames(result, levels) -} - - -.shape_palette_discrete <- function(levels, symbol) { - if (length(symbol) == 0) { - s <- rep("circle-open", length(levels)) - s <- stats::setNames(s, levels) - } else { - s <- stats::setNames(symbol[levels], levels) - s[is.na(s)] <- "circle-open" - } - s -} diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index be6f8d627..4a3b883e5 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -32,8 +32,7 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", teal.transform::datasets(), teal.transform::variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = NULL, - multiple = TRUE + selected = NULL ), teal.transform::values() ), @@ -41,8 +40,7 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", teal.transform::datasets(), teal.transform::variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = NULL, - multiple = TRUE + selected = NULL ), teal.transform::values() ), diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index c5eb85423..cc6db627a 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -12,7 +12,7 @@ tm_t_crosstable.picks <- function(label = "Cross Table", teal.transform::datasets(), teal.transform::variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), - selected = 2L, multiple = TRUE, ordered = TRUE + selected = 2L, ordered = TRUE ), teal.transform::values() ), @@ -147,7 +147,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b selectors$y() }, handlerExpr = { - if (identical(selectors$x()$datasets$selected, selectors$x()$datasets$selected)) { + if (identical(selectors$x()$datasets$selected, selectors$y()$datasets$selected)) { shinyjs::hide("join_fun") } else { shinyjs::show("join_fun") @@ -160,7 +160,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b data = validated_q, selectors = selectors, output_name = "anl", - join_fun = input$join_fun # todo: make reactive + join_fun = isolate(input$join_fun) # todo: make reactive ) output_q <- reactive({ diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R deleted file mode 100644 index d19a5c39d..000000000 --- a/R/tm_t_reactable.R +++ /dev/null @@ -1,316 +0,0 @@ -#' `teal` module: Reactable -#' -#' Wrapper module on [reactable::reactable()] -#' -#' @inheritParams teal::module -#' @inheritParams shared_params -#' @param reactable_args (`list`) any argument of [reactable::reactable()]. -#' @export -tm_t_reactables <- function(label = "Table", - datanames = "all", - colnames = list(), - transformators = list(), - decorators = list(), - reactable_args = list()) { - module( - label = label, - ui = ui_t_reactables, - server = srv_t_reactables, - ui_args = list(decorators = decorators), - server_args = list( - datanames = datanames, - colnames = colnames, - reactable_args = reactable_args, - decorators = decorators - ), - datanames = datanames, - transformators = transformators - ) -} - -ui_t_reactables <- function(id, decorators = list()) { - ns <- NS(id) - uiOutput(ns("subtables"), container = div) -} - -srv_t_reactables <- function( - id, data, filter_panel_api, datanames, - colnames = list(), decorators = list(), reactable_args = list() -) { - moduleServer(id, function(input, output, session) { - datanames_r <- .validate_datanames(datanames = datanames, data = data) - colnames_r <- reactive({ - req(datanames_r()) - sapply(datanames_r(), function(dataname) { - if (length(colnames[[dataname]])) { - colnames()[[dataname]] - } else { - colnames(isolate(data())[[dataname]]) - } - }) - }) - - datalabels_r <- reactive({ - req(datanames_r()) - sapply(datanames_r(), function(dataname) { - datalabel <- attr(isolate(data())[[dataname]], "label") - if (length(datalabel)) datalabel else dataname - }) - }) - - output$subtables <- renderUI({ - logger::log_debug("srv_t_reactables@1 render subtables") - if (length(datanames_r()) == 0) { - return(NULL) - } - div( - htmltools::htmlDependency( - name = "teal-modules-general-reactable", - version = utils::packageVersion("teal.modules.general"), - package = "teal.modules.general", - src = "css", - stylesheet = "reactable.css" - ), - do.call( - bslib::accordion, - c( - list(id = session$ns("reactables"), class = "teal-modules-general reactable-accordion"), - lapply( - datanames_r(), - function(dataname) { - bslib::accordion_panel( - title = datalabels_r()[dataname], - ui_t_reactable(session$ns(dataname)) - ) - } - ) - ) - ) - ) - }) - - called_datanames <- reactiveVal() - observeEvent(datanames_r(), { - lapply( - setdiff(datanames_r(), called_datanames()), # call module only once per dataname - function(dataname) { - srv_t_reactable( - dataname, - data = data, - dataname = dataname, - filter_panel_api = filter_panel_api, - colnames = colnames[[dataname]], - reactable_args = reactable_args - ) - } - ) - called_datanames(union(called_datanames(), datanames_r())) - }) - }) -} - -ui_t_reactable <- function(id) { - ns <- NS(id) - - input <- shinyWidgets::pickerInput( - ns("colnames"), - label = NULL, - choices = NULL, - selected = NULL, - multiple = TRUE, - width = "100%", - options = shinyWidgets::pickerOptions( - actionsBox = TRUE, - `show-subtext` = TRUE, - countSelectedText = TRUE, - liveSearch = TRUE, - container = "body" - ) - ) - - # input <- actionButton(ns("show_select_colnames"), "Nothing selected", class = "rounded-pill btn-sm primary") |> - # bslib::popover(input) - bslib::page_fluid( - input, - bslib::card( - class = "teal-modules-general reactable-card", - full_screen = TRUE, - reactable::reactableOutput(ns("table")) - ) - ) -} - -srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, decorators, reactable_args = list()) { - moduleServer(id, function(input, output, session) { - logger::log_debug("srv_t_reactable initializing for dataname: { dataname }") - dataname_reactable <- sprintf("%s_reactable", dataname) - - dataset_labels <- reactive({ - req(data()) - teal.data::col_labels(data()[[dataname]], fill = TRUE) - }) - - reactable_args_r <- if (is.reactive(reactable_args)) reactable_args else reactive(reactable_args) - - cols_choices <- reactiveVal() - cols_selected <- reactiveVal() - observeEvent(dataset_labels(), { - req(dataset_labels()) - choices <- if (length(colnames)) { - colnames - } else { - names(dataset_labels()) - } - labels_choices <- dataset_labels()[choices] - cols_choices_new <- stats::setNames(choices, labels_choices) - if (!identical(cols_choices_new, cols_choices())) { - logger::log_debug("srv_t_reactable@1 update column choices") - shinyWidgets::updatePickerInput( - inputId = "colnames", - choices = cols_choices_new, - selected = cols_choices_new - ) - cols_choices(cols_choices_new) - cols_selected(cols_choices_new) - } - }) - observeEvent(input$colnames_open, `if`(!isTruthy(input$colnames_open), cols_selected(input$colnames))) - observeEvent(cols_selected(), { - updateActionButton( - inputId = "show_select_colnames", - label = paste(substring(toString(cols_selected()), 1, 100), "...") - ) - }) - - table_q <- reactive({ - req(cols_selected()) - select_call <- as.call( - c( - list(name = str2lang("dplyr::select"), .data = str2lang(dataname)), - lapply(unname(cols_selected()), str2lang) - ) - ) - - reactable_call <- .make_reactable_call( - dataset = data()[[dataname]][cols_selected()], - dataname = dataname, - args = reactable_args_r() - ) - - data() |> - within(lhs <- rhs, lhs = str2lang(dataname), rhs = select_call) |> - within(lhs <- rhs, lhs = str2lang(dataname_reactable), rhs = reactable_call) - }) - output$table <- reactable::renderReactable({ - logger::log_debug("srv_t_reactable@2 render table for dataset { dataname }") - table_q()[[dataname_reactable]] - }) - - # todo: add select -> show children table - table_selected_q <- reactive({ - selected_row <- reactable::getReactableState("table", "selected") - if (!is.null(selected_row)) { - within( - table_q(), - selected_row = selected_row, - dataname_selected = str2lang(sprintf("%s_selected", dataname)), - dataname = str2lang(dataname), - expr = { - dataname_selected <- dataname[selected_row, ] - } - ) - } else { - table_q() - } - }) - - table_selected_q - }) -} - -.make_reactable_call <- function(dataset, dataname, args) { - columns <- .make_reactable_columns_call(dataset = dataset, col_defs = args$columns) - call_args <- utils::modifyList( - list(columns = columns, onClick = "select", selection = "multiple"), - args[!names(args) %in% "columns"] - ) - as.call( - c( - list( - name = quote(reactable::reactable), - data = str2lang(dataname) - ), - call_args - ) - ) -} - -#' Makes `reactable::colDef` call containing: -#' name = -#' cell = -#' Arguments of [reactable::colDef()] are specified only if necessary -#' @param dataset (`data.frame`) -#' @return named list of `colDef` calls -#' @keywords internal -.make_reactable_columns_call <- function(dataset, col_defs) { - checkmate::assert_data_frame(dataset) - args <- lapply( - colnames(dataset), - function(i) { - column <- dataset[[i]] - label <- attr(column, "label") - is_labelled <- length(label) == 1 && !is.na(label) && !identical(label, "") - default_col_def <- if (is_labelled) list(name = label) else list() - col_def_override <- if (!is.null(col_defs[[i]])) col_defs[[i]] else list() - col_def_args <- utils::modifyList(default_col_def, col_def_override) - if (length(col_def_args)) { - as.call( - c( - list(quote(colDef)), - col_def_args - ) - ) - } - } - ) - names(args) <- names(dataset) - Filter(length, args) -} - -.name_to_id <- function(name) { - gsub("[[:space:][:punct:]]+", "_", x = tolower(name)) -} - -.validate_datanames <- function(datanames, data, class = "data.frame") { - all_datanames_r <- reactive({ - req(data()) - names( - Filter( - function(dataset) inherits(dataset, class), - as.list(data()) - ) - ) - }) - - this_datanames_r <- reactive({ - if (is.reactive(datanames)) { - datanames() - } else { - datanames - } - }) - - datanames_r <- reactiveVal() - - observeEvent(all_datanames_r(), { - new_datanames <- if (identical(this_datanames_r(), "all")) { - all_datanames_r() - } else { - intersect(this_datanames_r(), all_datanames_r()) - } - if (!identical(new_datanames, datanames_r())) { - datanames_r(new_datanames) - } - }) - datanames_r -} diff --git a/R/utils.R b/R/utils.R index 548862f67..4fbe862eb 100644 --- a/R/utils.R +++ b/R/utils.R @@ -411,106 +411,6 @@ set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { q }) } -# todo: to teal_data -children <- function(x, dataset_name = character(0)) { - checkmate::assert_multi_class(x, c("teal_data", "join_keys")) - checkmate::assert_character(dataset_name, max.len = 1) - if (length(dataset_name)) { - names( - Filter( - function(parent) parent == dataset_name, - teal.data::parents(x) - ) - ) - } else { - all_parents <- unique(unlist(teal.data::parents(x))) - names(all_parents) <- all_parents - lapply( - all_parents, - function(parent) children(x = x, dataset_name = parent) - ) - } -} - -.name_to_id <- function(name) { - gsub("[[:space:][:punct:]]+", "_", x = tolower(name)) -} - -#' Filter children on `plotly_selected` -#' -#' @description -#' Filters children datanames according to: -#' - selected x and y values on the plot (based on the parent dataset) -#' - [`teal.data::join_keys`] relationship between `children_datanames` -#' -#' @param data (`reactive teal_data`) -#' @param plot_dataname (`character(1)`) -#' @param xvar (`character(1)`) -#' @param yvar (`character(1)`) -#' @param plotly_selected (`reactive`) -#' @param children_datanames (`character`) -.plotly_selected_filter_children <- function( - data, plot_dataname, xvar, yvar, plotly_selected, children_datanames -) { - xvar_r <- if (is.reactive(xvar)) xvar else reactive(xvar) - yvar_r <- if (is.reactive(yvar)) yvar else reactive(yvar) - - plotly_selected_q <- reactive({ - req(plotly_selected(), xvar_r(), yvar_r()) - primary_keys <- unname(teal.data::join_keys(data())[plot_dataname, plot_dataname]) - if (length(primary_keys) == 0) { - primary_keys <- unique(sapply(children_datanames, USE.NAMES = FALSE, FUN = function(childname) { - names(teal.data::join_keys(data())[plot_dataname, childname]) - })) - } - req(primary_keys) - within( - data(), - expr = { - swimlane_selected <- dplyr::filter(dataname, xvar %in% xvals, yvar %in% yvals) %>% - dplyr::select(primary_keys) - }, - dataname = str2lang(plot_dataname), - xvar = str2lang(xvar_r()), - yvar = str2lang(yvar_r()), - xvals = plotly_selected()$x, - yvals = plotly_selected()$y, - primary_keys = primary_keys - ) - }) - - children_names <- reactive({ - if (length(children_datanames) == 0) { - children(plotly_selected_q(), plot_dataname) - } else { - children_datanames - } - }) - - eventReactive(plotly_selected_q(), { - exprs <- as.expression( - lapply( - children_names(), - function(childname) { - join_cols <- teal.data::join_keys(plotly_selected_q())[childname, plot_dataname] - substitute( - expr = { - if (nrow(childname) > 0) { - childname <- dplyr::right_join(childname, swimlane_selected, by = by) - } - }, - list( - childname = str2lang(childname), - by = join_cols - ) - ) - } - ) - ) - q <- teal.code::eval_code(plotly_selected_q(), exprs) - }) -} - .update_cs_input <- function(inputId, data, cs) { if (!missing(data) && !length(names(cs))) { @@ -520,87 +420,3 @@ children <- function(x, dataset_name = character(0)) { updateSelectInput(inputId = inputId, choices = cs$choices, selected = cs$selected) if (length(cs$choices) < 2) shinyjs::hide(inputId) } - - -#' @keywords internal -#' @noRd -trigger_tooltips_deps <- function() { - htmltools::htmlDependency( - name = "teal-modules-general-trigger-tooltips", - version = utils::packageVersion("teal.modules.general"), - package = "teal.modules.general", - src = "triggerTooltips", - script = "triggerTooltips.js", - stylesheet = "triggerTooltips.css" - ) -} - - -#' @keywords internal -#' @noRd -setup_trigger_tooltips <- function(plot, ns) { - htmlwidgets::onRender( - plot, - paste0( - "function(el) { - const targetDiv = document.querySelector('#", ns("plot"), " .modebar-group:nth-child(4)'); - if (targetDiv) { - const button = document.createElement('button'); - button.setAttribute('data-count', '0'); - button.className = 'teal-modules-general trigger-tooltips-button'; - - button.onclick = function () { - triggerSelectedTooltips('", ns("plot"), "') - }; - - const icon = document.createElement('i'); - icon.className = 'fas fa-message'; - - const tooltip = document.createElement('span'); - tooltip.className = 'plotly-icon-tooltip'; - tooltip.textContent = 'Hover selection'; - - button.appendChild(icon); - button.appendChild(tooltip); - targetDiv.appendChild(button); - } - }" - ) - ) -} - -#' @keywords internal -#' @noRd -set_plot_data <- function(plot, data_id) { - # Make sure to have a `customdata` column in the dataset and pass it to `plotly::plot_ly`. - htmlwidgets::onRender( - plot, - paste0( - " - function(el) { - slicedData = el.data.slice(0, -1).map(({ x, y, customdata, mode }) => ({ x, y, customdata, mode })); - plotData = { - x: [], - y: [], - customdata: [], - curveNumber: [], - pointNumber: [] - }; - - slicedData.forEach((item, curveNumber) => { - if (item.mode === 'markers') { - for (let i = 0; i < item.x.length; i++) { - plotData.pointNumber.push(i); - plotData.x.push(item.x[i]); - plotData.y.push(item.y[i]); - plotData.customdata.push(item.customdata[i]); - plotData.curveNumber.push(curveNumber); - } - } - }); - Shiny.setInputValue('", data_id, "', plotData); - } - " - ) - ) -} diff --git a/inst/css/reactable.css b/inst/css/reactable.css deleted file mode 100644 index 1b0c523aa..000000000 --- a/inst/css/reactable.css +++ /dev/null @@ -1,7 +0,0 @@ -.teal-modules-general.reactable-accordion .accordion-body { - padding: 0; -} - -.teal-modules-general.reactable-card { - margin-bottom: 0; -} diff --git a/inst/poc_adam.r b/inst/poc_adam.r deleted file mode 100644 index c0ca7ae3b..000000000 --- a/inst/poc_adam.r +++ /dev/null @@ -1,69 +0,0 @@ -pkgload::load_all("teal") -pkgload::load_all("teal.widgets") -pkgload::load_all("teal.modules.general") - -# Example data -data <- within(teal_data(), { - library(dplyr) - library(tidyr) - ADSL <- teal.data::rADSL |> mutate( - EOTSTT2 = case_when( - !is.na(DCSREAS) ~ DCSREAS, - TRUE ~ EOTSTT - ) - ) - - ADAE <- teal.data::rADAE - ADRS <- teal.data::rADRS -}) - -join_keys(data) <- default_cdisc_join_keys - -app <- init( - data = data, - modules = modules( - tm_data_table(), - tm_p_swimlane( - label = "Swimlane", - geom_specs = list( - list( - geom = quote(geom_col), - data = quote(ADSL), - mapping = list(y = quote(USUBJID), x = quote(EOSDY)), - width = 0.2 - ), # geom_col(data = synthetic_data, mapping = aes(x = subjid, x = max(study_day), width = 0.2) - list( - geom = quote(geom_point), - data = quote(ADSL), - mapping = list( - y = quote(USUBJID), x = quote(EOSDY), color = quote(EOTSTT2), shape = quote(EOTSTT2) - ) - ), - list( - geom = quote(geom_point), - data = quote(ADRS), - mapping = list( - y = quote(USUBJID), x = quote(ADY), color = quote(PARAMCD), shape = quote(PARAMCD) - ) - ), - list( - geom = quote(geom_point), - data = quote(ADAE), - mapping = list( - y = quote(USUBJID), x = quote(ASTDY), color = quote(AETERM), shape = quote(AETERM) - ) - ), - list( - geom = quote(geom_point), - data = quote(ADAE), - mapping = list( - y = quote(USUBJID), x = quote(AENDY), color = quote(AEOUT), shape = quote(AEOUT) - ) - ) - ), - title = "Swimlane Efficacy Plot" - ) - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/poc_adam_plotly.r b/inst/poc_adam_plotly.r deleted file mode 100644 index 673595d01..000000000 --- a/inst/poc_adam_plotly.r +++ /dev/null @@ -1,43 +0,0 @@ -library(plotly) -pkgload::load_all("teal.modules.general") - -# Example data -data <- within(teal_data(), { - library(dplyr) - library(tidyr) - ADSL <- teal.data::rADSL |> mutate( - EOTSTT2 = case_when( - !is.na(DCSREAS) ~ DCSREAS, - TRUE ~ EOTSTT - ), - TRTLEN = as.integer(TRTEDTM - TRTSDTM) - ) - - ADAE <- teal.data::rADAE - ADRS <- teal.data::rADRS -}) - -join_keys(data) <- default_cdisc_join_keys - - -plotly_specs <- list( - list("plotly::add_bars", x = ~TRTLEN, y = ~USUBJID, color = ~ARM, data = quote(ADSL)), - list("plotly::add_markers", x = ~ADY, y = ~USUBJID, color = ~AVALC, symbol = ~AVALC, data = quote(ADRS)) -) - -app <- init( - data = data, - modules = modules( - tm_data_table(), - tm_p_plotly( - label = "Swimlane", - plotly_specs = plotly_specs, - title = "Swimlane Efficacy Plot" - ) - ), - filter = teal_slices( - teal_slice("ADSL", "AGE", selected = c(20, 25)) - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/poc_crf.R b/inst/poc_crf.R deleted file mode 100644 index 616e496b9..000000000 --- a/inst/poc_crf.R +++ /dev/null @@ -1,533 +0,0 @@ -library(teal) -library(DT) -library(labelled) -library(reactable) -pkgload::load_all("teal.modules.general") - -# Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data - -data <- within(teal_data(), { - library(dplyr) - library(arrow) - library(forcats) - data_path <- "PATH_TO_DATA" - - swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> - filter(!is.na(event_result), !is.na(event_study_day)) |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) - - spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> - mutate(subject = as.character(subject)) - - parent_ds <- bind_rows( - swimlane_ds |> select(subject, cohrt, txarm), - spiderplot_ds |> select(subject, cohrt, txarm) - ) |> - distinct() -}) - -join_keys(data) <- join_keys( - join_key("parent_ds", "swimlane_ds", c("subject", "cohrt", "txarm")), - join_key("parent_ds", "spiderplot_ds", c("subject", "cohrt", "txarm")) -) - -swim_plotly_specs <- list( - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(study_drug_administration)), - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(response_assessment)), - list("plotly::add_markers", x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, data = quote(disposition)), - list("plotly::add_segments", x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, data = quote(max_subject_day), line = list(width = 1, color = "grey"), showlegend = FALSE), - list("plotly::layout", xaxis = list(title = "Study Day"), yaxis = list(title = "Subject")) -) - -swimlane_tm <- teal_transform_module( - server = function(id, data) { - reactive({ - data() |> - within({ - swimlane_ds <- swimlane_ds |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) - disposition <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "disposition") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - response_assessment <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "response_assessment") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - study_drug_administration <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "study_drug_administration") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day) - - max_subject_day <- swimlane_ds |> - group_by(subject) |> - summarise(study_day = max(event_study_day)) |> - bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) - }) - }) - } -) - -swimlane_ui_mod <- function(id) { - ns <- NS(id) - shinyjs::hidden( - fluidRow( - id = ns("reactive_tables"), - column( - 6, - class = "simple-card", - tagList( - h4("Multiple Myeloma Response"), - reactableOutput(ns("mm_response")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Study Tx Listing"), - reactableOutput(ns("tx_listing")) - ) - ) - ) - ) -} - -swimlane_srv_mod <- function(id, - data, - plotly_selected, - filter_panel_api) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - observeEvent(plotly_selected(), once = TRUE, { - shinyjs::show("reactive_tables") - }) - - output$mm_response <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - col_defs <- list( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") - ) - mm_response <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> - select(all_of(names(col_defs))) - reactable( - mm_response, - columns = col_defs, - defaultPageSize = 5, - searchable = TRUE, - sortable = TRUE - ) - }) - - output$tx_listing <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - - col_defs <- list( - site_name = colDef(name = "Site Name"), - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - txnam = colDef(name = "Study Drug Name"), - txrec = colDef(name = "Study Drug Administered"), - txrecrs = colDef(name = "Reason Study Drug Not Admin"), - txd_study_day = colDef(name = "Date Administered Study Day"), - date_administered = colDef(name = "Date Administered"), - cydly = colDef(name = "Cycle Delay"), - cydlyrs = colDef(name = "Cycle Delay Reason"), - cydlyae = colDef(name = "Cycle Delay Adverse Event"), - txdly = colDef(name = "Dose Delay"), - txdlyrs = colDef(name = "Dose Delay Reason"), - txdlyae = colDef(name = "AE related to Dose Delay"), - txpdos = colDef(name = "Planned Dose per Admin"), - txpdosu = colDef(name = "Planned Dose per Admin Unit"), - frqdv = colDef(name = "Frequency"), - txrte = colDef(name = "Route of Administration"), - txform = colDef(name = "Dose Formulation"), - txdmod = colDef(name = "Dose Modification"), - txrmod = colDef(name = "Dose Modification Reason"), - txdmae = colDef(name = "AE related to Dose Modification"), - txad = colDef(name = "Total Dose Administered"), - txadu = colDef(name = "Total Dose Administered Unit"), - txd = colDef(name = "Date Administered"), - txstm = colDef(name = "Start Time Administered"), - txstmu = colDef(name = "Start Time Administered Unknown"), - txed = colDef(name = "End Date Administered"), - txetm = colDef(name = "End Time Administered"), - txetmu = colDef(name = "End Time Administered Unknown"), - txtm = colDef(name = "Time Administered"), - txtmu = colDef(name = "Time Administered Unknown"), - txed_study_day = colDef(name = "End Study Day"), - infrt = colDef(name = "Infusion Rate"), - infrtu = colDef(name = "Infusion Rate Unit"), - tximod = colDef(name = "Infusion Modified?"), - txirmod = colDef(name = "Reason for Infusion modification"), - tximae = colDef(name = "AE related to Infusion Modification") - ) - tx_listing <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> - select(all_of(names(col_defs))) - reactable( - tx_listing, - columns = col_defs, - defaultPageSize = 5, - searchable = TRUE, - sortable = TRUE - ) - }) - }) -} - -spider_plotly_specs <- list( - list("plotly::add_markers", x = ~event_study_day, y = ~event_result_num, color = ~subject, data = quote(spiderplot_ds_filtered)), - list("plotly::add_lines", x = ~event_study_day, y = ~event_result_num, data = quote(spiderplot_ds_filtered), color = ~subject, showlegend = FALSE), - list( - "plotly::layout", - xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), - yaxis = list(title = ~y_title), - title = ~ paste0(y_title, " Over Time") - ) -) - - -spider_ui_mod <- function(id) { - ns <- NS(id) - shinyjs::hidden( - fluidRow( - id = ns("reactive_tables"), - fluidRow( - column( - 6, - class = "simple-card", - tagList( - h4("Most Recent Resp and Best Resp"), - reactableOutput(ns("recent_resp")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Multiple Myeloma Response"), - reactableOutput(ns("all_resp")) - ) - ) - ), - fluidRow( - column( - 6, - class = "simple-card", - tagList( - h4("Disease Assessment - SPEP"), - reactableOutput(ns("spep_listing")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Disease Assessment - SFLC"), - reactableOutput(ns("sflc_listing")) - ) - ) - ) - ) - ) -} - -spider_srv_mod <- function(id, - data, - plotly_selected, - filter_panel_api) { - checkmate::assert_class(data, "reactive") - checkmate::assert_class(isolate(data()), "teal_data") - moduleServer(id, function(input, output, session) { - all_resp_cols <- list( - txarm = colDef(name = "Study Arm"), - cohrt = colDef(name = "Study Cohort"), - subject = colDef(name = "Subject"), - event_result = colDef(name = "Response"), - event_study_day = colDef(name = "Study Day"), - visit_name = colDef(name = "Visit Name") - ) - - selected_recent_subject <- reactiveVal(NULL) - - observeEvent(plotly_selected(), once = TRUE, { - shinyjs::show("reactive_tables") - }) - - all_resp <- reactive({ - selected_subjects <- data()[["spiderplot_ds"]] |> - filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> - pull(subject) - data()[["spiderplot_ds"]] |> - filter(event_type == "response_assessment") |> - select(all_of(names(all_resp_cols))) |> - filter(subject %in% selected_subjects) - }) - - output$all_resp <- renderReactable({ - reactable( - all_resp(), - columns = all_resp_cols - ) - }) - - recent_resp_cols <- list( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") - ) - - recent_resp <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "latest_response_assessment") |> - filter(subject %in% all_resp()$subject) |> - select(all_of(names(recent_resp_cols))) - }) - - output$recent_resp <- renderReactable({ - reactable( - recent_resp(), - columns = recent_resp_cols, - selection = "single", - onClick = "select" - ) - }) - - spep_cols <- list( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lrspep1 = colDef(name = "Another Form added?"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") - ) - - spep <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "Serum M-protein") |> - filter(subject %in% all_resp()$subject) |> - select(all_of(names(spep_cols))) - }) - - output$spep_listing <- renderReactable({ - reactable( - spep(), - columns = spep_cols - ) - }) - - - sflc_cols <- list( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lchfrc = colDef(name = "Presence of Serum free light chains"), - lchfr_raw = colDef(name = "Serum free light chain results"), - klchf_raw = colDef(name = "Kappa free light chain results"), - llchf_raw = colDef(name = "Lambda free light chain results"), - klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") - ) - - sflc <- reactive({ - data()[["spiderplot_ds"]] |> - filter( - event_type %in% c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" - ) - ) |> - filter(subject %in% all_resp()$subject) |> - select(all_of(names(sflc_cols))) - }) - - output$sflc_listing <- renderReactable({ - reactable( - sflc(), - columns = sflc_cols - ) - }) - - observeEvent(input$recent_resp_selected, { - print(input$recent_resp_selected) - req(input$recent_resp_selected) - selected_subjects <- reactableProxy("recent_resp") %>% - getReactableState("selected") - print(selected_subjects) - }) - }) -} - -app <- init( - data = data, - header = tags$head(tags$style( - ".simple-card { - padding: 20px; - border-radius: 10px; - border: 1px solid #ddd; - box-shadow: 0 4px 6px rgba(0, 0, 0, 0.1); - background-color: #fff; - } - .simple-card h4 { - text-align: center; - }" - )), - modules = modules( - tm_p_swimlane2( - label = "Spiderplot", - plotly_specs = spider_plotly_specs, - title = "Swimlane Plot", - transformators = list(spiderplot_tm), - ui_mod = spider_ui_mod, - srv_mod = spider_srv_mod, - plot_height = 600 - ), - tm_p_swimlane2( - label = "Swimlane", - plotly_specs = swim_plotly_specs, - title = "Swim Lane - Duration of Tx", - colors = c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue", - "X Administration Injection" = "goldenrod", - "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid" - ), - symbols = c( - "DEATH" = "circle", - "WITHDRAWAL BY SUBJECT" = "square", - "PD (Progressive Disease)" = "circle", - "SD (Stable Disease)" = "square-open", - "MR (Minimal/Minor Response)" = "star-open", - "PR (Partial Response)" = "star-open", - "VGPR (Very Good Partial Response)" = "star-open", - "CR (Complete Response)" = "star-open", - "SCR (Stringent Complete Response)" = "star-open", - "X Administration Injection" = "line-ns-open", - "Y Administration Infusion" = "line-ns-open", - "Z Administration Infusion" = "line-ns-open" - ), - transformators = list(swimlane_tm), - ui_mod = swimlane_ui_mod, - srv_mod = swimlane_srv_mod - ), - tm_data_table() - ), - filter = teal_slices( - teal_slice( - dataname = "parent_ds", - varname = "subject" - ), - teal_slice( - dataname = "parent_ds", - varname = "cohrt" - ), - teal_slice( - dataname = "parent_ds", - varname = "txarm" - ), - count_type = "all" - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/poc_crf2.R b/inst/poc_crf2.R deleted file mode 100644 index 6d52992f4..000000000 --- a/inst/poc_crf2.R +++ /dev/null @@ -1,765 +0,0 @@ -library(teal) -library(DT) -library(labelled) -library(reactable) -pkgload::load_all("~/nest/teal.modules.general") -# Note: Please add the `PATH_TO_DATA` and change the X, Y, and Z Administrations to the actual values in the data - -with_tooltips <- function(...) { - args <- list(...) - lapply(args, function(col) { - col$header <- tags$span(col$name, title = col$name) - return(col) - }) -} - -data <- within(teal_data(), { - library(dplyr) - library(arrow) - library(forcats) - data_path <- "PATH/TO/DATA" - - swimlane_ds <- read_parquet(file.path(data_path, "swimlane_ds.parquet")) |> - filter(!is.na(event_result), !is.na(event_study_day)) |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) - - spiderplot_ds <- read_parquet(file.path(data_path, "spiderplot_ds.parquet")) |> - mutate(subject = as.character(subject)) - - parent_ds <- bind_rows( - swimlane_ds |> select(subject, cohrt, txarm), - spiderplot_ds |> select(subject, cohrt, txarm) - ) |> - distinct() -}) - -join_keys(data) <- join_keys( - join_key("parent_ds", "swimlane_ds", c("subject", "cohrt", "txarm")), - join_key("parent_ds", "spiderplot_ds", c("subject", "cohrt", "txarm")) -) - -tm_swimlane <- function(label = "Swimlane", plot_height = 700) { - ui <- function(id, height) { - ns <- NS(id) - tagList( - fluidRow( - class = "simple-card", - h4("Swim Lane - Duration of Tx"), - sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height, width = "100%"), - plotly::plotlyOutput(ns("plot"), height = "100%") - ), - fluidRow( - column( - 6, - class = "simple-card", - tagList( - h4("Multiple Myeloma Response"), - reactableOutput(ns("mm_response")) - ) - ), - column( - 6, - class = "simple-card", - tagList( - h4("Study Tx Listing"), - reactableOutput(ns("tx_listing")) - ) - ) - ) - ) - } - server <- function(id, data, filter_panel_api, plot_height = 600) { - moduleServer(id, function(input, output, session) { - plotly_q <- reactive({ - data() |> - within( - { - swimlane_ds <- swimlane_ds |> - mutate(subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max)) |> - mutate( - subject = forcats::fct_reorder(as.factor(subject), event_study_day, .fun = max), - tooltip = case_when( - event_type == "study_drug_administration" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Administration:", event_result - ), - event_type == "response_assessment" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Response Assessment:", event_result - ), - event_type == "disposition" ~ paste( - "Subject:", subject, - "
Study Day:", event_study_day, - "
Disposition:", event_result - ), - TRUE ~ NA_character_ - ) - ) - - swimlane_ds <- swimlane_ds |> - group_by(subject, event_study_day) |> - mutate( - tooltip = paste(unique(tooltip), collapse = "
") - ) |> - ungroup() |> - mutate(tooltip = stringr::str_remove_all(tooltip, "
Subject: [0-9]+
Study Day: [0-9]+")) - - disposition <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "disposition") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - response_assessment <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "response_assessment") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - study_drug_administration <- swimlane_ds |> - filter(!is.na(event_study_day)) |> - filter(event_type == "study_drug_administration") |> - transmute(subject, event_type, catagory = event_result, study_day = event_study_day, tooltip) - - max_subject_day <- swimlane_ds |> - group_by(subject) |> - summarise(study_day = max(event_study_day)) |> - bind_rows(tibble(subject = unique(swimlane_ds$subject), study_day = 0)) - - adverse_events <- swimlane_ds |> - filter(event_type == "adverse_event") |> - select(subject, event_study_day, event_result, aenum, aeraw, icrsgr, ecrsgr, igrnci, egrnci, aeod_study_day, aerd_study_day) |> - mutate( - initial_grade = coalesce(icrsgr, igrnci), - extreme_grade = coalesce(ecrsgr, egrnci), - initial_label = case_when( - !is.na(icrsgr) ~ "Initial ASTCT Grade", - !is.na(igrnci) ~ "Initial NCI CTCAE Grade", - TRUE ~ "Initial Grade" - ), - extreme_label = case_when( - !is.na(ecrsgr) ~ "Most Extreme ASTCT Grade", - !is.na(egrnci) ~ "Most Extreme NCI CTCAE Grade", - TRUE ~ "Most Extreme Grade" - ) - ) |> - mutate( - tooltip = sprintf( - "Subject: %s
Study Day: %d
AENUM: %d
Event of Interest: %s
Primary Adverse Event: %s
Onset Study Day: %d
End Date Study Day: %d
%s: %d
%s: %d", - subject, - event_study_day, - aenum, - event_result, - aeraw, - aeod_study_day, - aerd_study_day, - initial_label, - initial_grade, - extreme_label, - extreme_grade - ) - ) - - p <- plotly::plot_ly( - source = "swimlane", - colors = c( - "DEATH" = "black", - "WITHDRAWAL BY SUBJECT" = "grey", - "PD (Progressive Disease)" = "red", - "SD (Stable Disease)" = "darkorchid4", - "MR (Minimal/Minor Response)" = "sienna4", - "PR (Partial Response)" = "maroon", - "VGPR (Very Good Partial Response)" = "chartreuse4", - "CR (Complete Response)" = "#3a41fc", - "SCR (Stringent Complete Response)" = "midnightblue", - "X Administration Injection" = "goldenrod", - "Y Administration Infusion" = "deepskyblue3", - "Z Administration Infusion" = "darkorchid", - "Cytokine Release Syndrome" = "#f5a733", - "Cytokine Release Syndrome Start" = "#fccf79", - "Cytokine Release Syndrome End" = "#f59505", - "Infection" = "pink", - "Infection Start" = "#f2ced3", - "Infection End" = "#d65668" - ), - symbols = c( - "DEATH" = "circle", - "WITHDRAWAL BY SUBJECT" = "square", - "PD (Progressive Disease)" = "circle", - "SD (Stable Disease)" = "square-open", - "MR (Minimal/Minor Response)" = "star-open", - "PR (Partial Response)" = "star-open", - "VGPR (Very Good Partial Response)" = "star-open", - "CR (Complete Response)" = "star-open", - "SCR (Stringent Complete Response)" = "star-open", - "X Administration Injection" = "line-ns-open", - "Y Administration Infusion" = "line-ns-open", - "Z Administration Infusion" = "line-ns-open" - ), - height = height - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = study_drug_administration - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = response_assessment - ) |> - plotly::add_markers( - x = ~study_day, y = ~subject, color = ~catagory, symbol = ~catagory, - text = ~tooltip, - hoverinfo = "text", - data = disposition - ) |> - plotly::add_segments( - x = ~0, xend = ~study_day, y = ~subject, yend = ~subject, - data = max_subject_day, - line = list(width = 1, color = "grey"), - showlegend = FALSE - ) |> - plotly::add_segments( - data = adverse_events, - x = ~aeod_study_day, - xend = ~aerd_study_day, - y = ~subject, - yend = ~subject, - color = ~event_result, - line = list(width = 2), - showlegend = TRUE, - name = ~event_result, - legendgroup = ~event_result, - hoverinfo = "none" - ) |> - plotly::add_markers( - data = adverse_events |> filter(event_study_day == aeod_study_day), - x = ~aeod_study_day, - y = ~subject, - text = ~tooltip, - hoverinfo = "text", - color = ~ paste0(event_result, " Start"), - showlegend = TRUE, - legendgroup = ~event_result, - marker = list(size = 6, symbol = "arrow-down") - ) |> - plotly::add_markers( - data = adverse_events |> filter(event_study_day == aerd_study_day), - x = ~aerd_study_day, - y = ~subject, - text = ~tooltip, - hoverinfo = "text", - color = ~ paste0(event_result, " End"), - showlegend = TRUE, - legendgroup = ~event_result, - marker = list(size = 6, symbol = "arrow-down") - ) |> - plotly::layout( - xaxis = list(title = "Study Day"), yaxis = list(title = "Subject") - ) |> - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) - }, - height = input$plot_height - ) - }) - - output$plot <- plotly::renderPlotly({ - plotly::event_register( - plotly_q()$p, - "plotly_selected" - ) - }) - - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "swimlane")) - - output$mm_response <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - col_defs <- with_tooltips( - subject = colDef(name = "Subject"), - raise_query = colDef( - name = "Raise Query", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - visit_name = colDef(name = "Visit Name"), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") - ) - mm_response <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y, event_type == "response_assessment") |> - select(all_of(names(col_defs))) - if (nrow(mm_response) == 0) { - return() - } - - reactable( - mm_response, - class = "custom-reactable", - columns = col_defs, - defaultPageSize = 10, - wrap = FALSE, - searchable = TRUE, - sortable = TRUE - ) - }) - - output$tx_listing <- renderReactable({ - swimlane_ds <- data()[["swimlane_ds"]] - - col_defs <- with_tooltips( - site_name = colDef(name = "Site Name"), - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - txnam = colDef(name = "Study Drug Name"), - txrec = colDef(name = "Study Drug Administered"), - txrecrs = colDef(name = "Reason Study Drug Not Admin"), - txd_study_day = colDef(name = "Date Administered Study Day"), - date_administered = colDef(name = "Date Administered"), - cydly = colDef(name = "Cycle Delay"), - cydlyrs = colDef(name = "Cycle Delay Reason"), - cydlyae = colDef(name = "Cycle Delay Adverse Event"), - txdly = colDef(name = "Dose Delay"), - txdlyrs = colDef(name = "Dose Delay Reason"), - txdlyae = colDef(name = "AE related to Dose Delay"), - txpdos = colDef(name = "Planned Dose per Admin"), - txpdosu = colDef(name = "Planned Dose per Admin Unit"), - frqdv = colDef(name = "Frequency"), - txrte = colDef(name = "Route of Administration"), - txform = colDef(name = "Dose Formulation"), - txdmod = colDef(name = "Dose Modification"), - txrmod = colDef(name = "Dose Modification Reason"), - txdmae = colDef(name = "AE related to Dose Modification"), - txad = colDef(name = "Total Dose Administered"), - txadu = colDef(name = "Total Dose Administered Unit"), - txd = colDef(name = "Date Administered"), - txstm = colDef(name = "Start Time Administered"), - txstmu = colDef(name = "Start Time Administered Unknown"), - txed = colDef(name = "End Date Administered"), - txetm = colDef(name = "End Time Administered"), - txetmu = colDef(name = "End Time Administered Unknown"), - txtm = colDef(name = "Time Administered"), - txtmu = colDef(name = "Time Administered Unknown"), - txed_study_day = colDef(name = "End Study Day"), - infrt = colDef(name = "Infusion Rate"), - infrtu = colDef(name = "Infusion Rate Unit"), - tximod = colDef(name = "Infusion Modified?"), - txirmod = colDef(name = "Reason for Infusion modification"), - tximae = colDef(name = "AE related to Infusion Modification") - ) - tx_listing <- swimlane_ds |> - filter(event_study_day %in% plotly_selected()$x, subject %in% plotly_selected()$y) |> - select(all_of(names(col_defs))) - if (nrow(tx_listing) == 0) { - return() - } - - reactable( - tx_listing, - columns = col_defs, - defaultPageSize = 10, - wrap = FALSE, - searchable = TRUE, - sortable = TRUE - ) - }) - }) - } - module( - label = label, - ui = ui, - server = server, - datanames = "all", - ui_args = list(height = plot_height) - ) -} - -tm_spider <- function(label = "Spiderplot", plot_height = 600) { - ui <- function(id, height) { - ns <- NS(id) - tagList( - div( - style = "display: flex; justify-content: center; align-items: center; gap: 30px;", - div( - selectInput(NS(id, "event_type"), "Select Y Axis", NULL) - ), - div(sliderInput(ns("plot_height"), "Plot Height (px)", 400, 1200, height)) - ), - div( - style = "display: flex", - div( - class = "simple-card", - style = "width: 50%", - tagList( - h4("Most Recent Resp and Best Resp"), - reactableOutput(ns("recent_resp")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - plotly::plotlyOutput(ns("plot"), height = "100%") - ) - ), - div( - style = "display: flex", - div( - style = "width: 50%", - div( - class = "simple-card", - h4("Disease Assessment - SFLC"), - reactableOutput(ns("sflc_listing")) - ), - div( - class = "simple-card", - h4("Disease Assessment - SPEP"), - reactableOutput(ns("spep_listing")) - ) - ), - div( - class = "simple-card", - style = "width: 50%", - h4("Multiple Myeloma Response"), - reactableOutput(ns("all_resp")) - ) - ) - ) - } - server <- function(id, data, filter_panel_api, plot_height = 600) { - moduleServer(id, function(input, output, session) { - spiderplot_ds <- reactive(data()[["spiderplot_ds"]]) - observeEvent(spiderplot_ds(), { - event_types <- unique(spiderplot_ds()$event_type) - updateSelectInput( - inputId = "event_type", - choices = event_types[!event_types %in% c("response_assessment", "latest_response_assessment")] - ) - }) - plotly_q <- reactive({ - data() |> - within( - { - y_title <- selected_event - spiderplot_ds_filtered <- spiderplot_ds |> - filter(event_type == selected_event) - ticksuffix <- ifelse(grepl("Change from baseline", selected_event), "%", "") - - p <- plotly::plot_ly(source = "spiderplot", height = height) |> - plotly::add_markers( - x = ~event_study_day, y = ~event_result_num, color = ~subject, - data = spiderplot_ds_filtered - ) |> - plotly::add_lines( - x = ~event_study_day, y = ~event_result_num, color = ~subject, - data = spiderplot_ds_filtered, - showlegend = FALSE - ) |> - plotly::layout( - xaxis = list(title = "Collection Date Study Day", zeroline = FALSE), - yaxis = list(title = ~y_title, ticksuffix = ticksuffix, separatethousands = TRUE, exponentformat = "none"), - title = ~ paste0(paste(strwrap(y_title, width = 50), collapse = "
"), " Over Time") - ) |> - plotly::layout(dragmode = "select") |> - plotly::config(displaylogo = FALSE) - }, - selected_event = input$event_type, - height = input$plot_height - ) - }) - - output$plot <- plotly::renderPlotly({ - plotly::event_register( - plotly_q()$p, - "plotly_selected" - ) - }) - - plotly_selected <- reactive(plotly::event_data("plotly_selected", source = "spiderplot")) - - - resp_cols <- with_tooltips( - subject = colDef(name = "Subject"), - raise_query = colDef( - name = "Raise Query", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - visit_name = colDef(name = "Visit Name"), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments") - ) - - selected_recent_subject <- reactiveVal(NULL) - - plotly_selected_subjects <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_study_day %in% plotly_selected()$x, event_result %in% plotly_selected()$y) |> - pull(subject) - }) - - recent_resp_ds <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "latest_response_assessment") |> - filter(subject %in% plotly_selected_subjects()) |> - select(all_of(names(resp_cols))) - }) - - output$recent_resp <- renderReactable({ - req(plotly_selected_subjects()) - - reactable( - recent_resp_ds(), - columns = resp_cols, - selection = "single", - onClick = "select", - defaultPageSize = 15, - wrap = FALSE, - rowClass = JS(" - function(rowInfo) { - console.log(rowInfo); - if (rowInfo.selected) { - return 'selected-row'; - } - } - ") - ) - }) - - table_selected_subjects <- reactive({ - selected_row <- getReactableState("recent_resp", "selected") - if (!is.null(selected_row)) { - recent_resp_ds()[selected_row, ]$subject - } else { - unique(recent_resp_ds()$subject) - } - }) - - all_resp <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "response_assessment") |> - select(all_of(names(resp_cols))) |> - filter(subject %in% plotly_selected_subjects()) |> - filter(subject %in% table_selected_subjects()) - }) - - output$all_resp <- renderReactable({ - if (nrow(all_resp()) == 0) { - return() - } - - reactable( - all_resp(), - columns = resp_cols, - defaultPageSize = 15, - wrap = FALSE - ) - }) - - spep_cols <- with_tooltips( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lrspep1 = colDef(name = "Another Form added?"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") - ) - - spep <- reactive({ - data()[["spiderplot_ds"]] |> - filter(event_type == "Serum M-protein") |> - filter(subject %in% table_selected_subjects()) |> - select(all_of(names(spep_cols))) - }) - - output$spep_listing <- renderReactable({ - if (nrow(spep()) == 0) { - return() - } - - reactable( - spep(), - columns = spep_cols, - defaultPageSize = 5, - wrap = FALSE - ) - }) - - - sflc_cols <- with_tooltips( - subject = colDef(name = "Subject"), - visit_name = colDef(name = "Visit Name"), - visit_date = colDef(name = "Visit Date"), - form_name = colDef(name = "Form Name"), - source_system_url_link = colDef( - name = "Source System URL Link", - cell = function(value) { - if (!is.na(value) && !is.null(value) && value != "") { - htmltools::tags$a(href = value, target = "_blank", "Link") - } else { - "N/A" - } - } - ), - rspdn = colDef(name = "Assessment Performed"), - rspd = colDef(name = "Response Date"), - rspd_study_day = colDef(name = "Response Date Study Day"), - orsp = colDef(name = "Response"), - bma = colDef(name = "Best Marrow Aspirate"), - bmb = colDef(name = "Best Marrow Biopsy"), - comnts = colDef(name = "Comments"), - asmntdn = colDef(name = "Assessment Not Done"), - blq = colDef(name = "Serum M-protein too small to quantify"), - coldr = colDef(name = "Collection Date"), - cold_study_day = colDef(name = "Collection Study Day"), - coltm = colDef(name = "Collection Time"), - coltmu = colDef(name = "Collection Time Unknown"), - lchfrc = colDef(name = "Presence of Serum free light chains"), - lchfr_raw = colDef(name = "Serum free light chain results"), - klchf_raw = colDef(name = "Kappa free light chain results"), - llchf_raw = colDef(name = "Lambda free light chain results"), - klchp_raw = colDef(name = "Kappa-Lambda free light chain ratio"), - mprte_raw = colDef(name = "Serum M-protein"), - mprtec = colDef(name = "SPEP Serum M-protein detection") - ) - - sflc <- reactive({ - data()[["spiderplot_ds"]] |> - filter( - event_type %in% c( - "Kappa free light chain quantity", - "Lambda free light chain quantity", - "Kappa-Lambda free light chain ratio" - ) - ) |> - filter(subject %in% table_selected_subjects()) |> - select(all_of(names(sflc_cols))) - }) - - output$sflc_listing <- renderReactable({ - if (nrow(sflc()) == 0) { - return() - } - - reactable( - sflc(), - columns = sflc_cols, - defaultPageSize = 5, - wrap = FALSE - ) - }) - }) - } - module( - label = label, - ui = ui, - server = server, - datanames = "all", - ui_args = list(height = plot_height) - ) -} - -app <- init( - data = data, - header = tags$head(tags$style( - ".simple-card { - padding: 20px; - border-radius: 10px; - border: 1px solid #ddd; - box-shadow: 0 4px 6px rgba(0, 0, 0, 0.1); - background-color: #fff; - } - .simple-card h4 { - text-align: center; - } - .selected-row { - background-color: #d9edf7; - color: #31708f; - } - .custom-reactable.rt-nowrap .rt-th-inner { - white-space: normal !important; /* Allow text wrapping */ - text-overflow: unset !important; /* Disable ellipsis */ - overflow: visible !important; /* Ensure content is visible and wrapped */ - }" - )), - modules = modules( - tm_swimlane(), - tm_spider(), - tm_data_table() - ), - filter = teal_slices( - teal_slice( - dataname = "parent_ds", - varname = "subject" - ), - teal_slice( - dataname = "parent_ds", - varname = "cohrt" - ), - teal_slice( - dataname = "parent_ds", - varname = "txarm" - ), - count_type = "all" - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/poc_osprey.R b/inst/poc_osprey.R deleted file mode 100644 index b254c43de..000000000 --- a/inst/poc_osprey.R +++ /dev/null @@ -1,75 +0,0 @@ -pkgload::load_all("teal.modules.general") - -data <- within(teal_data(), { - library(dplyr) - library(osprey) - - ADSL <- osprey::rADSL |> - mutate(x_val = as.integer(TRTEDTM - TRTSDTM)) |> - arrange(x_val) |> - filter(!is.na(x_val)) - ADRS <- osprey::rADRS |> - filter(ADY >= 0, USUBJID %in% ADSL$USUBJID) - reference_lines <- data.frame(x = c(50, 250), xend = c(50, 250), y = min(ADSL$USUBJID), yend = max(ADSL$USUBJID)) -}) - -join_keys(data) <- default_cdisc_join_keys[c("ADSL", "ADRS")] - -plotly_specs <- list( - list( - "plotly::add_bars", - data = quote(ADSL), - x = ~x_val, y = ~USUBJID, color = ~ARM, - colors = c("A: Drug X" = "#343CFF", "B: Placebo" = "#FF484B", "C: Combination" = "#222222") - ), - list( - "plotly::add_markers", - data = quote(ADRS), - x = ~ADY, y = ~USUBJID, symbol = ~AVALC, - marker = list( - size = 10, - color = "#329133" - ) - ), - list( - "plotly::add_segments", - data = quote(reference_lines), - x = ~x, - xend = ~xend, - y = ~y, - yend = ~yend, - line = list( - color = "#CA0E40", - width = 2, - dash = "dash" - ), - showlegend = FALSE - ) -) - -app <- init( - data = data, - filter = teal_slices( - teal_slice( - "ADSL", - "AGE", - selected = c(24, 25) - ), - teal_slice( - "ADRS", - "PARAMCD", - selected = "OVRINV" - ) - ), - modules = modules( - tm_data_table(), - tm_p_swimlane2( - label = "Swimlane", - plotly_specs = plotly_specs, - title = "Swimlane Efficacy Plot", - symbols = c("CR" = "circle", "PR" = "triangle-up", "SD" = "diamond-wide", "PD" = "square", "NE" = "x-thin-open") - ) - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/swimlane_poc.R b/inst/swimlane_poc.R deleted file mode 100644 index d06007e7e..000000000 --- a/inst/swimlane_poc.R +++ /dev/null @@ -1,71 +0,0 @@ -pkgload::load_all("teal") -pkgload::load_all("teal.widgets") -pkgload::load_all("teal.modules.general") - -# Example data -data <- within(teal_data(), { - library(dplyr) - library(tidyr) - - set.seed(123) # Setting a seed for reproducibility - # Define possible maximum study days - .possible_end_days <- c(50, 60, 70) - - # Create sample data - synthetic_data <- tibble(subjid = c(1:15), strata = rep(c("category 1", "category 2"), length.out = 15)) |> - rowwise() |> - mutate( - max_study_day = sample(.possible_end_days, 1), - study_day = list(seq(10, max_study_day, by = 10)) - ) |> - unnest(study_day) |> - group_by(subjid) |> - mutate( - assigned_drug = sample(c("Drug A", "Drug B"), 1) - ) |> - ungroup() |> - mutate( - response_type = sample(c("CR", "PR"), n(), replace = TRUE), - subjid = reorder(as.character(subjid), max_study_day) - ) |> - select(-max_study_day) -}) - -app <- init( - data = data, - modules = modules( - tm_data_table(), - tm_p_swimlane( - label = "Swimlane", - geom_specs = list( - list( - geom = str2lang("ggplot2::geom_col"), - data = quote(synthetic_data), - mapping = list(y = quote(subjid), x = quote(max(study_day))), - width = 0.2 - ), # geom_col(data = synthetic_data, mapping = aes(x = subjid, x = max(study_day), width = 0.2) - list( - geom = quote(geom_point), - data = quote(synthetic_data), - mapping = list( - y = quote(subjid), x = quote(study_day), color = quote(assigned_drug), shape = quote(assigned_drug) - ) - ), - list( - geom = quote(geom_point), - data = quote(synthetic_data), - mapping = list( - y = quote(subjid), x = quote(study_day), color = quote(response_type), shape = quote(response_type) - ) - ), - list( - geom = quote(facet_wrap), - facets = quote(vars(strata)) - ) - ), - title = "Swimlane Efficacy Plot" - ) - ) -) - -shinyApp(app$ui, app$server) diff --git a/inst/teal_app.lock b/inst/teal_app.lock deleted file mode 100644 index 9bbf330de..000000000 --- a/inst/teal_app.lock +++ /dev/null @@ -1,5853 +0,0 @@ -{ - "R": { - "Version": "4.4.1", - "Repositories": [ - { - "Name": "NON_VALIDATED", - "URL": "https://packages.roche.com/Non-Validated/2024-10-14+2K_YKWmH" - }, - { - "Name": "CRAN", - "URL": "https://packages.roche.com/CRAN/2024-10-14" - } - ] - }, - "Packages": { - "DT": { - "Package": "DT", - "Version": "0.33", - "Source": "Repository", - "Type": "Package", - "Title": "A Wrapper of the JavaScript Library 'DataTables'", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = \"aut\"), person(\"Joe\", \"Cheng\", email = \"joe@posit.co\", role = c(\"aut\", \"cre\")), person(\"Xianying\", \"Tan\", role = \"aut\"), person(\"JJ\", \"Allaire\", role = \"ctb\"), person(\"Maximilian\", \"Girlich\", role = \"ctb\"), person(\"Greg\", \"Freedman Ellis\", role = \"ctb\"), person(\"Johannes\", \"Rauh\", role = \"ctb\"), person(\"SpryMedia Limited\", role = c(\"ctb\", \"cph\"), comment = \"DataTables in htmlwidgets/lib\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js in htmlwidgets/lib\"), person(\"Leon\", \"Gersen\", role = c(\"ctb\", \"cph\"), comment = \"noUiSlider in htmlwidgets/lib\"), person(\"Bartek\", \"Szopka\", role = c(\"ctb\", \"cph\"), comment = \"jquery.highlight.js in htmlwidgets/lib\"), person(\"Alex\", \"Pickering\", role = c(\"ctb\")), person(\"William\", \"Holmes\", role = c(\"ctb\")), person(\"Mikko\", \"Marttila\", role = c(\"ctb\")), person(\"Andres\", \"Quintero\", role = c(\"ctb\")), person(\"Stéphane\", \"Laurent\", role = c(\"ctb\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Data objects in R can be rendered as HTML tables using the JavaScript library 'DataTables' (typically via R Markdown or Shiny). The 'DataTables' library has been included in this R package. The package name 'DT' is an abbreviation of 'DataTables'.", - "URL": "https://github.com/rstudio/DT", - "BugReports": "https://github.com/rstudio/DT/issues", - "License": "GPL-3 | file LICENSE", - "Imports": [ - "htmltools (>= 0.3.6)", - "htmlwidgets (>= 1.3)", - "httpuv", - "jsonlite (>= 0.9.16)", - "magrittr", - "crosstalk", - "jquerylib", - "promises" - ], - "Suggests": [ - "knitr (>= 1.8)", - "rmarkdown", - "shiny (>= 1.6)", - "bslib", - "future", - "testit", - "tibble" - ], - "VignetteBuilder": "knitr", - "RoxygenNote": "7.3.1", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Yihui Xie [aut], Joe Cheng [aut, cre], Xianying Tan [aut], JJ Allaire [ctb], Maximilian Girlich [ctb], Greg Freedman Ellis [ctb], Johannes Rauh [ctb], SpryMedia Limited [ctb, cph] (DataTables in htmlwidgets/lib), Brian Reavis [ctb, cph] (selectize.js in htmlwidgets/lib), Leon Gersen [ctb, cph] (noUiSlider in htmlwidgets/lib), Bartek Szopka [ctb, cph] (jquery.highlight.js in htmlwidgets/lib), Alex Pickering [ctb], William Holmes [ctb], Mikko Marttila [ctb], Andres Quintero [ctb], Stéphane Laurent [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Joe Cheng ", - "Repository": "RSPM" - }, - "DescTools": { - "Package": "DescTools", - "Version": "0.99.59", - "Source": "Repository", - "Type": "Package", - "Title": "Tools for Descriptive Statistics", - "Date": "2025-01-25", - "Authors@R": "c( person(given=\"Andri\", family=\"Signorell\", email = \"andri@signorell.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4311-1969\")), person(\"Ken\" , \"Aho\", role = c(\"ctb\")), person(\"Andreas\" , \"Alfons\", role = c(\"ctb\")), person(\"Nanina\" , \"Anderegg\", role = c(\"ctb\")), person(\"Tomas\" , \"Aragon\", role = c(\"ctb\")), person(\"Chandima\" , \"Arachchige\", role = c(\"ctb\")), person(\"Antti\" , \"Arppe\", role = c(\"ctb\")), person(\"Adrian\" , \"Baddeley\", role = c(\"ctb\")), person(\"Kamil\" , \"Barton\", role = c(\"ctb\")), person(\"Ben\" , \"Bolker\", role = c(\"ctb\")), person(\"Hans W.\" , \"Borchers\", role = c(\"ctb\")), person(\"Frederico\" , \"Caeiro\", role = c(\"ctb\")), person(\"Stephane\" , \"Champely\", role = c(\"ctb\")), person(\"Daniel\" , \"Chessel\", role = c(\"ctb\")), person(\"Leanne\" , \"Chhay\", role = c(\"ctb\")), person(\"Nicholas\" , \"Cooper\", role = c(\"ctb\")), person(\"Clint\" , \"Cummins\", role = c(\"ctb\")), person(\"Michael\" , \"Dewey\", role = c(\"ctb\")), person(\"Harold C.\" , \"Doran\", role = c(\"ctb\")), person(\"Stephane\" , \"Dray\", role = c(\"ctb\")), person(\"Charles\" , \"Dupont\", role = c(\"ctb\")), person(\"Dirk\" , \"Eddelbuettel\", role = c(\"ctb\")), person(\"Claus\" , \"Ekstrom\", role = c(\"ctb\")), person(\"Martin\" , \"Elff\", role = c(\"ctb\")), person(\"Jeff\" , \"Enos\", role = c(\"ctb\")), person(\"Richard W.\" , \"Farebrother\", role = c(\"ctb\")), person(\"John\" , \"Fox\", role = c(\"ctb\")), person(\"Romain\" , \"Francois\", role = c(\"ctb\")), person(\"Michael\" , \"Friendly\", role = c(\"ctb\")), person(\"Tal\" , \"Galili\", role = c(\"ctb\")), person(\"Matthias\" , \"Gamer\", role = c(\"ctb\")), person(\"Joseph L.\" , \"Gastwirth\", role = c(\"ctb\")), person(\"Vilmantas\" , \"Gegzna\", role = c(\"ctb\")), person(\"Yulia R.\" , \"Gel\", role = c(\"ctb\")), person(\"Sereina\" , \"Graber\", role = c(\"ctb\")), person(\"Juergen\" , \"Gross\", role = c(\"ctb\")), person(\"Gabor\" , \"Grothendieck\", role = c(\"ctb\")), person(\"Frank E.\" , \"Harrell Jr\", role = c(\"ctb\")), person(\"Richard\" , \"Heiberger\", role = c(\"ctb\")), person(\"Michael\" , \"Hoehle\", role = c(\"ctb\")), person(\"Christian W.\" , \"Hoffmann\", role = c(\"ctb\")), person(\"Soeren\" , \"Hojsgaard\", role = c(\"ctb\")), person(\"Torsten\" , \"Hothorn\", role = c(\"ctb\")), person(\"Markus\" , \"Huerzeler\", role = c(\"ctb\")), person(\"Wallace W.\" , \"Hui\", role = c(\"ctb\")), person(\"Pete\" , \"Hurd\", role = c(\"ctb\")), person(\"Rob J.\" , \"Hyndman\", role = c(\"ctb\")), person(\"Christopher\" , \"Jackson\", role = c(\"ctb\")), person(\"Matthias\" , \"Kohl\", role = c(\"ctb\")), person(\"Mikko\" , \"Korpela\", role = c(\"ctb\")), person(\"Max\" , \"Kuhn\", role = c(\"ctb\")), person(\"Detlew\" , \"Labes\", role = c(\"ctb\")), person(\"Friederich\" , \"Leisch\", role = c(\"ctb\")), person(\"Jim\" , \"Lemon\", role = c(\"ctb\")), person(\"Dong\" , \"Li\", role = c(\"ctb\")), person(\"Martin\" , \"Maechler\", role = c(\"ctb\")), person(\"Arni\" , \"Magnusson\", role = c(\"ctb\")), person(\"Ben\" , \"Mainwaring\", role = c(\"ctb\")), person(\"Daniel\" , \"Malter\", role = c(\"ctb\")), person(\"George\" , \"Marsaglia\", role = c(\"ctb\")), person(\"John\" , \"Marsaglia\", role = c(\"ctb\")), person(\"Alina\" , \"Matei\", role = c(\"ctb\")), person(\"David\" , \"Meyer\", role = c(\"ctb\")), person(\"Weiwen\" , \"Miao\", role = c(\"ctb\")), person(\"Giovanni\" , \"Millo\", role = c(\"ctb\")), person(\"Yongyi\" , \"Min\", role = c(\"ctb\")), person(\"David\" , \"Mitchell\", role = c(\"ctb\")), person(\"Cyril Flurin\" , \"Moser\", role = c(\"ctb\")), person(\"Franziska\" , \"Mueller\", role = c(\"ctb\")), person(\"Markus\" , \"Naepflin\", role = c(\"ctb\")), person(\"Danielle\" , \"Navarro\", role = c(\"ctb\")), person(\"Henric\" , \"Nilsson\", role = c(\"ctb\")), person(\"Klaus\" , \"Nordhausen\", role = c(\"ctb\")), person(\"Derek\" , \"Ogle\", role = c(\"ctb\")), person(\"Hong\" , \"Ooi\", role = c(\"ctb\")), person(\"Nick\" , \"Parsons\", role = c(\"ctb\")), person(\"Sandrine\" , \"Pavoine\", role = c(\"ctb\")), person(\"Tony\" , \"Plate\", role = c(\"ctb\")), person(\"Luke\" , \"Prendergast\", role = c(\"ctb\")), person(\"Roland\" , \"Rapold\", role = c(\"ctb\")), person(\"William\" , \"Revelle\", role = c(\"ctb\")), person(\"Tyler\" , \"Rinker\", role = c(\"ctb\")), person(\"Brian D.\" , \"Ripley\", role = c(\"ctb\")), person(\"Caroline\" , \"Rodriguez\", role = c(\"ctb\")), person(\"Nathan\" , \"Russell\", role = c(\"ctb\")), person(\"Nick\" , \"Sabbe\", role = c(\"ctb\")), person(\"Ralph\" , \"Scherer\", role = c(\"ctb\")), person(\"Venkatraman E.\", \"Seshan\", role = c(\"ctb\")), person(\"Michael\" , \"Smithson\", role = c(\"ctb\")), person(\"Greg\" , \"Snow\", role = c(\"ctb\")), person(\"Karline\" , \"Soetaert\", role = c(\"ctb\")), person(\"Werner A.\" , \"Stahel\", role = c(\"ctb\")), person(\"Alec\" , \"Stephenson\", role = c(\"ctb\")), person(\"Mark\" , \"Stevenson\", role = c(\"ctb\")), person(\"Ralf\" , \"Stubner\", role = c(\"ctb\")), person(\"Matthias\" , \"Templ\", role = c(\"ctb\")), person(\"Duncan\" , \"Temple Lang\", role = c(\"ctb\")), person(\"Terry\" , \"Therneau\", role = c(\"ctb\")), person(\"Yves\" , \"Tille\", role = c(\"ctb\")), person(\"Luis\" , \"Torgo\", role = c(\"ctb\")), person(\"Adrian\" , \"Trapletti\", role = c(\"ctb\")), person(\"Joshua\" , \"Ulrich\", role = c(\"ctb\")), person(\"Kevin\" , \"Ushey\", role = c(\"ctb\")), person(\"Jeremy\" , \"VanDerWal\", role = c(\"ctb\")), person(\"Bill\" , \"Venables\", role = c(\"ctb\")), person(\"John\" , \"Verzani\", role = c(\"ctb\")), person(\"Pablo J.\" , \"Villacorta Iglesias\", role = c(\"ctb\")), person(\"Gregory R.\" , \"Warnes\", role = c(\"ctb\")), person(\"Stefan\" , \"Wellek\", role = c(\"ctb\")), person(\"Hadley\" , \"Wickham\", role = c(\"ctb\")), person(\"Rand R.\" , \"Wilcox\", role = c(\"ctb\")), person(\"Peter\" , \"Wolf\", role = c(\"ctb\")), person(\"Daniel\" , \"Wollschlaeger\", role = c(\"ctb\")), person(\"Joseph\" , \"Wood\", role = c(\"ctb\")), person(\"Ying\" , \"Wu\", role = c(\"ctb\")), person(\"Thomas\" , \"Yee\", role = c(\"ctb\")), person(\"Achim\" , \"Zeileis\", role = c(\"ctb\")) )", - "Description": "A collection of miscellaneous basic statistic functions and convenience wrappers for efficiently describing data. The author's intention was to create a toolbox, which facilitates the (notoriously time consuming) first descriptive tasks in data analysis, consisting of calculating descriptive statistics, drawing graphical summaries and reporting the results. The package contains furthermore functions to produce documents using MS Word (or PowerPoint) and functions to import data from Excel. Many of the included functions can be found scattered in other packages and other sources written partly by Titans of R. The reason for collecting them here, was primarily to have them consolidated in ONE instead of dozens of packages (which themselves might depend on other packages which are not needed at all), and to provide a common and consistent interface as far as function and arguments naming, NA handling, recycling rules etc. are concerned. Google style guides were used as naming rules (in absence of convincing alternatives). The 'BigCamelCase' style was consequently applied to functions borrowed from contributed R packages as well.", - "Suggests": [ - "RDCOMClient", - "tcltk", - "VGAM", - "R.rsp", - "testthat (>= 3.0.0)" - ], - "Depends": [ - "base", - "stats", - "R (>= 4.2.0)" - ], - "Imports": [ - "graphics", - "grDevices", - "methods", - "MASS", - "utils", - "boot", - "mvtnorm", - "expm", - "Rcpp (>= 0.12.10)", - "rstudioapi", - "Exact", - "gld", - "data.table", - "readxl", - "haven", - "httr", - "withr", - "cli" - ], - "LinkingTo": [ - "Rcpp" - ], - "License": "GPL (>= 2)", - "LazyLoad": "yes", - "LazyData": "yes", - "Additional_repositories": "http://www.omegahat.net/R", - "URL": "https://andrisignorell.github.io/DescTools/, https://github.com/AndriSignorell/DescTools/", - "BugReports": "https://github.com/AndriSignorell/DescTools/issues", - "RoxygenNote": "7.3.2", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "SystemRequirements": "C++17", - "VignetteBuilder": "R.rsp", - "Config/testthat/edition": "3", - "Author": "Andri Signorell [aut, cre] (), Ken Aho [ctb], Andreas Alfons [ctb], Nanina Anderegg [ctb], Tomas Aragon [ctb], Chandima Arachchige [ctb], Antti Arppe [ctb], Adrian Baddeley [ctb], Kamil Barton [ctb], Ben Bolker [ctb], Hans W. Borchers [ctb], Frederico Caeiro [ctb], Stephane Champely [ctb], Daniel Chessel [ctb], Leanne Chhay [ctb], Nicholas Cooper [ctb], Clint Cummins [ctb], Michael Dewey [ctb], Harold C. Doran [ctb], Stephane Dray [ctb], Charles Dupont [ctb], Dirk Eddelbuettel [ctb], Claus Ekstrom [ctb], Martin Elff [ctb], Jeff Enos [ctb], Richard W. Farebrother [ctb], John Fox [ctb], Romain Francois [ctb], Michael Friendly [ctb], Tal Galili [ctb], Matthias Gamer [ctb], Joseph L. Gastwirth [ctb], Vilmantas Gegzna [ctb], Yulia R. Gel [ctb], Sereina Graber [ctb], Juergen Gross [ctb], Gabor Grothendieck [ctb], Frank E. Harrell Jr [ctb], Richard Heiberger [ctb], Michael Hoehle [ctb], Christian W. Hoffmann [ctb], Soeren Hojsgaard [ctb], Torsten Hothorn [ctb], Markus Huerzeler [ctb], Wallace W. Hui [ctb], Pete Hurd [ctb], Rob J. Hyndman [ctb], Christopher Jackson [ctb], Matthias Kohl [ctb], Mikko Korpela [ctb], Max Kuhn [ctb], Detlew Labes [ctb], Friederich Leisch [ctb], Jim Lemon [ctb], Dong Li [ctb], Martin Maechler [ctb], Arni Magnusson [ctb], Ben Mainwaring [ctb], Daniel Malter [ctb], George Marsaglia [ctb], John Marsaglia [ctb], Alina Matei [ctb], David Meyer [ctb], Weiwen Miao [ctb], Giovanni Millo [ctb], Yongyi Min [ctb], David Mitchell [ctb], Cyril Flurin Moser [ctb], Franziska Mueller [ctb], Markus Naepflin [ctb], Danielle Navarro [ctb], Henric Nilsson [ctb], Klaus Nordhausen [ctb], Derek Ogle [ctb], Hong Ooi [ctb], Nick Parsons [ctb], Sandrine Pavoine [ctb], Tony Plate [ctb], Luke Prendergast [ctb], Roland Rapold [ctb], William Revelle [ctb], Tyler Rinker [ctb], Brian D. Ripley [ctb], Caroline Rodriguez [ctb], Nathan Russell [ctb], Nick Sabbe [ctb], Ralph Scherer [ctb], Venkatraman E. Seshan [ctb], Michael Smithson [ctb], Greg Snow [ctb], Karline Soetaert [ctb], Werner A. Stahel [ctb], Alec Stephenson [ctb], Mark Stevenson [ctb], Ralf Stubner [ctb], Matthias Templ [ctb], Duncan Temple Lang [ctb], Terry Therneau [ctb], Yves Tille [ctb], Luis Torgo [ctb], Adrian Trapletti [ctb], Joshua Ulrich [ctb], Kevin Ushey [ctb], Jeremy VanDerWal [ctb], Bill Venables [ctb], John Verzani [ctb], Pablo J. Villacorta Iglesias [ctb], Gregory R. Warnes [ctb], Stefan Wellek [ctb], Hadley Wickham [ctb], Rand R. Wilcox [ctb], Peter Wolf [ctb], Daniel Wollschlaeger [ctb], Joseph Wood [ctb], Ying Wu [ctb], Thomas Yee [ctb], Achim Zeileis [ctb]", - "Maintainer": "Andri Signorell ", - "Repository": "CRAN" - }, - "Exact": { - "Package": "Exact", - "Version": "3.3", - "Source": "Repository", - "Type": "Package", - "Title": "Unconditional Exact Test", - "Authors@R": "person(\"Peter\", \"Calhoun\", email=\"calhoun.peter@gmail.com\", role=c(\"aut\", \"cre\"))", - "Author": "Peter Calhoun [aut, cre]", - "Maintainer": "Peter Calhoun ", - "Description": "Performs unconditional exact tests and power calculations for 2x2 contingency tables. For comparing two independent proportions, performs Barnard's test (1945) using the original CSM test (Barnard, 1947 ), using Fisher's p-value referred to as Boschloo's test (1970) , or using a Z-statistic (Suissa and Shuster, 1985, ). For comparing two binary proportions, performs unconditional exact test using McNemar's Z-statistic (Berger and Sidik, 2003, ), using McNemar's conditional p-value, using McNemar's Z-statistic with continuity correction, or using CSM test. Calculates confidence intervals for the difference in proportion. This package interacts with pre-computed data available through the ExactData R package, which is available in a 'drat' repository. Install the ExactData R package from GitHub at . The ExactData R package is approximately 85 MB.", - "License": "GPL-2", - "Depends": [ - "R (>= 3.5.0)" - ], - "Imports": [ - "graphics", - "stats", - "utils", - "rootSolve" - ], - "Suggests": [ - "ExactData" - ], - "Additional_repositories": "https://pcalhoun1.github.io/drat", - "NeedsCompilation": "no", - "Repository": "CRAN" - }, - "MASS": { - "Package": "MASS", - "Version": "7.3-64", - "Source": "Repository", - "Priority": "recommended", - "Date": "2025-01-06", - "Revision": "$Rev: 3680 $", - "Depends": [ - "R (>= 4.4.0)", - "grDevices", - "graphics", - "stats", - "utils" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "lattice", - "nlme", - "nnet", - "survival" - ], - "Authors@R": "c(person(\"Brian\", \"Ripley\", role = c(\"aut\", \"cre\", \"cph\"), email = \"Brian.Ripley@R-project.org\"), person(\"Bill\", \"Venables\", role = c(\"aut\", \"cph\")), person(c(\"Douglas\", \"M.\"), \"Bates\", role = \"ctb\"), person(\"Kurt\", \"Hornik\", role = \"trl\", comment = \"partial port ca 1998\"), person(\"Albrecht\", \"Gebhardt\", role = \"trl\", comment = \"partial port ca 1998\"), person(\"David\", \"Firth\", role = \"ctb\", comment = \"support functions for polr\"))", - "Description": "Functions and datasets to support Venables and Ripley, \"Modern Applied Statistics with S\" (4th edition, 2002).", - "Title": "Support Functions and Datasets for Venables and Ripley's MASS", - "LazyData": "yes", - "ByteCompile": "yes", - "License": "GPL-2 | GPL-3", - "URL": "http://www.stats.ox.ac.uk/pub/MASS4/", - "Contact": "", - "NeedsCompilation": "yes", - "Author": "Brian Ripley [aut, cre, cph], Bill Venables [aut, cph], Douglas M. Bates [ctb], Kurt Hornik [trl] (partial port ca 1998), Albrecht Gebhardt [trl] (partial port ca 1998), David Firth [ctb] (support functions for polr)", - "Maintainer": "Brian Ripley ", - "Repository": "CRAN" - }, - "Matrix": { - "Package": "Matrix", - "Version": "1.7-2", - "Source": "Repository", - "VersionNote": "do also bump src/version.h, inst/include/Matrix/version.h", - "Date": "2025-01-20", - "Priority": "recommended", - "Title": "Sparse and Dense Matrix Classes and Methods", - "Description": "A rich hierarchy of sparse and dense matrix classes, including general, symmetric, triangular, and diagonal matrices with numeric, logical, or pattern entries. Efficient methods for operating on such matrices, often wrapping the 'BLAS', 'LAPACK', and 'SuiteSparse' libraries.", - "License": "GPL (>= 2) | file LICENCE", - "URL": "https://Matrix.R-forge.R-project.org", - "BugReports": "https://R-forge.R-project.org/tracker/?atid=294&group_id=61", - "Contact": "Matrix-authors@R-project.org", - "Authors@R": "c(person(\"Douglas\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"Martin\", \"Maechler\", role = c(\"aut\", \"cre\"), email = \"mmaechler+Matrix@gmail.com\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Mikael\", \"Jagan\", role = \"aut\", comment = c(ORCID = \"0000-0002-3542-2938\")), person(\"Timothy A.\", \"Davis\", role = \"ctb\", comment = c(ORCID = \"0000-0001-7614-6899\", \"SuiteSparse libraries\", \"collaborators listed in dir(system.file(\\\"doc\\\", \\\"SuiteSparse\\\", package=\\\"Matrix\\\"), pattern=\\\"License\\\", full.names=TRUE, recursive=TRUE)\")), person(\"George\", \"Karypis\", role = \"ctb\", comment = c(ORCID = \"0000-0003-2753-1437\", \"METIS library\", \"Copyright: Regents of the University of Minnesota\")), person(\"Jason\", \"Riedy\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4345-4200\", \"GNU Octave's condest() and onenormest()\", \"Copyright: Regents of the University of California\")), person(\"Jens\", \"Oehlschlägel\", role = \"ctb\", comment = \"initial nearPD()\"), person(\"R Core Team\", role = \"ctb\", comment = c(ROR = \"02zz1nj61\", \"base R's matrix implementation\")))", - "Depends": [ - "R (>= 4.4)", - "methods" - ], - "Imports": [ - "grDevices", - "graphics", - "grid", - "lattice", - "stats", - "utils" - ], - "Suggests": [ - "MASS", - "datasets", - "sfsmisc", - "tools" - ], - "Enhances": [ - "SparseM", - "graph" - ], - "LazyData": "no", - "LazyDataNote": "not possible, since we use data/*.R and our S4 classes", - "BuildResaveData": "no", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Douglas Bates [aut] (), Martin Maechler [aut, cre] (), Mikael Jagan [aut] (), Timothy A. Davis [ctb] (, SuiteSparse libraries, collaborators listed in dir(system.file(\"doc\", \"SuiteSparse\", package=\"Matrix\"), pattern=\"License\", full.names=TRUE, recursive=TRUE)), George Karypis [ctb] (, METIS library, Copyright: Regents of the University of Minnesota), Jason Riedy [ctb] (, GNU Octave's condest() and onenormest(), Copyright: Regents of the University of California), Jens Oehlschlägel [ctb] (initial nearPD()), R Core Team [ctb] (02zz1nj61, base R's matrix implementation)", - "Maintainer": "Martin Maechler ", - "Repository": "CRAN" - }, - "R.cache": { - "Package": "R.cache", - "Version": "0.16.0", - "Source": "Repository", - "Depends": [ - "R (>= 2.14.0)" - ], - "Imports": [ - "utils", - "R.methodsS3 (>= 1.8.1)", - "R.oo (>= 1.24.0)", - "R.utils (>= 2.10.1)", - "digest (>= 0.6.13)" - ], - "Title": "Fast and Light-Weight Caching (Memoization) of Objects and Results to Speed Up Computations", - "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", - "Author": "Henrik Bengtsson [aut, cre, cph]", - "Maintainer": "Henrik Bengtsson ", - "Description": "Memoization can be used to speed up repetitive and computational expensive function calls. The first time a function that implements memoization is called the results are stored in a cache memory. The next time the function is called with the same set of parameters, the results are momentarily retrieved from the cache avoiding repeating the calculations. With this package, any R object can be cached in a key-value storage where the key can be an arbitrary set of R objects. The cache memory is persistent (on the file system).", - "License": "LGPL (>= 2.1)", - "LazyLoad": "TRUE", - "URL": "https://github.com/HenrikBengtsson/R.cache", - "BugReports": "https://github.com/HenrikBengtsson/R.cache/issues", - "RoxygenNote": "7.2.1", - "NeedsCompilation": "no", - "Repository": "CRAN" - }, - "R.methodsS3": { - "Package": "R.methodsS3", - "Version": "1.8.2", - "Source": "Repository", - "Depends": [ - "R (>= 2.13.0)" - ], - "Imports": [ - "utils" - ], - "Suggests": [ - "codetools" - ], - "Title": "S3 Methods Simplified", - "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", - "Author": "Henrik Bengtsson [aut, cre, cph]", - "Maintainer": "Henrik Bengtsson ", - "Description": "Methods that simplify the setup of S3 generic functions and S3 methods. Major effort has been made in making definition of methods as simple as possible with a minimum of maintenance for package developers. For example, generic functions are created automatically, if missing, and naming conflict are automatically solved, if possible. The method setMethodS3() is a good start for those who in the future may want to migrate to S4. This is a cross-platform package implemented in pure R that generates standard S3 methods.", - "License": "LGPL (>= 2.1)", - "LazyLoad": "TRUE", - "URL": "https://github.com/HenrikBengtsson/R.methodsS3", - "BugReports": "https://github.com/HenrikBengtsson/R.methodsS3/issues", - "NeedsCompilation": "no", - "Repository": "CRAN" - }, - "R.oo": { - "Package": "R.oo", - "Version": "1.27.0", - "Source": "Repository", - "Depends": [ - "R (>= 2.13.0)", - "R.methodsS3 (>= 1.8.2)" - ], - "Imports": [ - "methods", - "utils" - ], - "Suggests": [ - "tools" - ], - "Title": "R Object-Oriented Programming with or without References", - "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", - "Author": "Henrik Bengtsson [aut, cre, cph]", - "Maintainer": "Henrik Bengtsson ", - "Description": "Methods and classes for object-oriented programming in R with or without references. Large effort has been made on making definition of methods as simple as possible with a minimum of maintenance for package developers. The package has been developed since 2001 and is now considered very stable. This is a cross-platform package implemented in pure R that defines standard S3 classes without any tricks.", - "License": "LGPL (>= 2.1)", - "LazyLoad": "TRUE", - "URL": "https://github.com/HenrikBengtsson/R.oo", - "BugReports": "https://github.com/HenrikBengtsson/R.oo/issues", - "NeedsCompilation": "no", - "Repository": "CRAN" - }, - "R.utils": { - "Package": "R.utils", - "Version": "2.12.3", - "Source": "Repository", - "Depends": [ - "R (>= 2.14.0)", - "R.oo" - ], - "Imports": [ - "methods", - "utils", - "tools", - "R.methodsS3" - ], - "Suggests": [ - "datasets", - "digest (>= 0.6.10)" - ], - "Title": "Various Programming Utilities", - "Authors@R": "c(person(\"Henrik\", \"Bengtsson\", role=c(\"aut\", \"cre\", \"cph\"), email = \"henrikb@braju.com\"))", - "Author": "Henrik Bengtsson [aut, cre, cph]", - "Maintainer": "Henrik Bengtsson ", - "Description": "Utility functions useful when programming and developing R packages.", - "License": "LGPL (>= 2.1)", - "LazyLoad": "TRUE", - "URL": "https://henrikbengtsson.github.io/R.utils/, https://github.com/HenrikBengtsson/R.utils", - "BugReports": "https://github.com/HenrikBengtsson/R.utils/issues", - "NeedsCompilation": "no", - "Repository": "CRAN" - }, - "R6": { - "Package": "R6", - "Version": "2.6.0", - "Source": "Repository", - "Title": "Encapsulated Classes with Reference Semantics", - "Authors@R": "c( person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Creates classes with reference semantics, similar to R's built-in reference classes. Compared to reference classes, R6 classes are simpler and lighter-weight, and they are not built on S4 classes so they do not require the methods package. These classes allow public and private members, and they support inheritance, even when the classes are defined in different packages.", - "License": "MIT + file LICENSE", - "URL": "https://r6.r-lib.org, https://github.com/r-lib/R6", - "BugReports": "https://github.com/r-lib/R6/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Suggests": [ - "lobstr", - "testthat (>= 3.0.0)" - ], - "Config/Needs/website": "tidyverse/tidytemplate, ggplot2, microbenchmark, scales", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Winston Chang ", - "Repository": "CRAN" - }, - "RColorBrewer": { - "Package": "RColorBrewer", - "Version": "1.1-3", - "Source": "Repository", - "Date": "2022-04-03", - "Title": "ColorBrewer Palettes", - "Authors@R": "c(person(given = \"Erich\", family = \"Neuwirth\", role = c(\"aut\", \"cre\"), email = \"erich.neuwirth@univie.ac.at\"))", - "Author": "Erich Neuwirth [aut, cre]", - "Maintainer": "Erich Neuwirth ", - "Depends": [ - "R (>= 2.0.0)" - ], - "Description": "Provides color schemes for maps (and other graphics) designed by Cynthia Brewer as described at http://colorbrewer2.org.", - "License": "Apache License 2.0", - "NeedsCompilation": "no", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "Rcpp": { - "Package": "Rcpp", - "Version": "1.0.14", - "Source": "Repository", - "Title": "Seamless R and C++ Integration", - "Date": "2025-01-11", - "Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Romain\", \"Francois\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"JJ\", \"Allaire\", role = \"aut\", comment = c(ORCID = \"0000-0003-0174-9868\")), person(\"Kevin\", \"Ushey\", role = \"aut\", comment = c(ORCID = \"0000-0003-2880-7407\")), person(\"Qiang\", \"Kou\", role = \"aut\", comment = c(ORCID = \"0000-0001-6786-5453\")), person(\"Nathan\", \"Russell\", role = \"aut\"), person(\"Iñaki\", \"Ucar\", role = \"aut\", comment = c(ORCID = \"0000-0001-6403-5550\")), person(\"Doug\", \"Bates\", role = \"aut\", comment = c(ORCID = \"0000-0001-8316-9503\")), person(\"John\", \"Chambers\", role = \"aut\"))", - "Description": "The 'Rcpp' package provides R functions as well as C++ classes which offer a seamless integration of R and C++. Many R data types and objects can be mapped back and forth to C++ equivalents which facilitates both writing of new code as well as easier integration of third-party libraries. Documentation about 'Rcpp' is provided by several vignettes included in this package, via the 'Rcpp Gallery' site at , the paper by Eddelbuettel and Francois (2011, ), the book by Eddelbuettel (2013, ) and the paper by Eddelbuettel and Balamuta (2018, ); see 'citation(\"Rcpp\")' for details.", - "Imports": [ - "methods", - "utils" - ], - "Suggests": [ - "tinytest", - "inline", - "rbenchmark", - "pkgKitten (>= 0.1.2)" - ], - "URL": "https://www.rcpp.org, https://dirk.eddelbuettel.com/code/rcpp.html, https://github.com/RcppCore/Rcpp", - "License": "GPL (>= 2)", - "BugReports": "https://github.com/RcppCore/Rcpp/issues", - "MailingList": "rcpp-devel@lists.r-forge.r-project.org", - "RoxygenNote": "6.1.1", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Dirk Eddelbuettel [aut, cre] (), Romain Francois [aut] (), JJ Allaire [aut] (), Kevin Ushey [aut] (), Qiang Kou [aut] (), Nathan Russell [aut], Iñaki Ucar [aut] (), Doug Bates [aut] (), John Chambers [aut]", - "Maintainer": "Dirk Eddelbuettel ", - "Repository": "CRAN" - }, - "arrow": { - "Package": "arrow", - "Version": "17.0.0.1", - "Source": "Repository", - "Title": "Integration to 'Apache' 'Arrow'", - "Authors@R": "c( person(\"Neal\", \"Richardson\", email = \"neal.p.richardson@gmail.com\", role = c(\"aut\")), person(\"Ian\", \"Cook\", email = \"ianmcook@gmail.com\", role = c(\"aut\")), person(\"Nic\", \"Crane\", email = \"thisisnic@gmail.com\", role = c(\"aut\")), person(\"Dewey\", \"Dunnington\", role = c(\"aut\"), email = \"dewey@fishandwhistle.net\", comment = c(ORCID = \"0000-0002-9415-4582\")), person(\"Romain\", \"Fran\\u00e7ois\", role = c(\"aut\"), comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Jonathan\", \"Keane\", email = \"jkeane@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Drago\\u0219\", \"Moldovan-Gr\\u00fcnfeld\", email = \"dragos.mold@gmail.com\", role = c(\"aut\")), person(\"Jeroen\", \"Ooms\", email = \"jeroen@berkeley.edu\", role = c(\"aut\")), person(\"Jacob\", \"Wujciak-Jens\", email = \"jacob@wujciak.de\", role = c(\"aut\")), person(\"Javier\", \"Luraschi\", email = \"javier@rstudio.com\", role = c(\"ctb\")), person(\"Karl\", \"Dunkle Werner\", email = \"karldw@users.noreply.github.com\", role = c(\"ctb\"), comment = c(ORCID = \"0000-0003-0523-7309\")), person(\"Jeffrey\", \"Wong\", email = \"jeffreyw@netflix.com\", role = c(\"ctb\")), person(\"Apache Arrow\", email = \"dev@arrow.apache.org\", role = c(\"aut\", \"cph\")) )", - "Description": "'Apache' 'Arrow' is a cross-language development platform for in-memory data. It specifies a standardized language-independent columnar memory format for flat and hierarchical data, organized for efficient analytic operations on modern hardware. This package provides an interface to the 'Arrow C++' library.", - "Depends": [ - "R (>= 4.0)" - ], - "License": "Apache License (>= 2.0)", - "URL": "https://github.com/apache/arrow/, https://arrow.apache.org/docs/r/", - "BugReports": "https://github.com/apache/arrow/issues", - "Encoding": "UTF-8", - "Language": "en-US", - "SystemRequirements": "C++17; for AWS S3 support on Linux, libcurl and openssl (optional); cmake >= 3.16 (build-time only, and only for full source build)", - "Biarch": "true", - "Imports": [ - "assertthat", - "bit64 (>= 0.9-7)", - "glue", - "methods", - "purrr", - "R6", - "rlang (>= 1.0.0)", - "stats", - "tidyselect (>= 1.0.0)", - "utils", - "vctrs" - ], - "RoxygenNote": "7.3.1", - "Config/testthat/edition": "3", - "Config/build/bootstrap": "TRUE", - "Suggests": [ - "blob", - "curl", - "cli", - "DBI", - "dbplyr", - "decor", - "distro", - "dplyr", - "duckdb (>= 0.2.8)", - "hms", - "jsonlite", - "knitr", - "lubridate", - "pillar", - "pkgload", - "reticulate", - "rmarkdown", - "stringi", - "stringr", - "sys", - "testthat (>= 3.1.0)", - "tibble", - "tzdb", - "withr" - ], - "LinkingTo": [ - "cpp11 (>= 0.4.2)" - ], - "Collate": "'arrowExports.R' 'enums.R' 'arrow-object.R' 'type.R' 'array-data.R' 'arrow-datum.R' 'array.R' 'arrow-info.R' 'arrow-package.R' 'arrow-tabular.R' 'buffer.R' 'chunked-array.R' 'io.R' 'compression.R' 'scalar.R' 'compute.R' 'config.R' 'csv.R' 'dataset.R' 'dataset-factory.R' 'dataset-format.R' 'dataset-partition.R' 'dataset-scan.R' 'dataset-write.R' 'dictionary.R' 'dplyr-across.R' 'dplyr-arrange.R' 'dplyr-by.R' 'dplyr-collect.R' 'dplyr-count.R' 'dplyr-datetime-helpers.R' 'dplyr-distinct.R' 'dplyr-eval.R' 'dplyr-filter.R' 'dplyr-funcs-agg.R' 'dplyr-funcs-augmented.R' 'dplyr-funcs-conditional.R' 'dplyr-funcs-datetime.R' 'dplyr-funcs-doc.R' 'dplyr-funcs-math.R' 'dplyr-funcs-simple.R' 'dplyr-funcs-string.R' 'dplyr-funcs-type.R' 'expression.R' 'dplyr-funcs.R' 'dplyr-glimpse.R' 'dplyr-group-by.R' 'dplyr-join.R' 'dplyr-mutate.R' 'dplyr-select.R' 'dplyr-slice.R' 'dplyr-summarize.R' 'dplyr-union.R' 'record-batch.R' 'table.R' 'dplyr.R' 'duckdb.R' 'extension.R' 'feather.R' 'field.R' 'filesystem.R' 'flight.R' 'install-arrow.R' 'ipc-stream.R' 'json.R' 'memory-pool.R' 'message.R' 'metadata.R' 'parquet.R' 'python.R' 'query-engine.R' 'record-batch-reader.R' 'record-batch-writer.R' 'reexports-bit64.R' 'reexports-tidyselect.R' 'schema.R' 'udf.R' 'util.R'", - "NeedsCompilation": "yes", - "Author": "Neal Richardson [aut], Ian Cook [aut], Nic Crane [aut], Dewey Dunnington [aut] (), Romain François [aut] (), Jonathan Keane [aut, cre], Dragoș Moldovan-Grünfeld [aut], Jeroen Ooms [aut], Jacob Wujciak-Jens [aut], Javier Luraschi [ctb], Karl Dunkle Werner [ctb] (), Jeffrey Wong [ctb], Apache Arrow [aut, cph]", - "Maintainer": "Jonathan Keane ", - "Repository": "RSPM" - }, - "askpass": { - "Package": "askpass", - "Version": "1.2.1", - "Source": "Repository", - "Type": "Package", - "Title": "Password Entry Utilities for R, Git, and SSH", - "Authors@R": "person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\"))", - "Description": "Cross-platform utilities for prompting the user for credentials or a passphrase, for example to authenticate with a server or read a protected key. Includes native programs for MacOS and Windows, hence no 'tcltk' is required. Password entry can be invoked in two different ways: directly from R via the askpass() function, or indirectly as password-entry back-end for 'ssh-agent' or 'git-credential' via the SSH_ASKPASS and GIT_ASKPASS environment variables. Thereby the user can be prompted for credentials or a passphrase if needed when R calls out to git or ssh.", - "License": "MIT + file LICENSE", - "URL": "https://r-lib.r-universe.dev/askpass", - "BugReports": "https://github.com/r-lib/askpass/issues", - "Encoding": "UTF-8", - "Imports": [ - "sys (>= 2.1)" - ], - "RoxygenNote": "7.2.3", - "Suggests": [ - "testthat" - ], - "Language": "en-US", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] ()", - "Maintainer": "Jeroen Ooms ", - "Repository": "RSPM" - }, - "assertthat": { - "Package": "assertthat", - "Version": "0.2.1", - "Source": "Repository", - "Title": "Easy Pre and Post Assertions", - "Authors@R": "person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", c(\"aut\", \"cre\"))", - "Description": "An extension to stopifnot() that makes it easy to declare the pre and post conditions that you code should satisfy, while also producing friendly error messages so that your users know what's gone wrong.", - "License": "GPL-3", - "Imports": [ - "tools" - ], - "Suggests": [ - "testthat", - "covr" - ], - "RoxygenNote": "6.0.1", - "Collate": "'assert-that.r' 'on-failure.r' 'assertions-file.r' 'assertions-scalar.R' 'assertions.r' 'base.r' 'base-comparison.r' 'base-is.r' 'base-logical.r' 'base-misc.r' 'utils.r' 'validate-that.R'", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "backports": { - "Package": "backports", - "Version": "1.5.0", - "Source": "Repository", - "Type": "Package", - "Title": "Reimplementations of Functions Introduced Since R-3.0.0", - "Authors@R": "c( person(\"Michel\", \"Lang\", NULL, \"michellang@gmail.com\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Duncan\", \"Murdoch\", NULL, \"murdoch.duncan@gmail.com\", role = c(\"aut\")), person(\"R Core Team\", role = \"aut\"))", - "Maintainer": "Michel Lang ", - "Description": "Functions introduced or changed since R v3.0.0 are re-implemented in this package. The backports are conditionally exported in order to let R resolve the function name to either the implemented backport, or the respective base version, if available. Package developers can make use of new functions or arguments by selectively importing specific backports to support older installations.", - "URL": "https://github.com/r-lib/backports", - "BugReports": "https://github.com/r-lib/backports/issues", - "License": "GPL-2 | GPL-3", - "NeedsCompilation": "yes", - "ByteCompile": "yes", - "Depends": [ - "R (>= 3.0.0)" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "Author": "Michel Lang [cre, aut] (), Duncan Murdoch [aut], R Core Team [aut]", - "Repository": "RSPM" - }, - "base64enc": { - "Package": "base64enc", - "Version": "0.1-3", - "Source": "Repository", - "Title": "Tools for base64 encoding", - "Author": "Simon Urbanek ", - "Maintainer": "Simon Urbanek ", - "Depends": [ - "R (>= 2.9.0)" - ], - "Enhances": [ - "png" - ], - "Description": "This package provides tools for handling base64 encoding. It is more flexible than the orphaned base64 package.", - "License": "GPL-2 | GPL-3", - "URL": "http://www.rforge.net/base64enc", - "NeedsCompilation": "yes", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "bit": { - "Package": "bit", - "Version": "4.5.0.1", - "Source": "Repository", - "Type": "Package", - "Title": "Classes and Methods for Fast Memory-Efficient Boolean Selections", - "Date": "2024-09-17", - "Authors@R": "c(person(given = \"Jens\", family = \"Oehlschlägel\", role = c(\"aut\", \"cre\"), email = \"Jens.Oehlschlaegel@truecluster.com\"), person(given = \"Brian\", family = \"Ripley\", role = \"ctb\"))", - "Author": "Jens Oehlschlägel [aut, cre], Brian Ripley [ctb]", - "Maintainer": "Jens Oehlschlägel ", - "Depends": [ - "R (>= 3.4.0)" - ], - "Suggests": [ - "testthat (>= 0.11.0)", - "roxygen2", - "knitr", - "markdown", - "rmarkdown", - "microbenchmark", - "bit64 (>= 4.0.0)", - "ff (>= 4.0.0)" - ], - "Description": "Provided are classes for boolean and skewed boolean vectors, fast boolean methods, fast unique and non-unique integer sorting, fast set operations on sorted and unsorted sets of integers, and foundations for ff (range index, compression, chunked processing).", - "License": "GPL-2 | GPL-3", - "LazyLoad": "yes", - "ByteCompile": "yes", - "Encoding": "UTF-8", - "URL": "https://github.com/truecluster/bit", - "VignetteBuilder": "knitr, rmarkdown", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Repository": "CRAN" - }, - "bit64": { - "Package": "bit64", - "Version": "4.6.0-1", - "Source": "Repository", - "Title": "A S3 Class for Vectors of 64bit Integers", - "Authors@R": "c( person(\"Michael\", \"Chirico\", email = \"michaelchirico4@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Jens\", \"Oehlschlägel\", role = \"aut\"), person(\"Leonardo\", \"Silvestri\", role = \"ctb\"), person(\"Ofek\", \"Shilon\", role = \"ctb\") )", - "Depends": [ - "R (>= 3.4.0)", - "bit (>= 4.0.0)" - ], - "Description": "Package 'bit64' provides serializable S3 atomic 64bit (signed) integers. These are useful for handling database keys and exact counting in +-2^63. WARNING: do not use them as replacement for 32bit integers, integer64 are not supported for subscripting by R-core and they have different semantics when combined with double, e.g. integer64 + double => integer64. Class integer64 can be used in vectors, matrices, arrays and data.frames. Methods are available for coercion from and to logicals, integers, doubles, characters and factors as well as many elementwise and summary functions. Many fast algorithmic operations such as 'match' and 'order' support inter- active data exploration and manipulation and optionally leverage caching.", - "License": "GPL-2 | GPL-3", - "LazyLoad": "yes", - "ByteCompile": "yes", - "URL": "https://github.com/r-lib/bit64", - "Encoding": "UTF-8", - "Imports": [ - "graphics", - "methods", - "stats", - "utils" - ], - "Suggests": [ - "testthat (>= 3.0.3)", - "withr" - ], - "Config/testthat/edition": "3", - "Config/needs/development": "testthat", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Michael Chirico [aut, cre], Jens Oehlschlägel [aut], Leonardo Silvestri [ctb], Ofek Shilon [ctb]", - "Maintainer": "Michael Chirico ", - "Repository": "CRAN" - }, - "boot": { - "Package": "boot", - "Version": "1.3-31", - "Source": "Repository", - "Priority": "recommended", - "Date": "2024-08-28", - "Authors@R": "c(person(\"Angelo\", \"Canty\", role = \"aut\", email = \"cantya@mcmaster.ca\", comment = \"author of original code for S\"), person(\"Brian\", \"Ripley\", role = c(\"aut\", \"trl\"), email = \"ripley@stats.ox.ac.uk\", comment = \"conversion to R, maintainer 1999--2022, author of parallel support\"), person(\"Alessandra R.\", \"Brazzale\", role = c(\"ctb\", \"cre\"), email = \"brazzale@stat.unipd.it\", comment = \"minor bug fixes\"))", - "Maintainer": "Alessandra R. Brazzale ", - "Note": "Maintainers are not available to give advice on using a package they did not author.", - "Description": "Functions and datasets for bootstrapping from the book \"Bootstrap Methods and Their Application\" by A. C. Davison and D. V. Hinkley (1997, CUP), originally written by Angelo Canty for S.", - "Title": "Bootstrap Functions (Originally by Angelo Canty for S)", - "Depends": [ - "R (>= 3.0.0)", - "graphics", - "stats" - ], - "Suggests": [ - "MASS", - "survival" - ], - "LazyData": "yes", - "ByteCompile": "yes", - "License": "Unlimited", - "NeedsCompilation": "no", - "Author": "Angelo Canty [aut] (author of original code for S), Brian Ripley [aut, trl] (conversion to R, maintainer 1999--2022, author of parallel support), Alessandra R. Brazzale [ctb, cre] (minor bug fixes)", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "bslib": { - "Package": "bslib", - "Version": "0.9.0", - "Source": "Repository", - "Title": "Custom 'Bootstrap' 'Sass' Themes for 'shiny' and 'rmarkdown'", - "Authors@R": "c( person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Garrick\", \"Aden-Buie\", , \"garrick@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0002-7111-0077\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(, \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Javi\", \"Aguilar\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap colorpicker library\"), person(\"Thomas\", \"Park\", role = c(\"ctb\", \"cph\"), comment = \"Bootswatch library\"), person(, \"PayPal\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap accessibility plugin\") )", - "Description": "Simplifies custom 'CSS' styling of both 'shiny' and 'rmarkdown' via 'Bootstrap' 'Sass'. Supports 'Bootstrap' 3, 4 and 5 as well as their various 'Bootswatch' themes. An interactive widget is also provided for previewing themes in real time.", - "License": "MIT + file LICENSE", - "URL": "https://rstudio.github.io/bslib/, https://github.com/rstudio/bslib", - "BugReports": "https://github.com/rstudio/bslib/issues", - "Depends": [ - "R (>= 2.10)" - ], - "Imports": [ - "base64enc", - "cachem", - "fastmap (>= 1.1.1)", - "grDevices", - "htmltools (>= 0.5.8)", - "jquerylib (>= 0.1.3)", - "jsonlite", - "lifecycle", - "memoise (>= 2.0.1)", - "mime", - "rlang", - "sass (>= 0.4.9)" - ], - "Suggests": [ - "bsicons", - "curl", - "fontawesome", - "future", - "ggplot2", - "knitr", - "magrittr", - "rappdirs", - "rmarkdown (>= 2.7)", - "shiny (> 1.8.1)", - "testthat", - "thematic", - "tools", - "utils", - "withr", - "yaml" - ], - "Config/Needs/deploy": "BH, chiflights22, colourpicker, commonmark, cpp11, cpsievert/chiflights22, cpsievert/histoslider, dplyr, DT, ggplot2, ggridges, gt, hexbin, histoslider, htmlwidgets, lattice, leaflet, lubridate, markdown, modelr, plotly, reactable, reshape2, rprojroot, rsconnect, rstudio/shiny, scales, styler, tibble", - "Config/Needs/routine": "chromote, desc, renv", - "Config/Needs/website": "brio, crosstalk, dplyr, DT, ggplot2, glue, htmlwidgets, leaflet, lorem, palmerpenguins, plotly, purrr, rprojroot, rstudio/htmltools, scales, stringr, tidyr, webshot2", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "true", - "Config/testthat/start-first": "zzzz-bs-sass, fonts, zzz-precompile, theme-*, rmd-*", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "Collate": "'accordion.R' 'breakpoints.R' 'bs-current-theme.R' 'bs-dependencies.R' 'bs-global.R' 'bs-remove.R' 'bs-theme-layers.R' 'bs-theme-preset-bootswatch.R' 'bs-theme-preset-brand.R' 'bs-theme-preset-builtin.R' 'bs-theme-preset.R' 'utils.R' 'bs-theme-preview.R' 'bs-theme-update.R' 'bs-theme.R' 'bslib-package.R' 'buttons.R' 'card.R' 'deprecated.R' 'files.R' 'fill.R' 'imports.R' 'input-dark-mode.R' 'input-switch.R' 'layout.R' 'nav-items.R' 'nav-update.R' 'navbar_options.R' 'navs-legacy.R' 'navs.R' 'onLoad.R' 'page.R' 'popover.R' 'precompiled.R' 'print.R' 'shiny-devmode.R' 'sidebar.R' 'staticimports.R' 'tooltip.R' 'utils-deps.R' 'utils-shiny.R' 'utils-tags.R' 'value-box.R' 'version-default.R' 'versions.R'", - "NeedsCompilation": "no", - "Author": "Carson Sievert [aut, cre] (), Joe Cheng [aut], Garrick Aden-Buie [aut] (), Posit Software, PBC [cph, fnd], Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Javi Aguilar [ctb, cph] (Bootstrap colorpicker library), Thomas Park [ctb, cph] (Bootswatch library), PayPal [ctb, cph] (Bootstrap accessibility plugin)", - "Maintainer": "Carson Sievert ", - "Repository": "CRAN" - }, - "cachem": { - "Package": "cachem", - "Version": "1.1.0", - "Source": "Repository", - "Title": "Cache R Objects with Automatic Pruning", - "Description": "Key-value stores with automatic pruning. Caches can limit either their total size or the age of the oldest object (or both), automatically pruning objects to maintain the constraints.", - "Authors@R": "c( person(\"Winston\", \"Chang\", , \"winston@posit.co\", c(\"aut\", \"cre\")), person(family = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")))", - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "ByteCompile": "true", - "URL": "https://cachem.r-lib.org/, https://github.com/r-lib/cachem", - "Imports": [ - "rlang", - "fastmap (>= 1.2.0)" - ], - "Suggests": [ - "testthat" - ], - "RoxygenNote": "7.2.3", - "Config/Needs/routine": "lobstr", - "Config/Needs/website": "pkgdown", - "NeedsCompilation": "yes", - "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Winston Chang ", - "Repository": "RSPM" - }, - "callr": { - "Package": "callr", - "Version": "3.7.6", - "Source": "Repository", - "Title": "Call R from R", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\", \"cph\"), comment = c(ORCID = \"0000-0001-7098-9676\")), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Ascent Digital Services\", role = c(\"cph\", \"fnd\")) )", - "Description": "It is sometimes useful to perform a computation in a separate R process, without affecting the current R process at all. This packages does exactly that.", - "License": "MIT + file LICENSE", - "URL": "https://callr.r-lib.org, https://github.com/r-lib/callr", - "BugReports": "https://github.com/r-lib/callr/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "processx (>= 3.6.1)", - "R6", - "utils" - ], - "Suggests": [ - "asciicast (>= 2.3.1)", - "cli (>= 1.1.0)", - "mockery", - "ps", - "rprojroot", - "spelling", - "testthat (>= 3.2.0)", - "withr (>= 2.3.0)" - ], - "Config/Needs/website": "r-lib/asciicast, glue, htmlwidgets, igraph, tibble, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.3.1.9000", - "NeedsCompilation": "no", - "Author": "Gábor Csárdi [aut, cre, cph] (), Winston Chang [aut], Posit Software, PBC [cph, fnd], Ascent Digital Services [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "RSPM" - }, - "cellranger": { - "Package": "cellranger", - "Version": "1.1.0", - "Source": "Repository", - "Title": "Translate Spreadsheet Cell Ranges to Rows and Columns", - "Authors@R": "c( person(\"Jennifer\", \"Bryan\", , \"jenny@stat.ubc.ca\", c(\"cre\", \"aut\")), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", \"ctb\") )", - "Description": "Helper functions to work with spreadsheets and the \"A1:D10\" style of cell range specification.", - "Depends": [ - "R (>= 3.0.0)" - ], - "License": "MIT + file LICENSE", - "LazyData": "true", - "URL": "https://github.com/rsheets/cellranger", - "BugReports": "https://github.com/rsheets/cellranger/issues", - "Suggests": [ - "covr", - "testthat (>= 1.0.0)", - "knitr", - "rmarkdown" - ], - "RoxygenNote": "5.0.1.9000", - "VignetteBuilder": "knitr", - "Imports": [ - "rematch", - "tibble" - ], - "NeedsCompilation": "no", - "Author": "Jennifer Bryan [cre, aut], Hadley Wickham [ctb]", - "Maintainer": "Jennifer Bryan ", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "checkmate": { - "Package": "checkmate", - "Version": "2.3.2", - "Source": "Repository", - "Type": "Package", - "Title": "Fast and Versatile Argument Checks", - "Description": "Tests and assertions to perform frequent argument checks. A substantial part of the package was written in C to minimize any worries about execution time overhead.", - "Authors@R": "c( person(\"Michel\", \"Lang\", NULL, \"michellang@gmail.com\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Bernd\", \"Bischl\", NULL, \"bernd_bischl@gmx.net\", role = \"ctb\"), person(\"Dénes\", \"Tóth\", NULL, \"toth.denes@kogentum.hu\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4262-3217\")) )", - "URL": "https://mllg.github.io/checkmate/, https://github.com/mllg/checkmate", - "URLNote": "https://github.com/mllg/checkmate", - "BugReports": "https://github.com/mllg/checkmate/issues", - "NeedsCompilation": "yes", - "ByteCompile": "yes", - "Encoding": "UTF-8", - "Depends": [ - "R (>= 3.0.0)" - ], - "Imports": [ - "backports (>= 1.1.0)", - "utils" - ], - "Suggests": [ - "R6", - "fastmatch", - "data.table (>= 1.9.8)", - "devtools", - "ggplot2", - "knitr", - "magrittr", - "microbenchmark", - "rmarkdown", - "testthat (>= 3.0.4)", - "tinytest (>= 1.1.0)", - "tibble" - ], - "License": "BSD_3_clause + file LICENSE", - "VignetteBuilder": "knitr", - "RoxygenNote": "7.3.2", - "Collate": "'AssertCollection.R' 'allMissing.R' 'anyInfinite.R' 'anyMissing.R' 'anyNaN.R' 'asInteger.R' 'assert.R' 'helper.R' 'makeExpectation.R' 'makeTest.R' 'makeAssertion.R' 'checkAccess.R' 'checkArray.R' 'checkAtomic.R' 'checkAtomicVector.R' 'checkCharacter.R' 'checkChoice.R' 'checkClass.R' 'checkComplex.R' 'checkCount.R' 'checkDataFrame.R' 'checkDataTable.R' 'checkDate.R' 'checkDirectoryExists.R' 'checkDisjunct.R' 'checkDouble.R' 'checkEnvironment.R' 'checkFALSE.R' 'checkFactor.R' 'checkFileExists.R' 'checkFlag.R' 'checkFormula.R' 'checkFunction.R' 'checkInt.R' 'checkInteger.R' 'checkIntegerish.R' 'checkList.R' 'checkLogical.R' 'checkMatrix.R' 'checkMultiClass.R' 'checkNamed.R' 'checkNames.R' 'checkNull.R' 'checkNumber.R' 'checkNumeric.R' 'checkOS.R' 'checkPOSIXct.R' 'checkPathForOutput.R' 'checkPermutation.R' 'checkR6.R' 'checkRaw.R' 'checkScalar.R' 'checkScalarNA.R' 'checkSetEqual.R' 'checkString.R' 'checkSubset.R' 'checkTRUE.R' 'checkTibble.R' 'checkVector.R' 'coalesce.R' 'isIntegerish.R' 'matchArg.R' 'qassert.R' 'qassertr.R' 'vname.R' 'wfwl.R' 'zzz.R'", - "Author": "Michel Lang [cre, aut] (), Bernd Bischl [ctb], Dénes Tóth [ctb] ()", - "Maintainer": "Michel Lang ", - "Repository": "RSPM" - }, - "class": { - "Package": "class", - "Version": "7.3-23", - "Source": "Repository", - "Priority": "recommended", - "Date": "2025-01-01", - "Depends": [ - "R (>= 3.0.0)", - "stats", - "utils" - ], - "Imports": [ - "MASS" - ], - "Authors@R": "c(person(\"Brian\", \"Ripley\", role = c(\"aut\", \"cre\", \"cph\"), email = \"Brian.Ripley@R-project.org\"), person(\"William\", \"Venables\", role = \"cph\"))", - "Description": "Various functions for classification, including k-nearest neighbour, Learning Vector Quantization and Self-Organizing Maps.", - "Title": "Functions for Classification", - "ByteCompile": "yes", - "License": "GPL-2 | GPL-3", - "URL": "http://www.stats.ox.ac.uk/pub/MASS4/", - "NeedsCompilation": "yes", - "Author": "Brian Ripley [aut, cre, cph], William Venables [cph]", - "Maintainer": "Brian Ripley ", - "Repository": "CRAN" - }, - "cli": { - "Package": "cli", - "Version": "3.6.4", - "Source": "Repository", - "Title": "Helpers for Developing Command Line Interfaces", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"gabor@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Kirill\", \"Müller\", role = \"ctb\"), person(\"Salim\", \"Brüggemann\", , \"salim-b@pm.me\", role = \"ctb\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A suite of tools to build attractive command line interfaces ('CLIs'), from semantic elements: headings, lists, alerts, paragraphs, etc. Supports custom themes via a 'CSS'-like language. It also contains a number of lower level 'CLI' elements: rules, boxes, trees, and 'Unicode' symbols with 'ASCII' alternatives. It support ANSI colors and text styles as well.", - "License": "MIT + file LICENSE", - "URL": "https://cli.r-lib.org, https://github.com/r-lib/cli", - "BugReports": "https://github.com/r-lib/cli/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "utils" - ], - "Suggests": [ - "callr", - "covr", - "crayon", - "digest", - "glue (>= 1.6.0)", - "grDevices", - "htmltools", - "htmlwidgets", - "knitr", - "methods", - "processx", - "ps (>= 1.3.4.9000)", - "rlang (>= 1.0.2.9003)", - "rmarkdown", - "rprojroot", - "rstudioapi", - "testthat (>= 3.2.0)", - "tibble", - "whoami", - "withr" - ], - "Config/Needs/website": "r-lib/asciicast, bench, brio, cpp11, decor, desc, fansi, prettyunits, sessioninfo, tidyverse/tidytemplate, usethis, vctrs", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Gábor Csárdi [aut, cre], Hadley Wickham [ctb], Kirill Müller [ctb], Salim Brüggemann [ctb] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - }, - "clipr": { - "Package": "clipr", - "Version": "0.8.0", - "Source": "Repository", - "Type": "Package", - "Title": "Read and Write from the System Clipboard", - "Authors@R": "c( person(\"Matthew\", \"Lincoln\", , \"matthew.d.lincoln@gmail.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4387-3384\")), person(\"Louis\", \"Maddox\", role = \"ctb\"), person(\"Steve\", \"Simpson\", role = \"ctb\"), person(\"Jennifer\", \"Bryan\", role = \"ctb\") )", - "Description": "Simple utility functions to read from and write to the Windows, OS X, and X11 clipboards.", - "License": "GPL-3", - "URL": "https://github.com/mdlincoln/clipr, http://matthewlincoln.net/clipr/", - "BugReports": "https://github.com/mdlincoln/clipr/issues", - "Imports": [ - "utils" - ], - "Suggests": [ - "covr", - "knitr", - "rmarkdown", - "rstudioapi (>= 0.5)", - "testthat (>= 2.0.0)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.1.2", - "SystemRequirements": "xclip (https://github.com/astrand/xclip) or xsel (http://www.vergenet.net/~conrad/software/xsel/) for accessing the X11 clipboard, or wl-clipboard (https://github.com/bugaevc/wl-clipboard) for systems using Wayland.", - "NeedsCompilation": "no", - "Author": "Matthew Lincoln [aut, cre] (), Louis Maddox [ctb], Steve Simpson [ctb], Jennifer Bryan [ctb]", - "Maintainer": "Matthew Lincoln ", - "Repository": "RSPM" - }, - "colorspace": { - "Package": "colorspace", - "Version": "2.1-1", - "Source": "Repository", - "Date": "2024-07-26", - "Title": "A Toolbox for Manipulating and Assessing Colors and Palettes", - "Authors@R": "c(person(given = \"Ross\", family = \"Ihaka\", role = \"aut\", email = \"ihaka@stat.auckland.ac.nz\"), person(given = \"Paul\", family = \"Murrell\", role = \"aut\", email = \"paul@stat.auckland.ac.nz\", comment = c(ORCID = \"0000-0002-3224-8858\")), person(given = \"Kurt\", family = \"Hornik\", role = \"aut\", email = \"Kurt.Hornik@R-project.org\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(given = c(\"Jason\", \"C.\"), family = \"Fisher\", role = \"aut\", email = \"jfisher@usgs.gov\", comment = c(ORCID = \"0000-0001-9032-8912\")), person(given = \"Reto\", family = \"Stauffer\", role = \"aut\", email = \"Reto.Stauffer@uibk.ac.at\", comment = c(ORCID = \"0000-0002-3798-5507\")), person(given = c(\"Claus\", \"O.\"), family = \"Wilke\", role = \"aut\", email = \"wilke@austin.utexas.edu\", comment = c(ORCID = \"0000-0002-7470-9261\")), person(given = c(\"Claire\", \"D.\"), family = \"McWhite\", role = \"aut\", email = \"claire.mcwhite@utmail.utexas.edu\", comment = c(ORCID = \"0000-0001-7346-3047\")), person(given = \"Achim\", family = \"Zeileis\", role = c(\"aut\", \"cre\"), email = \"Achim.Zeileis@R-project.org\", comment = c(ORCID = \"0000-0003-0918-3766\")))", - "Description": "Carries out mapping between assorted color spaces including RGB, HSV, HLS, CIEXYZ, CIELUV, HCL (polar CIELUV), CIELAB, and polar CIELAB. Qualitative, sequential, and diverging color palettes based on HCL colors are provided along with corresponding ggplot2 color scales. Color palette choice is aided by an interactive app (with either a Tcl/Tk or a shiny graphical user interface) and shiny apps with an HCL color picker and a color vision deficiency emulator. Plotting functions for displaying and assessing palettes include color swatches, visualizations of the HCL space, and trajectories in HCL and/or RGB spectrum. Color manipulation functions include: desaturation, lightening/darkening, mixing, and simulation of color vision deficiencies (deutanomaly, protanomaly, tritanomaly). Details can be found on the project web page at and in the accompanying scientific paper: Zeileis et al. (2020, Journal of Statistical Software, ).", - "Depends": [ - "R (>= 3.0.0)", - "methods" - ], - "Imports": [ - "graphics", - "grDevices", - "stats" - ], - "Suggests": [ - "datasets", - "utils", - "KernSmooth", - "MASS", - "kernlab", - "mvtnorm", - "vcd", - "tcltk", - "shiny", - "shinyjs", - "ggplot2", - "dplyr", - "scales", - "grid", - "png", - "jpeg", - "knitr", - "rmarkdown", - "RColorBrewer", - "rcartocolor", - "scico", - "viridis", - "wesanderson" - ], - "VignetteBuilder": "knitr", - "License": "BSD_3_clause + file LICENSE", - "URL": "https://colorspace.R-Forge.R-project.org/, https://hclwizard.org/", - "BugReports": "https://colorspace.R-Forge.R-project.org/contact.html", - "LazyData": "yes", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "NeedsCompilation": "yes", - "Author": "Ross Ihaka [aut], Paul Murrell [aut] (), Kurt Hornik [aut] (), Jason C. Fisher [aut] (), Reto Stauffer [aut] (), Claus O. Wilke [aut] (), Claire D. McWhite [aut] (), Achim Zeileis [aut, cre] ()", - "Maintainer": "Achim Zeileis ", - "Repository": "RSPM" - }, - "commonmark": { - "Package": "commonmark", - "Version": "1.9.2", - "Source": "Repository", - "Type": "Package", - "Title": "High Performance CommonMark and Github Markdown Rendering in R", - "Authors@R": "c( person(\"Jeroen\", \"Ooms\", ,\"jeroenooms@gmail.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"John MacFarlane\", role = \"cph\", comment = \"Author of cmark\"))", - "Description": "The CommonMark specification defines a rationalized version of markdown syntax. This package uses the 'cmark' reference implementation for converting markdown text into various formats including html, latex and groff man. In addition it exposes the markdown parse tree in xml format. Also includes opt-in support for GFM extensions including tables, autolinks, and strikethrough text.", - "License": "BSD_2_clause + file LICENSE", - "URL": "https://docs.ropensci.org/commonmark/ https://ropensci.r-universe.dev/commonmark", - "BugReports": "https://github.com/r-lib/commonmark/issues", - "Suggests": [ - "curl", - "testthat", - "xml2" - ], - "RoxygenNote": "7.2.3", - "Language": "en-US", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] (), John MacFarlane [cph] (Author of cmark)", - "Maintainer": "Jeroen Ooms ", - "Repository": "RSPM" - }, - "cowplot": { - "Package": "cowplot", - "Version": "1.1.3", - "Source": "Repository", - "Title": "Streamlined Plot Theme and Plot Annotations for 'ggplot2'", - "Authors@R": "person( given = \"Claus O.\", family = \"Wilke\", role = c(\"aut\", \"cre\"), email = \"wilke@austin.utexas.edu\", comment = c(ORCID = \"0000-0002-7470-9261\") )", - "Description": "Provides various features that help with creating publication-quality figures with 'ggplot2', such as a set of themes, functions to align plots and arrange them into complex compound figures, and functions that make it easy to annotate plots and or mix plots with images. The package was originally written for internal use in the Wilke lab, hence the name (Claus O. Wilke's plot package). It has also been used extensively in the book Fundamentals of Data Visualization.", - "URL": "https://wilkelab.org/cowplot/", - "BugReports": "https://github.com/wilkelab/cowplot/issues", - "Depends": [ - "R (>= 3.5.0)" - ], - "Imports": [ - "ggplot2 (>= 3.4.0)", - "grid", - "gtable", - "grDevices", - "methods", - "rlang", - "scales" - ], - "License": "GPL-2", - "Suggests": [ - "Cairo", - "covr", - "dplyr", - "forcats", - "gridGraphics (>= 0.4-0)", - "knitr", - "lattice", - "magick", - "maps", - "PASWR", - "patchwork", - "rmarkdown", - "ragg", - "testthat (>= 1.0.0)", - "tidyr", - "vdiffr (>= 0.3.0)", - "VennDiagram" - ], - "VignetteBuilder": "knitr", - "Collate": "'add_sub.R' 'align_plots.R' 'as_grob.R' 'as_gtable.R' 'axis_canvas.R' 'cowplot.R' 'draw.R' 'get_plot_component.R' 'get_axes.R' 'get_titles.R' 'get_legend.R' 'get_panel.R' 'gtable.R' 'key_glyph.R' 'plot_grid.R' 'save.R' 'set_null_device.R' 'setup.R' 'stamp.R' 'themes.R' 'utils_ggplot2.R'", - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Claus O. Wilke [aut, cre] ()", - "Maintainer": "Claus O. Wilke ", - "Repository": "CRAN" - }, - "cpp11": { - "Package": "cpp11", - "Version": "0.5.1", - "Source": "Repository", - "Title": "A C++11 Interface for R's C Interface", - "Authors@R": "c( person(\"Davis\", \"Vaughan\", email = \"davis@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4777-038X\")), person(\"Jim\",\"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Romain\", \"François\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Benjamin\", \"Kietzman\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides a header only, C++11 interface to R's C interface. Compared to other approaches 'cpp11' strives to be safe against long jumps from the C API as well as C++ exceptions, conform to normal R function semantics and supports interaction with 'ALTREP' vectors.", - "License": "MIT + file LICENSE", - "URL": "https://cpp11.r-lib.org, https://github.com/r-lib/cpp11", - "BugReports": "https://github.com/r-lib/cpp11/issues", - "Depends": [ - "R (>= 4.0.0)" - ], - "Suggests": [ - "bench", - "brio", - "callr", - "cli", - "covr", - "decor", - "desc", - "ggplot2", - "glue", - "knitr", - "lobstr", - "mockery", - "progress", - "rmarkdown", - "scales", - "Rcpp", - "testthat (>= 3.2.0)", - "tibble", - "utils", - "vctrs", - "withr" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Config/Needs/cpp11/cpp_register": "brio, cli, decor, desc, glue, tibble, vctrs", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Davis Vaughan [aut, cre] (), Jim Hester [aut] (), Romain François [aut] (), Benjamin Kietzman [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Davis Vaughan ", - "Repository": "CRAN" - }, - "crayon": { - "Package": "crayon", - "Version": "1.5.3", - "Source": "Repository", - "Title": "Colored Terminal Output", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Brodie\", \"Gaslam\", , \"brodie.gaslam@yahoo.com\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "The crayon package is now superseded. Please use the 'cli' package for new projects. Colored terminal output on terminals that support 'ANSI' color and highlight codes. It also works in 'Emacs' 'ESS'. 'ANSI' color support is automatically detected. Colors and highlighting can be combined and nested. New styles can also be created easily. This package was inspired by the 'chalk' 'JavaScript' project.", - "License": "MIT + file LICENSE", - "URL": "https://r-lib.github.io/crayon/, https://github.com/r-lib/crayon", - "BugReports": "https://github.com/r-lib/crayon/issues", - "Imports": [ - "grDevices", - "methods", - "utils" - ], - "Suggests": [ - "mockery", - "rstudioapi", - "testthat", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "Collate": "'aaa-rstudio-detect.R' 'aaaa-rematch2.R' 'aab-num-ansi-colors.R' 'aac-num-ansi-colors.R' 'ansi-256.R' 'ansi-palette.R' 'combine.R' 'string.R' 'utils.R' 'crayon-package.R' 'disposable.R' 'enc-utils.R' 'has_ansi.R' 'has_color.R' 'link.R' 'styles.R' 'machinery.R' 'parts.R' 'print.R' 'style-var.R' 'show.R' 'string_operations.R'", - "NeedsCompilation": "no", - "Author": "Gábor Csárdi [aut, cre], Brodie Gaslam [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "RSPM" - }, - "crosstalk": { - "Package": "crosstalk", - "Version": "1.2.1", - "Source": "Repository", - "Type": "Package", - "Title": "Inter-Widget Interactivity for HTML Widgets", - "Authors@R": "c( person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@posit.co\"), person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"carson@posit.co\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js library\"), person(\"Kristopher Michael\", \"Kowal\", role = c(\"ctb\", \"cph\"), comment = \"es5-shim library\"), person(family = \"es5-shim contributors\", role = c(\"ctb\", \"cph\"), comment = \"es5-shim library\"), person(\"Denis\", \"Ineshin\", role = c(\"ctb\", \"cph\"), comment = \"ion.rangeSlider library\"), person(\"Sami\", \"Samhuri\", role = c(\"ctb\", \"cph\"), comment = \"Javascript strftime library\") )", - "Description": "Provides building blocks for allowing HTML widgets to communicate with each other, with Shiny or without (i.e. static .html files). Currently supports linked brushing and filtering.", - "License": "MIT + file LICENSE", - "Imports": [ - "htmltools (>= 0.3.6)", - "jsonlite", - "lazyeval", - "R6" - ], - "Suggests": [ - "shiny", - "ggplot2", - "testthat (>= 2.1.0)", - "sass", - "bslib" - ], - "URL": "https://rstudio.github.io/crosstalk/, https://github.com/rstudio/crosstalk", - "BugReports": "https://github.com/rstudio/crosstalk/issues", - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Joe Cheng [aut], Carson Sievert [aut, cre] (), Posit Software, PBC [cph, fnd], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Brian Reavis [ctb, cph] (selectize.js library), Kristopher Michael Kowal [ctb, cph] (es5-shim library), es5-shim contributors [ctb, cph] (es5-shim library), Denis Ineshin [ctb, cph] (ion.rangeSlider library), Sami Samhuri [ctb, cph] (Javascript strftime library)", - "Maintainer": "Carson Sievert ", - "Repository": "RSPM" - }, - "curl": { - "Package": "curl", - "Version": "6.2.0", - "Source": "Repository", - "Type": "Package", - "Title": "A Modern and Flexible Web Client for R", - "Authors@R": "c( person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Posit Software, PBC\", role = \"cph\"))", - "Description": "Bindings to 'libcurl' for performing fully configurable HTTP/FTP requests where responses can be processed in memory, on disk, or streaming via the callback or connection interfaces. Some knowledge of 'libcurl' is recommended; for a more-user-friendly web client see the 'httr2' package which builds on this package with http specific tools and logic.", - "License": "MIT + file LICENSE", - "SystemRequirements": "libcurl (>= 7.62): libcurl-devel (rpm) or libcurl4-openssl-dev (deb)", - "URL": "https://jeroen.r-universe.dev/curl", - "BugReports": "https://github.com/jeroen/curl/issues", - "Suggests": [ - "spelling", - "testthat (>= 1.0.0)", - "knitr", - "jsonlite", - "later", - "rmarkdown", - "httpuv (>= 1.4.4)", - "webutils" - ], - "VignetteBuilder": "knitr", - "Depends": [ - "R (>= 3.0.0)" - ], - "RoxygenNote": "7.3.2.9000", - "Encoding": "UTF-8", - "Language": "en-US", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] (), Hadley Wickham [ctb], Posit Software, PBC [cph]", - "Maintainer": "Jeroen Ooms ", - "Repository": "CRAN" - }, - "data.table": { - "Package": "data.table", - "Version": "1.16.4", - "Source": "Repository", - "Title": "Extension of `data.frame`", - "Depends": [ - "R (>= 3.3.0)" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "bit64 (>= 4.0.0)", - "bit (>= 4.0.4)", - "R.utils", - "xts", - "zoo (>= 1.8-1)", - "yaml", - "knitr", - "markdown" - ], - "Description": "Fast aggregation of large data (e.g. 100GB in RAM), fast ordered joins, fast add/modify/delete of columns by group using no copies at all, list columns, friendly and fast character-separated-value read/write. Offers a natural and flexible syntax, for faster development.", - "License": "MPL-2.0 | file LICENSE", - "URL": "https://r-datatable.com, https://Rdatatable.gitlab.io/data.table, https://github.com/Rdatatable/data.table", - "BugReports": "https://github.com/Rdatatable/data.table/issues", - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "ByteCompile": "TRUE", - "Authors@R": "c( person(\"Tyson\",\"Barrett\", role=c(\"aut\",\"cre\"), email=\"t.barrett88@gmail.com\", comment = c(ORCID=\"0000-0002-2137-1391\")), person(\"Matt\",\"Dowle\", role=\"aut\", email=\"mattjdowle@gmail.com\"), person(\"Arun\",\"Srinivasan\", role=\"aut\", email=\"asrini@pm.me\"), person(\"Jan\",\"Gorecki\", role=\"aut\"), person(\"Michael\",\"Chirico\", role=\"aut\", comment = c(ORCID=\"0000-0003-0787-087X\")), person(\"Toby\",\"Hocking\", role=\"aut\", comment = c(ORCID=\"0000-0002-3146-0865\")), person(\"Benjamin\",\"Schwendinger\",role=\"aut\", comment = c(ORCID=\"0000-0003-3315-8114\")), person(\"Pasha\",\"Stetsenko\", role=\"ctb\"), person(\"Tom\",\"Short\", role=\"ctb\"), person(\"Steve\",\"Lianoglou\", role=\"ctb\"), person(\"Eduard\",\"Antonyan\", role=\"ctb\"), person(\"Markus\",\"Bonsch\", role=\"ctb\"), person(\"Hugh\",\"Parsonage\", role=\"ctb\"), person(\"Scott\",\"Ritchie\", role=\"ctb\"), person(\"Kun\",\"Ren\", role=\"ctb\"), person(\"Xianying\",\"Tan\", role=\"ctb\"), person(\"Rick\",\"Saporta\", role=\"ctb\"), person(\"Otto\",\"Seiskari\", role=\"ctb\"), person(\"Xianghui\",\"Dong\", role=\"ctb\"), person(\"Michel\",\"Lang\", role=\"ctb\"), person(\"Watal\",\"Iwasaki\", role=\"ctb\"), person(\"Seth\",\"Wenchel\", role=\"ctb\"), person(\"Karl\",\"Broman\", role=\"ctb\"), person(\"Tobias\",\"Schmidt\", role=\"ctb\"), person(\"David\",\"Arenburg\", role=\"ctb\"), person(\"Ethan\",\"Smith\", role=\"ctb\"), person(\"Francois\",\"Cocquemas\", role=\"ctb\"), person(\"Matthieu\",\"Gomez\", role=\"ctb\"), person(\"Philippe\",\"Chataignon\", role=\"ctb\"), person(\"Nello\",\"Blaser\", role=\"ctb\"), person(\"Dmitry\",\"Selivanov\", role=\"ctb\"), person(\"Andrey\",\"Riabushenko\", role=\"ctb\"), person(\"Cheng\",\"Lee\", role=\"ctb\"), person(\"Declan\",\"Groves\", role=\"ctb\"), person(\"Daniel\",\"Possenriede\", role=\"ctb\"), person(\"Felipe\",\"Parages\", role=\"ctb\"), person(\"Denes\",\"Toth\", role=\"ctb\"), person(\"Mus\",\"Yaramaz-David\", role=\"ctb\"), person(\"Ayappan\",\"Perumal\", role=\"ctb\"), person(\"James\",\"Sams\", role=\"ctb\"), person(\"Martin\",\"Morgan\", role=\"ctb\"), person(\"Michael\",\"Quinn\", role=\"ctb\"), person(\"@javrucebo\",\"\", role=\"ctb\"), person(\"@marc-outins\",\"\", role=\"ctb\"), person(\"Roy\",\"Storey\", role=\"ctb\"), person(\"Manish\",\"Saraswat\", role=\"ctb\"), person(\"Morgan\",\"Jacob\", role=\"ctb\"), person(\"Michael\",\"Schubmehl\", role=\"ctb\"), person(\"Davis\",\"Vaughan\", role=\"ctb\"), person(\"Leonardo\",\"Silvestri\", role=\"ctb\"), person(\"Jim\",\"Hester\", role=\"ctb\"), person(\"Anthony\",\"Damico\", role=\"ctb\"), person(\"Sebastian\",\"Freundt\", role=\"ctb\"), person(\"David\",\"Simons\", role=\"ctb\"), person(\"Elliott\",\"Sales de Andrade\", role=\"ctb\"), person(\"Cole\",\"Miller\", role=\"ctb\"), person(\"Jens Peder\",\"Meldgaard\", role=\"ctb\"), person(\"Vaclav\",\"Tlapak\", role=\"ctb\"), person(\"Kevin\",\"Ushey\", role=\"ctb\"), person(\"Dirk\",\"Eddelbuettel\", role=\"ctb\"), person(\"Tony\",\"Fischetti\", role=\"ctb\"), person(\"Ofek\",\"Shilon\", role=\"ctb\"), person(\"Vadim\",\"Khotilovich\", role=\"ctb\"), person(\"Hadley\",\"Wickham\", role=\"ctb\"), person(\"Bennet\",\"Becker\", role=\"ctb\"), person(\"Kyle\",\"Haynes\", role=\"ctb\"), person(\"Boniface Christian\",\"Kamgang\", role=\"ctb\"), person(\"Olivier\",\"Delmarcell\", role=\"ctb\"), person(\"Josh\",\"O'Brien\", role=\"ctb\"), person(\"Dereck\",\"de Mezquita\", role=\"ctb\"), person(\"Michael\",\"Czekanski\", role=\"ctb\"), person(\"Dmitry\", \"Shemetov\", role=\"ctb\"), person(\"Nitish\", \"Jha\", role=\"ctb\"), person(\"Joshua\", \"Wu\", role=\"ctb\"), person(\"Iago\", \"Giné-Vázquez\", role=\"ctb\"), person(\"Anirban\", \"Chetia\", role=\"ctb\"), person(\"Doris\", \"Amoakohene\", role=\"ctb\"), person(\"Ivan\", \"Krylov\", role=\"ctb\") )", - "NeedsCompilation": "yes", - "Author": "Tyson Barrett [aut, cre] (), Matt Dowle [aut], Arun Srinivasan [aut], Jan Gorecki [aut], Michael Chirico [aut] (), Toby Hocking [aut] (), Benjamin Schwendinger [aut] (), Pasha Stetsenko [ctb], Tom Short [ctb], Steve Lianoglou [ctb], Eduard Antonyan [ctb], Markus Bonsch [ctb], Hugh Parsonage [ctb], Scott Ritchie [ctb], Kun Ren [ctb], Xianying Tan [ctb], Rick Saporta [ctb], Otto Seiskari [ctb], Xianghui Dong [ctb], Michel Lang [ctb], Watal Iwasaki [ctb], Seth Wenchel [ctb], Karl Broman [ctb], Tobias Schmidt [ctb], David Arenburg [ctb], Ethan Smith [ctb], Francois Cocquemas [ctb], Matthieu Gomez [ctb], Philippe Chataignon [ctb], Nello Blaser [ctb], Dmitry Selivanov [ctb], Andrey Riabushenko [ctb], Cheng Lee [ctb], Declan Groves [ctb], Daniel Possenriede [ctb], Felipe Parages [ctb], Denes Toth [ctb], Mus Yaramaz-David [ctb], Ayappan Perumal [ctb], James Sams [ctb], Martin Morgan [ctb], Michael Quinn [ctb], @javrucebo [ctb], @marc-outins [ctb], Roy Storey [ctb], Manish Saraswat [ctb], Morgan Jacob [ctb], Michael Schubmehl [ctb], Davis Vaughan [ctb], Leonardo Silvestri [ctb], Jim Hester [ctb], Anthony Damico [ctb], Sebastian Freundt [ctb], David Simons [ctb], Elliott Sales de Andrade [ctb], Cole Miller [ctb], Jens Peder Meldgaard [ctb], Vaclav Tlapak [ctb], Kevin Ushey [ctb], Dirk Eddelbuettel [ctb], Tony Fischetti [ctb], Ofek Shilon [ctb], Vadim Khotilovich [ctb], Hadley Wickham [ctb], Bennet Becker [ctb], Kyle Haynes [ctb], Boniface Christian Kamgang [ctb], Olivier Delmarcell [ctb], Josh O'Brien [ctb], Dereck de Mezquita [ctb], Michael Czekanski [ctb], Dmitry Shemetov [ctb], Nitish Jha [ctb], Joshua Wu [ctb], Iago Giné-Vázquez [ctb], Anirban Chetia [ctb], Doris Amoakohene [ctb], Ivan Krylov [ctb]", - "Maintainer": "Tyson Barrett ", - "Repository": "CRAN" - }, - "desc": { - "Package": "desc", - "Version": "1.4.3", - "Source": "Repository", - "Title": "Manipulate DESCRIPTION Files", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Kirill\", \"Müller\", role = \"aut\"), person(\"Jim\", \"Hester\", , \"james.f.hester@gmail.com\", role = \"aut\"), person(\"Maëlle\", \"Salmon\", role = \"ctb\", comment = c(ORCID = \"0000-0002-2815-0399\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Maintainer": "Gábor Csárdi ", - "Description": "Tools to read, write, create, and manipulate DESCRIPTION files. It is intended for packages that create or manipulate other packages.", - "License": "MIT + file LICENSE", - "URL": "https://desc.r-lib.org/, https://github.com/r-lib/desc", - "BugReports": "https://github.com/r-lib/desc/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "cli", - "R6", - "utils" - ], - "Suggests": [ - "callr", - "covr", - "gh", - "spelling", - "testthat", - "whoami", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.2.3", - "Collate": "'assertions.R' 'authors-at-r.R' 'built.R' 'classes.R' 'collate.R' 'constants.R' 'deps.R' 'desc-package.R' 'description.R' 'encoding.R' 'find-package-root.R' 'latex.R' 'non-oo-api.R' 'package-archives.R' 'read.R' 'remotes.R' 'str.R' 'syntax_checks.R' 'urls.R' 'utils.R' 'validate.R' 'version.R'", - "NeedsCompilation": "no", - "Author": "Gábor Csárdi [aut, cre], Kirill Müller [aut], Jim Hester [aut], Maëlle Salmon [ctb] (), Posit Software, PBC [cph, fnd]", - "Repository": "RSPM" - }, - "digest": { - "Package": "digest", - "Version": "0.6.37", - "Source": "Repository", - "Authors@R": "c(person(\"Dirk\", \"Eddelbuettel\", role = c(\"aut\", \"cre\"), email = \"edd@debian.org\", comment = c(ORCID = \"0000-0001-6419-907X\")), person(\"Antoine\", \"Lucas\", role=\"ctb\"), person(\"Jarek\", \"Tuszynski\", role=\"ctb\"), person(\"Henrik\", \"Bengtsson\", role=\"ctb\", comment = c(ORCID = \"0000-0002-7579-5165\")), person(\"Simon\", \"Urbanek\", role=\"ctb\", comment = c(ORCID = \"0000-0003-2297-1732\")), person(\"Mario\", \"Frasca\", role=\"ctb\"), person(\"Bryan\", \"Lewis\", role=\"ctb\"), person(\"Murray\", \"Stokely\", role=\"ctb\"), person(\"Hannes\", \"Muehleisen\", role=\"ctb\"), person(\"Duncan\", \"Murdoch\", role=\"ctb\"), person(\"Jim\", \"Hester\", role=\"ctb\"), person(\"Wush\", \"Wu\", role=\"ctb\", comment = c(ORCID = \"0000-0001-5180-0567\")), person(\"Qiang\", \"Kou\", role=\"ctb\", comment = c(ORCID = \"0000-0001-6786-5453\")), person(\"Thierry\", \"Onkelinx\", role=\"ctb\", comment = c(ORCID = \"0000-0001-8804-4216\")), person(\"Michel\", \"Lang\", role=\"ctb\", comment = c(ORCID = \"0000-0001-9754-0393\")), person(\"Viliam\", \"Simko\", role=\"ctb\"), person(\"Kurt\", \"Hornik\", role=\"ctb\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(\"Radford\", \"Neal\", role=\"ctb\", comment = c(ORCID = \"0000-0002-2473-3407\")), person(\"Kendon\", \"Bell\", role=\"ctb\", comment = c(ORCID = \"0000-0002-9093-8312\")), person(\"Matthew\", \"de Queljoe\", role=\"ctb\"), person(\"Dmitry\", \"Selivanov\", role=\"ctb\"), person(\"Ion\", \"Suruceanu\", role=\"ctb\"), person(\"Bill\", \"Denney\", role=\"ctb\"), person(\"Dirk\", \"Schumacher\", role=\"ctb\"), person(\"András\", \"Svraka\", role=\"ctb\"), person(\"Sergey\", \"Fedorov\", role=\"ctb\"), person(\"Will\", \"Landau\", role=\"ctb\", comment = c(ORCID = \"0000-0003-1878-3253\")), person(\"Floris\", \"Vanderhaeghe\", role=\"ctb\", comment = c(ORCID = \"0000-0002-6378-6229\")), person(\"Kevin\", \"Tappe\", role=\"ctb\"), person(\"Harris\", \"McGehee\", role=\"ctb\"), person(\"Tim\", \"Mastny\", role=\"ctb\"), person(\"Aaron\", \"Peikert\", role=\"ctb\", comment = c(ORCID = \"0000-0001-7813-818X\")), person(\"Mark\", \"van der Loo\", role=\"ctb\", comment = c(ORCID = \"0000-0002-9807-4686\")), person(\"Chris\", \"Muir\", role=\"ctb\", comment = c(ORCID = \"0000-0003-2555-3878\")), person(\"Moritz\", \"Beller\", role=\"ctb\", comment = c(ORCID = \"0000-0003-4852-0526\")), person(\"Sebastian\", \"Campbell\", role=\"ctb\"), person(\"Winston\", \"Chang\", role=\"ctb\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Dean\", \"Attali\", role=\"ctb\", comment = c(ORCID = \"0000-0002-5645-3493\")), person(\"Michael\", \"Chirico\", role=\"ctb\", comment = c(ORCID = \"0000-0003-0787-087X\")), person(\"Kevin\", \"Ushey\", role=\"ctb\"))", - "Date": "2024-08-19", - "Title": "Create Compact Hash Digests of R Objects", - "Description": "Implementation of a function 'digest()' for the creation of hash digests of arbitrary R objects (using the 'md5', 'sha-1', 'sha-256', 'crc32', 'xxhash', 'murmurhash', 'spookyhash', 'blake3', 'crc32c', 'xxh3_64', and 'xxh3_128' algorithms) permitting easy comparison of R language objects, as well as functions such as'hmac()' to create hash-based message authentication code. Please note that this package is not meant to be deployed for cryptographic purposes for which more comprehensive (and widely tested) libraries such as 'OpenSSL' should be used.", - "URL": "https://github.com/eddelbuettel/digest, https://dirk.eddelbuettel.com/code/digest.html", - "BugReports": "https://github.com/eddelbuettel/digest/issues", - "Depends": [ - "R (>= 3.3.0)" - ], - "Imports": [ - "utils" - ], - "License": "GPL (>= 2)", - "Suggests": [ - "tinytest", - "simplermarkdown" - ], - "VignetteBuilder": "simplermarkdown", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Dirk Eddelbuettel [aut, cre] (), Antoine Lucas [ctb], Jarek Tuszynski [ctb], Henrik Bengtsson [ctb] (), Simon Urbanek [ctb] (), Mario Frasca [ctb], Bryan Lewis [ctb], Murray Stokely [ctb], Hannes Muehleisen [ctb], Duncan Murdoch [ctb], Jim Hester [ctb], Wush Wu [ctb] (), Qiang Kou [ctb] (), Thierry Onkelinx [ctb] (), Michel Lang [ctb] (), Viliam Simko [ctb], Kurt Hornik [ctb] (), Radford Neal [ctb] (), Kendon Bell [ctb] (), Matthew de Queljoe [ctb], Dmitry Selivanov [ctb], Ion Suruceanu [ctb], Bill Denney [ctb], Dirk Schumacher [ctb], András Svraka [ctb], Sergey Fedorov [ctb], Will Landau [ctb] (), Floris Vanderhaeghe [ctb] (), Kevin Tappe [ctb], Harris McGehee [ctb], Tim Mastny [ctb], Aaron Peikert [ctb] (), Mark van der Loo [ctb] (), Chris Muir [ctb] (), Moritz Beller [ctb] (), Sebastian Campbell [ctb], Winston Chang [ctb] (), Dean Attali [ctb] (), Michael Chirico [ctb] (), Kevin Ushey [ctb]", - "Maintainer": "Dirk Eddelbuettel ", - "Repository": "CRAN" - }, - "dplyr": { - "Package": "dplyr", - "Version": "1.1.4", - "Source": "Repository", - "Type": "Package", - "Title": "A Grammar of Data Manipulation", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Romain\", \"François\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Lionel\", \"Henry\", role = \"aut\"), person(\"Kirill\", \"Müller\", role = \"aut\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4777-038X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A fast, consistent tool for working with data frame like objects, both in memory and out of memory.", - "License": "MIT + file LICENSE", - "URL": "https://dplyr.tidyverse.org, https://github.com/tidyverse/dplyr", - "BugReports": "https://github.com/tidyverse/dplyr/issues", - "Depends": [ - "R (>= 3.5.0)" - ], - "Imports": [ - "cli (>= 3.4.0)", - "generics", - "glue (>= 1.3.2)", - "lifecycle (>= 1.0.3)", - "magrittr (>= 1.5)", - "methods", - "pillar (>= 1.9.0)", - "R6", - "rlang (>= 1.1.0)", - "tibble (>= 3.2.0)", - "tidyselect (>= 1.2.0)", - "utils", - "vctrs (>= 0.6.4)" - ], - "Suggests": [ - "bench", - "broom", - "callr", - "covr", - "DBI", - "dbplyr (>= 2.2.1)", - "ggplot2", - "knitr", - "Lahman", - "lobstr", - "microbenchmark", - "nycflights13", - "purrr", - "rmarkdown", - "RMySQL", - "RPostgreSQL", - "RSQLite", - "stringi (>= 1.7.6)", - "testthat (>= 3.1.5)", - "tidyr (>= 1.3.0)", - "withr" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse, shiny, pkgdown, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre] (), Romain François [aut] (), Lionel Henry [aut], Kirill Müller [aut] (), Davis Vaughan [aut] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "e1071": { - "Package": "e1071", - "Version": "1.7-16", - "Source": "Repository", - "Title": "Misc Functions of the Department of Statistics, Probability Theory Group (Formerly: E1071), TU Wien", - "Imports": [ - "graphics", - "grDevices", - "class", - "stats", - "methods", - "utils", - "proxy" - ], - "Suggests": [ - "cluster", - "mlbench", - "nnet", - "randomForest", - "rpart", - "SparseM", - "xtable", - "Matrix", - "MASS", - "slam" - ], - "Authors@R": "c(person(given = \"David\", family = \"Meyer\", role = c(\"aut\", \"cre\"), email = \"David.Meyer@R-project.org\", comment = c(ORCID = \"0000-0002-5196-3048\")), person(given = \"Evgenia\", family = \"Dimitriadou\", role = c(\"aut\",\"cph\")), person(given = \"Kurt\", family = \"Hornik\", role = \"aut\", email = \"Kurt.Hornik@R-project.org\", comment = c(ORCID = \"0000-0003-4198-9911\")), person(given = \"Andreas\", family = \"Weingessel\", role = \"aut\"), person(given = \"Friedrich\", family = \"Leisch\", role = \"aut\"), person(given = \"Chih-Chung\", family = \"Chang\", role = c(\"ctb\",\"cph\"), comment = \"libsvm C++-code\"), person(given = \"Chih-Chen\", family = \"Lin\", role = c(\"ctb\",\"cph\"), comment = \"libsvm C++-code\"))", - "Description": "Functions for latent class analysis, short time Fourier transform, fuzzy clustering, support vector machines, shortest path computation, bagged clustering, naive Bayes classifier, generalized k-nearest neighbour ...", - "License": "GPL-2 | GPL-3", - "LazyLoad": "yes", - "NeedsCompilation": "yes", - "Author": "David Meyer [aut, cre] (), Evgenia Dimitriadou [aut, cph], Kurt Hornik [aut] (), Andreas Weingessel [aut], Friedrich Leisch [aut], Chih-Chung Chang [ctb, cph] (libsvm C++-code), Chih-Chen Lin [ctb, cph] (libsvm C++-code)", - "Maintainer": "David Meyer ", - "Repository": "CRAN" - }, - "evaluate": { - "Package": "evaluate", - "Version": "1.0.3", - "Source": "Repository", - "Type": "Package", - "Title": "Parsing and Evaluation Tools that Provide More Details than the Default", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Yihui\", \"Xie\", role = \"aut\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Michael\", \"Lawrence\", role = \"ctb\"), person(\"Thomas\", \"Kluyver\", role = \"ctb\"), person(\"Jeroen\", \"Ooms\", role = \"ctb\"), person(\"Barret\", \"Schloerke\", role = \"ctb\"), person(\"Adam\", \"Ryczkowski\", role = \"ctb\"), person(\"Hiroaki\", \"Yutani\", role = \"ctb\"), person(\"Michel\", \"Lang\", role = \"ctb\"), person(\"Karolis\", \"Koncevičius\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Parsing and evaluation tools that make it easy to recreate the command line behaviour of R.", - "License": "MIT + file LICENSE", - "URL": "https://evaluate.r-lib.org/, https://github.com/r-lib/evaluate", - "BugReports": "https://github.com/r-lib/evaluate/issues", - "Depends": [ - "R (>= 3.6.0)" - ], - "Suggests": [ - "callr", - "covr", - "ggplot2 (>= 3.3.6)", - "lattice", - "methods", - "pkgload", - "rlang", - "knitr", - "testthat (>= 3.0.0)", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre], Yihui Xie [aut] (), Michael Lawrence [ctb], Thomas Kluyver [ctb], Jeroen Ooms [ctb], Barret Schloerke [ctb], Adam Ryczkowski [ctb], Hiroaki Yutani [ctb], Michel Lang [ctb], Karolis Koncevičius [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "CRAN" - }, - "expm": { - "Package": "expm", - "Version": "1.0-0", - "Source": "Repository", - "Type": "Package", - "Title": "Matrix Exponential, Log, 'etc'", - "Date": "2024-08-19", - "Authors@R": "c(person(\"Martin\", \"Maechler\", role=c(\"aut\",\"cre\"), email=\"maechler@stat.math.ethz.ch\", comment = c(ORCID = \"0000-0002-8685-9910\")) , person(\"Christophe\",\"Dutang\", role = \"aut\", comment = c(ORCID = \"0000-0001-6732-1501\")) , person(\"Vincent\", \"Goulet\", role = \"aut\", comment = c(ORCID = \"0000-0002-9315-5719\")) , person(\"Douglas\", \"Bates\", role = \"ctb\", comment = \"cosmetic clean up, in svn r42\") , person(\"David\", \"Firth\", role = \"ctb\", comment = \"expm(method= \\\"PadeO\\\" and \\\"TaylorO\\\")\") , person(\"Marina\", \"Shapira\", role = \"ctb\", comment = \"expm(method= \\\"PadeO\\\" and \\\"TaylorO\\\")\") , person(\"Michael\", \"Stadelmann\", role = \"ctb\", comment = \"\\\"Higham08*\\\" methods, see ?expm.Higham08...\") )", - "Contact": "expm-developers@lists.R-forge.R-project.org", - "Description": "Computation of the matrix exponential, logarithm, sqrt, and related quantities, using traditional and modern methods.", - "Depends": [ - "Matrix" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "RColorBrewer", - "sfsmisc", - "Rmpfr" - ], - "BuildResaveData": "no", - "License": "GPL (>= 2)", - "URL": "https://R-Forge.R-project.org/projects/expm/", - "BugReports": "https://R-forge.R-project.org/tracker/?atid=472&group_id=107", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Martin Maechler [aut, cre] (), Christophe Dutang [aut] (), Vincent Goulet [aut] (), Douglas Bates [ctb] (cosmetic clean up, in svn r42), David Firth [ctb] (expm(method= \"PadeO\" and \"TaylorO\")), Marina Shapira [ctb] (expm(method= \"PadeO\" and \"TaylorO\")), Michael Stadelmann [ctb] (\"Higham08*\" methods, see ?expm.Higham08...)", - "Maintainer": "Martin Maechler ", - "Repository": "CRAN" - }, - "fansi": { - "Package": "fansi", - "Version": "1.0.6", - "Source": "Repository", - "Title": "ANSI Control Sequence Aware String Functions", - "Description": "Counterparts to R string manipulation functions that account for the effects of ANSI text formatting control sequences.", - "Authors@R": "c( person(\"Brodie\", \"Gaslam\", email=\"brodie.gaslam@yahoo.com\", role=c(\"aut\", \"cre\")), person(\"Elliott\", \"Sales De Andrade\", role=\"ctb\"), person(family=\"R Core Team\", email=\"R-core@r-project.org\", role=\"cph\", comment=\"UTF8 byte length calcs from src/util.c\" ))", - "Depends": [ - "R (>= 3.1.0)" - ], - "License": "GPL-2 | GPL-3", - "URL": "https://github.com/brodieG/fansi", - "BugReports": "https://github.com/brodieG/fansi/issues", - "VignetteBuilder": "knitr", - "Suggests": [ - "unitizer", - "knitr", - "rmarkdown" - ], - "Imports": [ - "grDevices", - "utils" - ], - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "Collate": "'constants.R' 'fansi-package.R' 'internal.R' 'load.R' 'misc.R' 'nchar.R' 'strwrap.R' 'strtrim.R' 'strsplit.R' 'substr2.R' 'trimws.R' 'tohtml.R' 'unhandled.R' 'normalize.R' 'sgr.R'", - "NeedsCompilation": "yes", - "Author": "Brodie Gaslam [aut, cre], Elliott Sales De Andrade [ctb], R Core Team [cph] (UTF8 byte length calcs from src/util.c)", - "Maintainer": "Brodie Gaslam ", - "Repository": "RSPM" - }, - "farver": { - "Package": "farver", - "Version": "2.1.2", - "Source": "Repository", - "Type": "Package", - "Title": "High Performance Colour Space Manipulation", - "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Berendea\", \"Nicolae\", role = \"aut\", comment = \"Author of the ColorSpace C++ library\"), person(\"Romain\", \"François\", , \"romain@purrple.cat\", role = \"aut\", comment = c(ORCID = \"0000-0002-2444-4226\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "The encoding of colour can be handled in many different ways, using different colour spaces. As different colour spaces have different uses, efficient conversion between these representations are important. The 'farver' package provides a set of functions that gives access to very fast colour space conversion and comparisons implemented in C++, and offers speed improvements over the 'convertColor' function in the 'grDevices' package.", - "License": "MIT + file LICENSE", - "URL": "https://farver.data-imaginist.com, https://github.com/thomasp85/farver", - "BugReports": "https://github.com/thomasp85/farver/issues", - "Suggests": [ - "covr", - "testthat (>= 3.0.0)" - ], - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "NeedsCompilation": "yes", - "Author": "Thomas Lin Pedersen [cre, aut] (), Berendea Nicolae [aut] (Author of the ColorSpace C++ library), Romain François [aut] (), Posit, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "RSPM" - }, - "fastmap": { - "Package": "fastmap", - "Version": "1.2.0", - "Source": "Repository", - "Title": "Fast Data Structures", - "Authors@R": "c( person(\"Winston\", \"Chang\", email = \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(given = \"Tessil\", role = \"cph\", comment = \"hopscotch_map library\") )", - "Description": "Fast implementation of data structures, including a key-value store, stack, and queue. Environments are commonly used as key-value stores in R, but every time a new key is used, it is added to R's global symbol table, causing a small amount of memory leakage. This can be problematic in cases where many different keys are used. Fastmap avoids this memory leak issue by implementing the map using data structures in C++.", - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "Suggests": [ - "testthat (>= 2.1.1)" - ], - "URL": "https://r-lib.github.io/fastmap/, https://github.com/r-lib/fastmap", - "BugReports": "https://github.com/r-lib/fastmap/issues", - "NeedsCompilation": "yes", - "Author": "Winston Chang [aut, cre], Posit Software, PBC [cph, fnd], Tessil [cph] (hopscotch_map library)", - "Maintainer": "Winston Chang ", - "Repository": "RSPM" - }, - "flextable": { - "Package": "flextable", - "Version": "0.9.7", - "Source": "Repository", - "Type": "Package", - "Title": "Functions for Tabular Reporting", - "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"ArData\", role = \"cph\"), person(\"Clementine\", \"Jager\", role = \"ctb\"), person(\"Eli\", \"Daniels\", role = \"ctb\"), person(\"Panagiotis\", \"Skintzos\", , \"panagiotis.skintzos@ardata.fr\", role = \"aut\"), person(\"Quentin\", \"Fazilleau\", role = \"ctb\"), person(\"Maxim\", \"Nazarov\", role = \"ctb\"), person(\"Titouan\", \"Robert\", role = \"ctb\"), person(\"Michael\", \"Barrowman\", role = \"ctb\"), person(\"Atsushi\", \"Yasumoto\", role = \"ctb\"), person(\"Paul\", \"Julian\", role = \"ctb\"), person(\"Sean\", \"Browning\", role = \"ctb\"), person(\"Rémi\", \"Thériault\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4315-6788\")), person(\"Samuel\", \"Jobert\", role = \"ctb\"), person(\"Keith\", \"Newman\", role = \"ctb\") )", - "Description": "Use a grammar for creating and customizing pretty tables. The following formats are supported: 'HTML', 'PDF', 'RTF', 'Microsoft Word', 'Microsoft PowerPoint' and R 'Grid Graphics'. 'R Markdown', 'Quarto' and the package 'officer' can be used to produce the result files. The syntax is the same for the user regardless of the type of output to be produced. A set of functions allows the creation, definition of cell arrangement, addition of headers or footers, formatting and definition of cell content with text and or images. The package also offers a set of high-level functions that allow tabular reporting of statistical models and the creation of complex cross tabulations.", - "License": "GPL-3", - "URL": "https://ardata-fr.github.io/flextable-book/, https://davidgohel.github.io/flextable/", - "BugReports": "https://github.com/davidgohel/flextable/issues", - "Imports": [ - "data.table (>= 1.13.0)", - "gdtools (>= 0.4.0)", - "graphics", - "grDevices", - "grid", - "htmltools", - "knitr", - "officer (>= 0.6.7)", - "ragg", - "rlang", - "rmarkdown (>= 2.0)", - "stats", - "utils", - "uuid (>= 0.1-4)", - "xml2" - ], - "Suggests": [ - "bookdown (>= 0.40)", - "broom", - "broom.mixed", - "chromote", - "cluster", - "commonmark", - "doconv (>= 0.3.0)", - "equatags", - "ggplot2", - "lme4", - "magick", - "mgcv", - "nlme", - "officedown", - "pdftools", - "pkgdown (>= 2.0.0)", - "scales", - "svglite", - "tables (>= 0.9.17)", - "testthat (>= 3.0.0)", - "webshot2", - "withr", - "xtable" - ], - "VignetteBuilder": "knitr", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "David Gohel [aut, cre], ArData [cph], Clementine Jager [ctb], Eli Daniels [ctb], Panagiotis Skintzos [aut], Quentin Fazilleau [ctb], Maxim Nazarov [ctb], Titouan Robert [ctb], Michael Barrowman [ctb], Atsushi Yasumoto [ctb], Paul Julian [ctb], Sean Browning [ctb], Rémi Thériault [ctb] (), Samuel Jobert [ctb], Keith Newman [ctb]", - "Maintainer": "David Gohel ", - "Repository": "CRAN" - }, - "fontBitstreamVera": { - "Package": "fontBitstreamVera", - "Version": "0.1.1", - "Source": "Repository", - "Title": "Fonts with 'Bitstream Vera Fonts' License", - "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel.hry@gmail.com\", c(\"cre\", \"aut\")), person(\"Bitstream\", role = \"cph\"))", - "Description": "Provides fonts licensed under the 'Bitstream Vera Fonts' license for the 'fontquiver' package.", - "Depends": [ - "R (>= 3.0.0)" - ], - "License": "file LICENCE", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "5.0.1", - "NeedsCompilation": "no", - "Author": "Lionel Henry [cre, aut], Bitstream [cph]", - "Maintainer": "Lionel Henry ", - "License_is_FOSS": "yes", - "Repository": "CRAN" - }, - "fontLiberation": { - "Package": "fontLiberation", - "Version": "0.1.0", - "Source": "Repository", - "Title": "Liberation Fonts", - "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", \"cre\"), person(\"Pravin Satpute\", role = \"aut\"), person(\"Steve Matteson\", role = \"aut\"), person(\"Red Hat, Inc\", role = \"cph\"), person(\"Google Corporation\", role = \"cph\"))", - "Description": "A placeholder for the Liberation fontset intended for the `fontquiver` package. This fontset covers the 12 combinations of families (sans, serif, mono) and faces (plain, bold, italic, bold italic) supported in R graphics devices.", - "Depends": [ - "R (>= 3.0)" - ], - "License": "file LICENSE", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "5.0.1", - "NeedsCompilation": "no", - "Author": "Lionel Henry [cre], Pravin Satpute [aut], Steve Matteson [aut], Red Hat, Inc [cph], Google Corporation [cph]", - "Maintainer": "Lionel Henry ", - "Repository": "CRAN", - "License_is_FOSS": "yes" - }, - "fontawesome": { - "Package": "fontawesome", - "Version": "0.5.3", - "Source": "Repository", - "Type": "Package", - "Title": "Easily Work with 'Font Awesome' Icons", - "Description": "Easily and flexibly insert 'Font Awesome' icons into 'R Markdown' documents and 'Shiny' apps. These icons can be inserted into HTML content through inline 'SVG' tags or 'i' tags. There is also a utility function for exporting 'Font Awesome' icons as 'PNG' images for those situations where raster graphics are needed.", - "Authors@R": "c( person(\"Richard\", \"Iannone\", , \"rich@posit.co\", c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Christophe\", \"Dervieux\", , \"cderv@posit.co\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"ctb\"), person(\"Dave\", \"Gandy\", role = c(\"ctb\", \"cph\"), comment = \"Font-Awesome font\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "License": "MIT + file LICENSE", - "URL": "https://github.com/rstudio/fontawesome, https://rstudio.github.io/fontawesome/", - "BugReports": "https://github.com/rstudio/fontawesome/issues", - "Encoding": "UTF-8", - "ByteCompile": "true", - "RoxygenNote": "7.3.2", - "Depends": [ - "R (>= 3.3.0)" - ], - "Imports": [ - "rlang (>= 1.0.6)", - "htmltools (>= 0.5.1.1)" - ], - "Suggests": [ - "covr", - "dplyr (>= 1.0.8)", - "gt (>= 0.9.0)", - "knitr (>= 1.31)", - "testthat (>= 3.0.0)", - "rsvg" - ], - "Config/testthat/edition": "3", - "NeedsCompilation": "no", - "Author": "Richard Iannone [aut, cre] (), Christophe Dervieux [ctb] (), Winston Chang [ctb], Dave Gandy [ctb, cph] (Font-Awesome font), Posit Software, PBC [cph, fnd]", - "Maintainer": "Richard Iannone ", - "Repository": "CRAN" - }, - "fontquiver": { - "Package": "fontquiver", - "Version": "0.2.1", - "Source": "Repository", - "Title": "Set of Installed Fonts", - "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", c(\"cre\", \"aut\")), person(\"RStudio\", role = \"cph\"), person(\"George Douros\", role = \"cph\", comment = \"Symbola font\"))", - "Description": "Provides a set of fonts with permissive licences. This is useful when you want to avoid system fonts to make sure your outputs are reproducible.", - "Depends": [ - "R (>= 3.0.0)" - ], - "Imports": [ - "fontBitstreamVera (>= 0.1.0)", - "fontLiberation (>= 0.1.0)" - ], - "Suggests": [ - "testthat", - "htmltools" - ], - "License": "GPL-3 | file LICENSE", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "5.0.1", - "Collate": "'font-getters.R' 'fontset.R' 'fontset-bitstream-vera.R' 'fontset-dejavu.R' 'fontset-liberation.R' 'fontset-symbola.R' 'html-dependency.R' 'utils.R'", - "NeedsCompilation": "no", - "Author": "Lionel Henry [cre, aut], RStudio [cph], George Douros [cph] (Symbola font)", - "Maintainer": "Lionel Henry ", - "Repository": "CRAN" - }, - "forcats": { - "Package": "forcats", - "Version": "1.0.0", - "Source": "Repository", - "Title": "Tools for Working with Categorical Variables (Factors)", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = c(\"aut\", \"cre\")), person(\"RStudio\", role = c(\"cph\", \"fnd\")) )", - "Description": "Helpers for reordering factor levels (including moving specified levels to front, ordering by first appearance, reversing, and randomly shuffling), and tools for modifying factor levels (including collapsing rare levels into other, 'anonymising', and manually 'recoding').", - "License": "MIT + file LICENSE", - "URL": "https://forcats.tidyverse.org/, https://github.com/tidyverse/forcats", - "BugReports": "https://github.com/tidyverse/forcats/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "cli (>= 3.4.0)", - "glue", - "lifecycle", - "magrittr", - "rlang (>= 1.0.0)", - "tibble" - ], - "Suggests": [ - "covr", - "dplyr", - "ggplot2", - "knitr", - "readr", - "rmarkdown", - "testthat (>= 3.0.0)", - "withr" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre], RStudio [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "formatters": { - "Package": "formatters", - "Version": "0.5.10.9001", - "Source": "Repository", - "Title": "ASCII Formatting for Values and Tables", - "Date": "2025-02-05", - "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "We provide a framework for rendering complex tables to ASCII, and a set of formatters for transforming values or sets of values into ASCII-ready display strings.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/formatters/, https://github.com/insightsengineering/formatters/", - "BugReports": "https://github.com/insightsengineering/formatters/issues", - "Depends": [ - "methods", - "R (>= 2.10)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "grid", - "htmltools (>= 0.5.3)", - "lifecycle (>= 0.2.0)", - "stringi (>= 1.7.12)" - ], - "Suggests": [ - "dplyr (>= 1.0.9)", - "gt (>= 0.10.0)", - "huxtable (>= 2.0.0)", - "knitr (>= 1.42)", - "r2rtf (>= 0.3.2)", - "rmarkdown (>= 2.23)", - "testthat (>= 3.0.4)", - "withr (>= 2.0.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/Needs/verdepcheck": "mllg/checkmate, rstudio/htmltools, r-lib/lifecycle, tidyverse/dplyr, rstudio/gt, hughjonesd/huxtable, yihui/knitr, Merck/r2rtf, rstudio/rmarkdown, gagolews/stringi, r-lib/testthat, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "LazyData": "true", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Collate": "'data.R' 'format_value.R' 'matrix_form.R' 'generics.R' 'labels.R' 'mpf_exporters.R' 'package.R' 'page_size.R' 'pagination.R' 'tostring.R' 'utils.R' 'zzz.R'", - "Config/pak/sysreqs": "libicu-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/formatters", - "RemoteRef": "HEAD", - "RemoteSha": "ee566c9b53f010edae9d0d9a64af82b41cee7b66", - "NeedsCompilation": "no", - "Author": "Gabriel Becker [aut] (original creator of the package), Adrian Waddell [aut], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Joe Zhu " - }, - "fs": { - "Package": "fs", - "Version": "1.6.5", - "Source": "Repository", - "Title": "Cross-Platform File System Operations Based on 'libuv'", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A cross-platform interface to file system operations, built on top of the 'libuv' C library.", - "License": "MIT + file LICENSE", - "URL": "https://fs.r-lib.org, https://github.com/r-lib/fs", - "BugReports": "https://github.com/r-lib/fs/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "covr", - "crayon", - "knitr", - "pillar (>= 1.0.0)", - "rmarkdown", - "spelling", - "testthat (>= 3.0.0)", - "tibble (>= 1.1.0)", - "vctrs (>= 0.3.0)", - "withr" - ], - "VignetteBuilder": "knitr", - "ByteCompile": "true", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Copyright": "file COPYRIGHTS", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.2.3", - "SystemRequirements": "GNU make", - "NeedsCompilation": "yes", - "Author": "Jim Hester [aut], Hadley Wickham [aut], Gábor Csárdi [aut, cre], libuv project contributors [cph] (libuv library), Joyent, Inc. and other Node contributors [cph] (libuv library), Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - }, - "gdtools": { - "Package": "gdtools", - "Version": "0.4.1", - "Source": "Repository", - "Title": "Utilities for Graphical Rendering and Fonts Management", - "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", , \"jeroen@berkeley.edu\", role = \"aut\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Yixuan\", \"Qiu\", role = \"ctb\"), person(\"R Core Team\", role = \"cph\", comment = \"Cairo code from X11 device\"), person(\"ArData\", role = \"cph\"), person(\"RStudio\", role = \"cph\") )", - "Description": "Tools are provided to compute metrics of formatted strings and to check the availability of a font. Another set of functions is provided to support the collection of fonts from 'Google Fonts' in a cache. Their use is simple within 'R Markdown' documents and 'shiny' applications but also with graphic productions generated with the 'ggiraph', 'ragg' and 'svglite' packages or with tabular productions from the 'flextable' package.", - "License": "GPL-3 | file LICENSE", - "URL": "https://davidgohel.github.io/gdtools/", - "BugReports": "https://github.com/davidgohel/gdtools/issues", - "Depends": [ - "R (>= 4.0.0)" - ], - "Imports": [ - "fontquiver (>= 0.2.0)", - "htmltools", - "Rcpp (>= 0.12.12)", - "systemfonts (>= 1.1.0)", - "tools" - ], - "Suggests": [ - "curl", - "gfonts", - "methods", - "testthat" - ], - "LinkingTo": [ - "Rcpp" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "SystemRequirements": "cairo, freetype2, fontconfig", - "NeedsCompilation": "yes", - "Author": "David Gohel [aut, cre], Hadley Wickham [aut], Lionel Henry [aut], Jeroen Ooms [aut] (), Yixuan Qiu [ctb], R Core Team [cph] (Cairo code from X11 device), ArData [cph], RStudio [cph]", - "Maintainer": "David Gohel ", - "Repository": "CRAN" - }, - "generics": { - "Package": "generics", - "Version": "0.1.3", - "Source": "Repository", - "Title": "Common S3 Generics not Provided by Base R Methods Related to Model Fitting", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = c(\"aut\", \"cre\")), person(\"Max\", \"Kuhn\", , \"max@rstudio.com\", role = \"aut\"), person(\"Davis\", \"Vaughan\", , \"davis@rstudio.com\", role = \"aut\"), person(\"RStudio\", role = \"cph\") )", - "Description": "In order to reduce potential package dependencies and conflicts, generics provides a number of commonly used S3 generics.", - "License": "MIT + file LICENSE", - "URL": "https://generics.r-lib.org, https://github.com/r-lib/generics", - "BugReports": "https://github.com/r-lib/generics/issues", - "Depends": [ - "R (>= 3.2)" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "covr", - "pkgload", - "testthat (>= 3.0.0)", - "tibble", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.0", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre], Max Kuhn [aut], Davis Vaughan [aut], RStudio [cph]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "ggplot2": { - "Package": "ggplot2", - "Version": "3.5.1", - "Source": "Repository", - "Title": "Create Elegant Data Visualisations Using the Grammar of Graphics", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Winston\", \"Chang\", role = \"aut\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Lionel\", \"Henry\", role = \"aut\"), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Kohske\", \"Takahashi\", role = \"aut\"), person(\"Claus\", \"Wilke\", role = \"aut\", comment = c(ORCID = \"0000-0002-7470-9261\")), person(\"Kara\", \"Woo\", role = \"aut\", comment = c(ORCID = \"0000-0002-5125-4188\")), person(\"Hiroaki\", \"Yutani\", role = \"aut\", comment = c(ORCID = \"0000-0002-3385-7233\")), person(\"Dewey\", \"Dunnington\", role = \"aut\", comment = c(ORCID = \"0000-0002-9415-4582\")), person(\"Teun\", \"van den Brand\", role = \"aut\", comment = c(ORCID = \"0000-0002-9335-7468\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A system for 'declaratively' creating graphics, based on \"The Grammar of Graphics\". You provide the data, tell 'ggplot2' how to map variables to aesthetics, what graphical primitives to use, and it takes care of the details.", - "License": "MIT + file LICENSE", - "URL": "https://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2", - "BugReports": "https://github.com/tidyverse/ggplot2/issues", - "Depends": [ - "R (>= 3.5)" - ], - "Imports": [ - "cli", - "glue", - "grDevices", - "grid", - "gtable (>= 0.1.1)", - "isoband", - "lifecycle (> 1.0.1)", - "MASS", - "mgcv", - "rlang (>= 1.1.0)", - "scales (>= 1.3.0)", - "stats", - "tibble", - "vctrs (>= 0.6.0)", - "withr (>= 2.5.0)" - ], - "Suggests": [ - "covr", - "dplyr", - "ggplot2movies", - "hexbin", - "Hmisc", - "knitr", - "mapproj", - "maps", - "multcomp", - "munsell", - "nlme", - "profvis", - "quantreg", - "ragg (>= 1.2.6)", - "RColorBrewer", - "rmarkdown", - "rpart", - "sf (>= 0.7-3)", - "svglite (>= 2.1.2)", - "testthat (>= 3.1.2)", - "vdiffr (>= 1.0.6)", - "xml2" - ], - "Enhances": [ - "sp" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "ggtext, tidyr, forcats, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.3.1", - "Collate": "'ggproto.R' 'ggplot-global.R' 'aaa-.R' 'aes-colour-fill-alpha.R' 'aes-evaluation.R' 'aes-group-order.R' 'aes-linetype-size-shape.R' 'aes-position.R' 'compat-plyr.R' 'utilities.R' 'aes.R' 'utilities-checks.R' 'legend-draw.R' 'geom-.R' 'annotation-custom.R' 'annotation-logticks.R' 'geom-polygon.R' 'geom-map.R' 'annotation-map.R' 'geom-raster.R' 'annotation-raster.R' 'annotation.R' 'autolayer.R' 'autoplot.R' 'axis-secondary.R' 'backports.R' 'bench.R' 'bin.R' 'coord-.R' 'coord-cartesian-.R' 'coord-fixed.R' 'coord-flip.R' 'coord-map.R' 'coord-munch.R' 'coord-polar.R' 'coord-quickmap.R' 'coord-radial.R' 'coord-sf.R' 'coord-transform.R' 'data.R' 'docs_layer.R' 'facet-.R' 'facet-grid-.R' 'facet-null.R' 'facet-wrap.R' 'fortify-lm.R' 'fortify-map.R' 'fortify-multcomp.R' 'fortify-spatial.R' 'fortify.R' 'stat-.R' 'geom-abline.R' 'geom-rect.R' 'geom-bar.R' 'geom-bin2d.R' 'geom-blank.R' 'geom-boxplot.R' 'geom-col.R' 'geom-path.R' 'geom-contour.R' 'geom-count.R' 'geom-crossbar.R' 'geom-segment.R' 'geom-curve.R' 'geom-defaults.R' 'geom-ribbon.R' 'geom-density.R' 'geom-density2d.R' 'geom-dotplot.R' 'geom-errorbar.R' 'geom-errorbarh.R' 'geom-freqpoly.R' 'geom-function.R' 'geom-hex.R' 'geom-histogram.R' 'geom-hline.R' 'geom-jitter.R' 'geom-label.R' 'geom-linerange.R' 'geom-point.R' 'geom-pointrange.R' 'geom-quantile.R' 'geom-rug.R' 'geom-sf.R' 'geom-smooth.R' 'geom-spoke.R' 'geom-text.R' 'geom-tile.R' 'geom-violin.R' 'geom-vline.R' 'ggplot2-package.R' 'grob-absolute.R' 'grob-dotstack.R' 'grob-null.R' 'grouping.R' 'theme-elements.R' 'guide-.R' 'guide-axis.R' 'guide-axis-logticks.R' 'guide-axis-stack.R' 'guide-axis-theta.R' 'guide-legend.R' 'guide-bins.R' 'guide-colorbar.R' 'guide-colorsteps.R' 'guide-custom.R' 'layer.R' 'guide-none.R' 'guide-old.R' 'guides-.R' 'guides-grid.R' 'hexbin.R' 'import-standalone-obj-type.R' 'import-standalone-types-check.R' 'labeller.R' 'labels.R' 'layer-sf.R' 'layout.R' 'limits.R' 'margins.R' 'performance.R' 'plot-build.R' 'plot-construction.R' 'plot-last.R' 'plot.R' 'position-.R' 'position-collide.R' 'position-dodge.R' 'position-dodge2.R' 'position-identity.R' 'position-jitter.R' 'position-jitterdodge.R' 'position-nudge.R' 'position-stack.R' 'quick-plot.R' 'reshape-add-margins.R' 'save.R' 'scale-.R' 'scale-alpha.R' 'scale-binned.R' 'scale-brewer.R' 'scale-colour.R' 'scale-continuous.R' 'scale-date.R' 'scale-discrete-.R' 'scale-expansion.R' 'scale-gradient.R' 'scale-grey.R' 'scale-hue.R' 'scale-identity.R' 'scale-linetype.R' 'scale-linewidth.R' 'scale-manual.R' 'scale-shape.R' 'scale-size.R' 'scale-steps.R' 'scale-type.R' 'scale-view.R' 'scale-viridis.R' 'scales-.R' 'stat-align.R' 'stat-bin.R' 'stat-bin2d.R' 'stat-bindot.R' 'stat-binhex.R' 'stat-boxplot.R' 'stat-contour.R' 'stat-count.R' 'stat-density-2d.R' 'stat-density.R' 'stat-ecdf.R' 'stat-ellipse.R' 'stat-function.R' 'stat-identity.R' 'stat-qq-line.R' 'stat-qq.R' 'stat-quantilemethods.R' 'stat-sf-coordinates.R' 'stat-sf.R' 'stat-smooth-methods.R' 'stat-smooth.R' 'stat-sum.R' 'stat-summary-2d.R' 'stat-summary-bin.R' 'stat-summary-hex.R' 'stat-summary.R' 'stat-unique.R' 'stat-ydensity.R' 'summarise-plot.R' 'summary.R' 'theme.R' 'theme-defaults.R' 'theme-current.R' 'utilities-break.R' 'utilities-grid.R' 'utilities-help.R' 'utilities-matrix.R' 'utilities-patterns.R' 'utilities-resolution.R' 'utilities-tidy-eval.R' 'zxx.R' 'zzz.R'", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut] (), Winston Chang [aut] (), Lionel Henry [aut], Thomas Lin Pedersen [aut, cre] (), Kohske Takahashi [aut], Claus Wilke [aut] (), Kara Woo [aut] (), Hiroaki Yutani [aut] (), Dewey Dunnington [aut] (), Teun van den Brand [aut] (), Posit, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "RSPM" - }, - "gld": { - "Package": "gld", - "Version": "2.6.7", - "Source": "Repository", - "Date": "2025-01-17", - "Title": "Estimation and Use of the Generalised (Tukey) Lambda Distribution", - "Suggests": [], - "Imports": [ - "stats", - "graphics", - "e1071", - "lmom" - ], - "Authors@R": "c(person(given=\"Robert\",family=\"King\", role=c(\"aut\",\"cre\"), email=\"Robert.King.Newcastle@gmail.com\", comment=c(ORCID=\"0000-0001-7495-6599\")), person(given=\"Benjamin\",family=\"Dean\", role=\"aut\", email=\"Benjamin.Dean@uon.edu.au\"), person(given=\"Sigbert\",family=\"Klinke\", role=\"aut\"), person(given=\"Paul\",family=\"van Staden\", role=\"aut\",email=\"paul.vanstaden@up.ac.za\", comment=c(ORCID=\"0000-0002-5710-5984\")) )", - "Description": "The generalised lambda distribution, or Tukey lambda distribution, provides a wide variety of shapes with one functional form. This package provides random numbers, quantiles, probabilities, densities and density quantiles for four different types of the distribution, the FKML (Freimer et al 1988), RS (Ramberg and Schmeiser 1974), GPD (van Staden and Loots 2009) and FM5 - see documentation for details. It provides the density function, distribution function, and Quantile-Quantile plots. It implements a variety of estimation methods for the distribution, including diagnostic plots. Estimation methods include the starship (all 4 types), method of L-Moments for the GPD and FKML types, and a number of methods for only the FKML type. These include maximum likelihood, maximum product of spacings, Titterington's method, Moments, Trimmed L-Moments and Distributional Least Absolutes.", - "License": "GPL (>= 2)", - "URL": "https://github.com/newystats/gld/", - "NeedsCompilation": "yes", - "Author": "Robert King [aut, cre] (), Benjamin Dean [aut], Sigbert Klinke [aut], Paul van Staden [aut] ()", - "Maintainer": "Robert King ", - "Repository": "CRAN" - }, - "glue": { - "Package": "glue", - "Version": "1.8.0", - "Source": "Repository", - "Title": "Interpreted String Literals", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "An implementation of interpreted string literals, inspired by Python's Literal String Interpolation and Docstrings and Julia's Triple-Quoted String Literals .", - "License": "MIT + file LICENSE", - "URL": "https://glue.tidyverse.org/, https://github.com/tidyverse/glue", - "BugReports": "https://github.com/tidyverse/glue/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "methods" - ], - "Suggests": [ - "crayon", - "DBI (>= 1.2.0)", - "dplyr", - "knitr", - "magrittr", - "rlang", - "rmarkdown", - "RSQLite", - "testthat (>= 3.2.0)", - "vctrs (>= 0.3.0)", - "waldo (>= 0.5.3)", - "withr" - ], - "VignetteBuilder": "knitr", - "ByteCompile": "true", - "Config/Needs/website": "bench, forcats, ggbeeswarm, ggplot2, R.utils, rprintf, tidyr, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Jim Hester [aut] (), Jennifer Bryan [aut, cre] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Jennifer Bryan ", - "Repository": "RSPM" - }, - "gridExtra": { - "Package": "gridExtra", - "Version": "2.3", - "Source": "Repository", - "Authors@R": "c(person(\"Baptiste\", \"Auguie\", email = \"baptiste.auguie@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Anton\", \"Antonov\", email = \"tonytonov@gmail.com\", role = c(\"ctb\")))", - "License": "GPL (>= 2)", - "Title": "Miscellaneous Functions for \"Grid\" Graphics", - "Type": "Package", - "Description": "Provides a number of user-level functions to work with \"grid\" graphics, notably to arrange multiple grid-based plots on a page, and draw tables.", - "VignetteBuilder": "knitr", - "Imports": [ - "gtable", - "grid", - "grDevices", - "graphics", - "utils" - ], - "Suggests": [ - "ggplot2", - "egg", - "lattice", - "knitr", - "testthat" - ], - "RoxygenNote": "6.0.1", - "NeedsCompilation": "no", - "Author": "Baptiste Auguie [aut, cre], Anton Antonov [ctb]", - "Maintainer": "Baptiste Auguie ", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "gtable": { - "Package": "gtable", - "Version": "0.3.6", - "Source": "Repository", - "Title": "Arrange 'Grobs' in Tables", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Tools to make it easier to work with \"tables\" of 'grobs'. The 'gtable' package defines a 'gtable' grob class that specifies a grid along with a list of grobs and their placement in the grid. Further the package makes it easy to manipulate and combine 'gtable' objects so that complex compositions can be built up sequentially.", - "License": "MIT + file LICENSE", - "URL": "https://gtable.r-lib.org, https://github.com/r-lib/gtable", - "BugReports": "https://github.com/r-lib/gtable/issues", - "Depends": [ - "R (>= 4.0)" - ], - "Imports": [ - "cli", - "glue", - "grid", - "lifecycle", - "rlang (>= 1.1.0)", - "stats" - ], - "Suggests": [ - "covr", - "ggplot2", - "knitr", - "profvis", - "rmarkdown", - "testthat (>= 3.0.0)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Config/usethis/last-upkeep": "2024-10-25", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut], Thomas Lin Pedersen [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "CRAN" - }, - "haven": { - "Package": "haven", - "Version": "2.5.4", - "Source": "Repository", - "Title": "Import and Export 'SPSS', 'Stata' and 'SAS' Files", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Evan\", \"Miller\", role = c(\"aut\", \"cph\"), comment = \"Author of included ReadStat code\"), person(\"Danny\", \"Smith\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Import foreign statistical formats into R via the embedded 'ReadStat' C library, .", - "License": "MIT + file LICENSE", - "URL": "https://haven.tidyverse.org, https://github.com/tidyverse/haven, https://github.com/WizardMac/ReadStat", - "BugReports": "https://github.com/tidyverse/haven/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli (>= 3.0.0)", - "forcats (>= 0.2.0)", - "hms", - "lifecycle", - "methods", - "readr (>= 0.1.0)", - "rlang (>= 0.4.0)", - "tibble", - "tidyselect", - "vctrs (>= 0.3.0)" - ], - "Suggests": [ - "covr", - "crayon", - "fs", - "knitr", - "pillar (>= 1.4.0)", - "rmarkdown", - "testthat (>= 3.0.0)", - "utf8" - ], - "LinkingTo": [ - "cpp11" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "SystemRequirements": "GNU make, zlib: zlib1g-dev (deb), zlib-devel (rpm)", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre], Evan Miller [aut, cph] (Author of included ReadStat code), Danny Smith [aut], Posit Software, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "highr": { - "Package": "highr", - "Version": "0.11", - "Source": "Repository", - "Type": "Package", - "Title": "Syntax Highlighting for R Source Code", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Yixuan\", \"Qiu\", role = \"aut\"), person(\"Christopher\", \"Gandrud\", role = \"ctb\"), person(\"Qiang\", \"Li\", role = \"ctb\") )", - "Description": "Provides syntax highlighting for R source code. Currently it supports LaTeX and HTML output. Source code of other languages is supported via Andre Simon's highlight package ().", - "Depends": [ - "R (>= 3.3.0)" - ], - "Imports": [ - "xfun (>= 0.18)" - ], - "Suggests": [ - "knitr", - "markdown", - "testit" - ], - "License": "GPL", - "URL": "https://github.com/yihui/highr", - "BugReports": "https://github.com/yihui/highr/issues", - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "NeedsCompilation": "no", - "Author": "Yihui Xie [aut, cre] (), Yixuan Qiu [aut], Christopher Gandrud [ctb], Qiang Li [ctb]", - "Maintainer": "Yihui Xie ", - "Repository": "RSPM" - }, - "hms": { - "Package": "hms", - "Version": "1.1.3", - "Source": "Repository", - "Title": "Pretty Time of Day", - "Date": "2023-03-21", - "Authors@R": "c( person(\"Kirill\", \"Müller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(\"R Consortium\", role = \"fnd\"), person(\"RStudio\", role = \"fnd\") )", - "Description": "Implements an S3 class for storing and formatting time-of-day values, based on the 'difftime' class.", - "Imports": [ - "lifecycle", - "methods", - "pkgconfig", - "rlang (>= 1.0.2)", - "vctrs (>= 0.3.8)" - ], - "Suggests": [ - "crayon", - "lubridate", - "pillar (>= 1.1.0)", - "testthat (>= 3.0.0)" - ], - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "URL": "https://hms.tidyverse.org/, https://github.com/tidyverse/hms", - "BugReports": "https://github.com/tidyverse/hms/issues", - "RoxygenNote": "7.2.3", - "Config/testthat/edition": "3", - "Config/autostyle/scope": "line_breaks", - "Config/autostyle/strict": "false", - "Config/Needs/website": "tidyverse/tidytemplate", - "NeedsCompilation": "no", - "Author": "Kirill Müller [aut, cre] (), R Consortium [fnd], RStudio [fnd]", - "Maintainer": "Kirill Müller ", - "Repository": "RSPM" - }, - "htmltools": { - "Package": "htmltools", - "Version": "0.5.8.1", - "Source": "Repository", - "Type": "Package", - "Title": "Tools for HTML", - "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Barret\", \"Schloerke\", , \"barret@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Yihui\", \"Xie\", , \"yihui@posit.co\", role = \"aut\"), person(\"Jeff\", \"Allen\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Tools for HTML generation and output.", - "License": "GPL (>= 2)", - "URL": "https://github.com/rstudio/htmltools, https://rstudio.github.io/htmltools/", - "BugReports": "https://github.com/rstudio/htmltools/issues", - "Depends": [ - "R (>= 2.14.1)" - ], - "Imports": [ - "base64enc", - "digest", - "fastmap (>= 1.1.0)", - "grDevices", - "rlang (>= 1.0.0)", - "utils" - ], - "Suggests": [ - "Cairo", - "markdown", - "ragg", - "shiny", - "testthat", - "withr" - ], - "Enhances": [ - "knitr" - ], - "Config/Needs/check": "knitr", - "Config/Needs/website": "rstudio/quillt, bench", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "Collate": "'colors.R' 'fill.R' 'html_dependency.R' 'html_escape.R' 'html_print.R' 'htmltools-package.R' 'images.R' 'known_tags.R' 'selector.R' 'staticimports.R' 'tag_query.R' 'utils.R' 'tags.R' 'template.R'", - "NeedsCompilation": "yes", - "Author": "Joe Cheng [aut], Carson Sievert [aut, cre] (), Barret Schloerke [aut] (), Winston Chang [aut] (), Yihui Xie [aut], Jeff Allen [aut], Posit Software, PBC [cph, fnd]", - "Maintainer": "Carson Sievert ", - "Repository": "RSPM" - }, - "htmlwidgets": { - "Package": "htmlwidgets", - "Version": "1.6.4", - "Source": "Repository", - "Type": "Package", - "Title": "HTML Widgets for R", - "Authors@R": "c( person(\"Ramnath\", \"Vaidyanathan\", role = c(\"aut\", \"cph\")), person(\"Yihui\", \"Xie\", role = \"aut\"), person(\"JJ\", \"Allaire\", role = \"aut\"), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Carson\", \"Sievert\", , \"carson@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Kenton\", \"Russell\", role = c(\"aut\", \"cph\")), person(\"Ellis\", \"Hughes\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A framework for creating HTML widgets that render in various contexts including the R console, 'R Markdown' documents, and 'Shiny' web applications.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/ramnathv/htmlwidgets", - "BugReports": "https://github.com/ramnathv/htmlwidgets/issues", - "Imports": [ - "grDevices", - "htmltools (>= 0.5.7)", - "jsonlite (>= 0.9.16)", - "knitr (>= 1.8)", - "rmarkdown", - "yaml" - ], - "Suggests": [ - "testthat" - ], - "Enhances": [ - "shiny (>= 1.1)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Ramnath Vaidyanathan [aut, cph], Yihui Xie [aut], JJ Allaire [aut], Joe Cheng [aut], Carson Sievert [aut, cre] (), Kenton Russell [aut, cph], Ellis Hughes [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Carson Sievert ", - "Repository": "RSPM" - }, - "httpuv": { - "Package": "httpuv", - "Version": "1.6.15", - "Source": "Repository", - "Type": "Package", - "Title": "HTTP and WebSocket Server Library", - "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit, PBC\", \"fnd\", role = \"cph\"), person(\"Hector\", \"Corrada Bravo\", role = \"ctb\"), person(\"Jeroen\", \"Ooms\", role = \"ctb\"), person(\"Andrzej\", \"Krzemienski\", role = \"cph\", comment = \"optional.hpp\"), person(\"libuv project contributors\", role = \"cph\", comment = \"libuv library, see src/libuv/AUTHORS file\"), person(\"Joyent, Inc. and other Node contributors\", role = \"cph\", comment = \"libuv library, see src/libuv/AUTHORS file; and http-parser library, see src/http-parser/AUTHORS file\"), person(\"Niels\", \"Provos\", role = \"cph\", comment = \"libuv subcomponent: tree.h\"), person(\"Internet Systems Consortium, Inc.\", role = \"cph\", comment = \"libuv subcomponent: inet_pton and inet_ntop, contained in src/libuv/src/inet.c\"), person(\"Alexander\", \"Chemeris\", role = \"cph\", comment = \"libuv subcomponent: stdint-msvc2008.h (from msinttypes)\"), person(\"Google, Inc.\", role = \"cph\", comment = \"libuv subcomponent: pthread-fixes.c\"), person(\"Sony Mobile Communcations AB\", role = \"cph\", comment = \"libuv subcomponent: pthread-fixes.c\"), person(\"Berkeley Software Design Inc.\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Kenneth\", \"MacKay\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Emergya (Cloud4all, FP7/2007-2013, grant agreement no 289016)\", role = \"cph\", comment = \"libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c\"), person(\"Steve\", \"Reid\", role = \"aut\", comment = \"SHA-1 implementation\"), person(\"James\", \"Brown\", role = \"aut\", comment = \"SHA-1 implementation\"), person(\"Bob\", \"Trower\", role = \"aut\", comment = \"base64 implementation\"), person(\"Alexander\", \"Peslyak\", role = \"aut\", comment = \"MD5 implementation\"), person(\"Trantor Standard Systems\", role = \"cph\", comment = \"base64 implementation\"), person(\"Igor\", \"Sysoev\", role = \"cph\", comment = \"http-parser\") )", - "Description": "Provides low-level socket and protocol support for handling HTTP and WebSocket requests directly from within R. It is primarily intended as a building block for other packages, rather than making it particularly easy to create complete web applications using httpuv alone. httpuv is built on top of the libuv and http-parser C libraries, both of which were developed by Joyent, Inc. (See LICENSE file for libuv and http-parser license information.)", - "License": "GPL (>= 2) | file LICENSE", - "URL": "https://github.com/rstudio/httpuv", - "BugReports": "https://github.com/rstudio/httpuv/issues", - "Depends": [ - "R (>= 2.15.1)" - ], - "Imports": [ - "later (>= 0.8.0)", - "promises", - "R6", - "Rcpp (>= 1.0.7)", - "utils" - ], - "Suggests": [ - "callr", - "curl", - "testthat", - "websocket" - ], - "LinkingTo": [ - "later", - "Rcpp" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "SystemRequirements": "GNU make, zlib", - "Collate": "'RcppExports.R' 'httpuv.R' 'random_port.R' 'server.R' 'staticServer.R' 'static_paths.R' 'utils.R'", - "NeedsCompilation": "yes", - "Author": "Joe Cheng [aut], Winston Chang [aut, cre], Posit, PBC fnd [cph], Hector Corrada Bravo [ctb], Jeroen Ooms [ctb], Andrzej Krzemienski [cph] (optional.hpp), libuv project contributors [cph] (libuv library, see src/libuv/AUTHORS file), Joyent, Inc. and other Node contributors [cph] (libuv library, see src/libuv/AUTHORS file; and http-parser library, see src/http-parser/AUTHORS file), Niels Provos [cph] (libuv subcomponent: tree.h), Internet Systems Consortium, Inc. [cph] (libuv subcomponent: inet_pton and inet_ntop, contained in src/libuv/src/inet.c), Alexander Chemeris [cph] (libuv subcomponent: stdint-msvc2008.h (from msinttypes)), Google, Inc. [cph] (libuv subcomponent: pthread-fixes.c), Sony Mobile Communcations AB [cph] (libuv subcomponent: pthread-fixes.c), Berkeley Software Design Inc. [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Kenneth MacKay [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Emergya (Cloud4all, FP7/2007-2013, grant agreement no 289016) [cph] (libuv subcomponent: android-ifaddrs.h, android-ifaddrs.c), Steve Reid [aut] (SHA-1 implementation), James Brown [aut] (SHA-1 implementation), Bob Trower [aut] (base64 implementation), Alexander Peslyak [aut] (MD5 implementation), Trantor Standard Systems [cph] (base64 implementation), Igor Sysoev [cph] (http-parser)", - "Maintainer": "Winston Chang ", - "Repository": "RSPM" - }, - "httr": { - "Package": "httr", - "Version": "1.4.7", - "Source": "Repository", - "Title": "Tools for Working with URLs and HTTP", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Useful tools for working with HTTP organised by HTTP verbs (GET(), POST(), etc). Configuration functions make it easy to control additional request components (authenticate(), add_headers() and so on).", - "License": "MIT + file LICENSE", - "URL": "https://httr.r-lib.org/, https://github.com/r-lib/httr", - "BugReports": "https://github.com/r-lib/httr/issues", - "Depends": [ - "R (>= 3.5)" - ], - "Imports": [ - "curl (>= 5.0.2)", - "jsonlite", - "mime", - "openssl (>= 0.8)", - "R6" - ], - "Suggests": [ - "covr", - "httpuv", - "jpeg", - "knitr", - "png", - "readr", - "rmarkdown", - "testthat (>= 0.8.0)", - "xml2" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre], Posit, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "isoband": { - "Package": "isoband", - "Version": "0.2.7", - "Source": "Repository", - "Title": "Generate Isolines and Isobands from Regularly Spaced Elevation Grids", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Claus O.\", \"Wilke\", , \"wilke@austin.utexas.edu\", role = \"aut\", comment = c(\"Original author\", ORCID = \"0000-0002-7470-9261\")), person(\"Thomas Lin\", \"Pedersen\", , \"thomasp85@gmail.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-5147-4711\")) )", - "Description": "A fast C++ implementation to generate contour lines (isolines) and contour polygons (isobands) from regularly spaced grids containing elevation data.", - "License": "MIT + file LICENSE", - "URL": "https://isoband.r-lib.org", - "BugReports": "https://github.com/r-lib/isoband/issues", - "Imports": [ - "grid", - "utils" - ], - "Suggests": [ - "covr", - "ggplot2", - "knitr", - "magick", - "microbenchmark", - "rmarkdown", - "sf", - "testthat", - "xml2" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "SystemRequirements": "C++11", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre] (), Claus O. Wilke [aut] (Original author, ), Thomas Lin Pedersen [aut] ()", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "jquerylib": { - "Package": "jquerylib", - "Version": "0.1.4", - "Source": "Repository", - "Title": "Obtain 'jQuery' as an HTML Dependency Object", - "Authors@R": "c( person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"carson@rstudio.com\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@rstudio.com\"), person(family = \"RStudio\", role = \"cph\"), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/lib/jquery-AUTHORS.txt\") )", - "Description": "Obtain any major version of 'jQuery' () and use it in any webpage generated by 'htmltools' (e.g. 'shiny', 'htmlwidgets', and 'rmarkdown'). Most R users don't need to use this package directly, but other R packages (e.g. 'shiny', 'rmarkdown', etc.) depend on this package to avoid bundling redundant copies of 'jQuery'.", - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "Config/testthat/edition": "3", - "RoxygenNote": "7.0.2", - "Imports": [ - "htmltools" - ], - "Suggests": [ - "testthat" - ], - "NeedsCompilation": "no", - "Author": "Carson Sievert [aut, cre] (), Joe Cheng [aut], RStudio [cph], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/lib/jquery-AUTHORS.txt)", - "Maintainer": "Carson Sievert ", - "Repository": "RSPM" - }, - "jsonlite": { - "Package": "jsonlite", - "Version": "1.8.9", - "Source": "Repository", - "Title": "A Simple and Robust JSON Parser and Generator for R", - "License": "MIT + file LICENSE", - "Depends": [ - "methods" - ], - "Authors@R": "c( person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Duncan\", \"Temple Lang\", role = \"ctb\"), person(\"Lloyd\", \"Hilaiel\", role = \"cph\", comment=\"author of bundled libyajl\"))", - "URL": "https://jeroen.r-universe.dev/jsonlite https://arxiv.org/abs/1403.2805", - "BugReports": "https://github.com/jeroen/jsonlite/issues", - "Maintainer": "Jeroen Ooms ", - "VignetteBuilder": "knitr, R.rsp", - "Description": "A reasonably fast JSON parser and generator, optimized for statistical data and the web. Offers simple, flexible tools for working with JSON in R, and is particularly powerful for building pipelines and interacting with a web API. The implementation is based on the mapping described in the vignette (Ooms, 2014). In addition to converting JSON data from/to R objects, 'jsonlite' contains functions to stream, validate, and prettify JSON data. The unit tests included with the package verify that all edge cases are encoded and decoded consistently for use with dynamic data in systems and applications.", - "Suggests": [ - "httr", - "vctrs", - "testthat", - "knitr", - "rmarkdown", - "R.rsp", - "sf" - ], - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] (), Duncan Temple Lang [ctb], Lloyd Hilaiel [cph] (author of bundled libyajl)", - "Repository": "RSPM" - }, - "knitr": { - "Package": "knitr", - "Version": "1.49", - "Source": "Repository", - "Type": "Package", - "Title": "A General-Purpose Package for Dynamic Report Generation in R", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Abhraneel\", \"Sarma\", role = \"ctb\"), person(\"Adam\", \"Vogt\", role = \"ctb\"), person(\"Alastair\", \"Andrew\", role = \"ctb\"), person(\"Alex\", \"Zvoleff\", role = \"ctb\"), person(\"Amar\", \"Al-Zubaidi\", role = \"ctb\"), person(\"Andre\", \"Simon\", role = \"ctb\", comment = \"the CSS files under inst/themes/ were derived from the Highlight package http://www.andre-simon.de\"), person(\"Aron\", \"Atkins\", role = \"ctb\"), person(\"Aaron\", \"Wolen\", role = \"ctb\"), person(\"Ashley\", \"Manton\", role = \"ctb\"), person(\"Atsushi\", \"Yasumoto\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8335-495X\")), person(\"Ben\", \"Baumer\", role = \"ctb\"), person(\"Brian\", \"Diggs\", role = \"ctb\"), person(\"Brian\", \"Zhang\", role = \"ctb\"), person(\"Bulat\", \"Yapparov\", role = \"ctb\"), person(\"Cassio\", \"Pereira\", role = \"ctb\"), person(\"Christophe\", \"Dervieux\", role = \"ctb\"), person(\"David\", \"Hall\", role = \"ctb\"), person(\"David\", \"Hugh-Jones\", role = \"ctb\"), person(\"David\", \"Robinson\", role = \"ctb\"), person(\"Doug\", \"Hemken\", role = \"ctb\"), person(\"Duncan\", \"Murdoch\", role = \"ctb\"), person(\"Elio\", \"Campitelli\", role = \"ctb\"), person(\"Ellis\", \"Hughes\", role = \"ctb\"), person(\"Emily\", \"Riederer\", role = \"ctb\"), person(\"Fabian\", \"Hirschmann\", role = \"ctb\"), person(\"Fitch\", \"Simeon\", role = \"ctb\"), person(\"Forest\", \"Fang\", role = \"ctb\"), person(c(\"Frank\", \"E\", \"Harrell\", \"Jr\"), role = \"ctb\", comment = \"the Sweavel package at inst/misc/Sweavel.sty\"), person(\"Garrick\", \"Aden-Buie\", role = \"ctb\"), person(\"Gregoire\", \"Detrez\", role = \"ctb\"), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Hao\", \"Zhu\", role = \"ctb\"), person(\"Heewon\", \"Jeon\", role = \"ctb\"), person(\"Henrik\", \"Bengtsson\", role = \"ctb\"), person(\"Hiroaki\", \"Yutani\", role = \"ctb\"), person(\"Ian\", \"Lyttle\", role = \"ctb\"), person(\"Hodges\", \"Daniel\", role = \"ctb\"), person(\"Jacob\", \"Bien\", role = \"ctb\"), person(\"Jake\", \"Burkhead\", role = \"ctb\"), person(\"James\", \"Manton\", role = \"ctb\"), person(\"Jared\", \"Lander\", role = \"ctb\"), person(\"Jason\", \"Punyon\", role = \"ctb\"), person(\"Javier\", \"Luraschi\", role = \"ctb\"), person(\"Jeff\", \"Arnold\", role = \"ctb\"), person(\"Jenny\", \"Bryan\", role = \"ctb\"), person(\"Jeremy\", \"Ashkenas\", role = c(\"ctb\", \"cph\"), comment = \"the CSS file at inst/misc/docco-classic.css\"), person(\"Jeremy\", \"Stephens\", role = \"ctb\"), person(\"Jim\", \"Hester\", role = \"ctb\"), person(\"Joe\", \"Cheng\", role = \"ctb\"), person(\"Johannes\", \"Ranke\", role = \"ctb\"), person(\"John\", \"Honaker\", role = \"ctb\"), person(\"John\", \"Muschelli\", role = \"ctb\"), person(\"Jonathan\", \"Keane\", role = \"ctb\"), person(\"JJ\", \"Allaire\", role = \"ctb\"), person(\"Johan\", \"Toloe\", role = \"ctb\"), person(\"Jonathan\", \"Sidi\", role = \"ctb\"), person(\"Joseph\", \"Larmarange\", role = \"ctb\"), person(\"Julien\", \"Barnier\", role = \"ctb\"), person(\"Kaiyin\", \"Zhong\", role = \"ctb\"), person(\"Kamil\", \"Slowikowski\", role = \"ctb\"), person(\"Karl\", \"Forner\", role = \"ctb\"), person(c(\"Kevin\", \"K.\"), \"Smith\", role = \"ctb\"), person(\"Kirill\", \"Mueller\", role = \"ctb\"), person(\"Kohske\", \"Takahashi\", role = \"ctb\"), person(\"Lorenz\", \"Walthert\", role = \"ctb\"), person(\"Lucas\", \"Gallindo\", role = \"ctb\"), person(\"Marius\", \"Hofert\", role = \"ctb\"), person(\"Martin\", \"Modrák\", role = \"ctb\"), person(\"Michael\", \"Chirico\", role = \"ctb\"), person(\"Michael\", \"Friendly\", role = \"ctb\"), person(\"Michal\", \"Bojanowski\", role = \"ctb\"), person(\"Michel\", \"Kuhlmann\", role = \"ctb\"), person(\"Miller\", \"Patrick\", role = \"ctb\"), person(\"Nacho\", \"Caballero\", role = \"ctb\"), person(\"Nick\", \"Salkowski\", role = \"ctb\"), person(\"Niels Richard\", \"Hansen\", role = \"ctb\"), person(\"Noam\", \"Ross\", role = \"ctb\"), person(\"Obada\", \"Mahdi\", role = \"ctb\"), person(\"Pavel N.\", \"Krivitsky\", role = \"ctb\", comment=c(ORCID = \"0000-0002-9101-3362\")), person(\"Pedro\", \"Faria\", role = \"ctb\"), person(\"Qiang\", \"Li\", role = \"ctb\"), person(\"Ramnath\", \"Vaidyanathan\", role = \"ctb\"), person(\"Richard\", \"Cotton\", role = \"ctb\"), person(\"Robert\", \"Krzyzanowski\", role = \"ctb\"), person(\"Rodrigo\", \"Copetti\", role = \"ctb\"), person(\"Romain\", \"Francois\", role = \"ctb\"), person(\"Ruaridh\", \"Williamson\", role = \"ctb\"), person(\"Sagiru\", \"Mati\", role = \"ctb\", comment = c(ORCID = \"0000-0003-1413-3974\")), person(\"Scott\", \"Kostyshak\", role = \"ctb\"), person(\"Sebastian\", \"Meyer\", role = \"ctb\"), person(\"Sietse\", \"Brouwer\", role = \"ctb\"), person(c(\"Simon\", \"de\"), \"Bernard\", role = \"ctb\"), person(\"Sylvain\", \"Rousseau\", role = \"ctb\"), person(\"Taiyun\", \"Wei\", role = \"ctb\"), person(\"Thibaut\", \"Assus\", role = \"ctb\"), person(\"Thibaut\", \"Lamadon\", role = \"ctb\"), person(\"Thomas\", \"Leeper\", role = \"ctb\"), person(\"Tim\", \"Mastny\", role = \"ctb\"), person(\"Tom\", \"Torsney-Weir\", role = \"ctb\"), person(\"Trevor\", \"Davis\", role = \"ctb\"), person(\"Viktoras\", \"Veitas\", role = \"ctb\"), person(\"Weicheng\", \"Zhu\", role = \"ctb\"), person(\"Wush\", \"Wu\", role = \"ctb\"), person(\"Zachary\", \"Foster\", role = \"ctb\"), person(\"Zhian N.\", \"Kamvar\", role = \"ctb\", comment = c(ORCID = \"0000-0003-1458-7108\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides a general-purpose tool for dynamic report generation in R using Literate Programming techniques.", - "Depends": [ - "R (>= 3.6.0)" - ], - "Imports": [ - "evaluate (>= 0.15)", - "highr (>= 0.11)", - "methods", - "tools", - "xfun (>= 0.48)", - "yaml (>= 2.1.19)" - ], - "Suggests": [ - "bslib", - "codetools", - "DBI (>= 0.4-1)", - "digest", - "formatR", - "gifski", - "gridSVG", - "htmlwidgets (>= 0.7)", - "jpeg", - "JuliaCall (>= 0.11.1)", - "magick", - "litedown", - "markdown (>= 1.3)", - "png", - "ragg", - "reticulate (>= 1.4)", - "rgl (>= 0.95.1201)", - "rlang", - "rmarkdown", - "sass", - "showtext", - "styler (>= 1.2.0)", - "targets (>= 0.6.0)", - "testit", - "tibble", - "tikzDevice (>= 0.10)", - "tinytex (>= 0.46)", - "webshot", - "rstudioapi", - "svglite" - ], - "License": "GPL", - "URL": "https://yihui.org/knitr/", - "BugReports": "https://github.com/yihui/knitr/issues", - "Encoding": "UTF-8", - "VignetteBuilder": "litedown, knitr", - "SystemRequirements": "Package vignettes based on R Markdown v2 or reStructuredText require Pandoc (http://pandoc.org). The function rst2pdf() requires rst2pdf (https://github.com/rst2pdf/rst2pdf).", - "Collate": "'block.R' 'cache.R' 'utils.R' 'citation.R' 'hooks-html.R' 'plot.R' 'defaults.R' 'concordance.R' 'engine.R' 'highlight.R' 'themes.R' 'header.R' 'hooks-asciidoc.R' 'hooks-chunk.R' 'hooks-extra.R' 'hooks-latex.R' 'hooks-md.R' 'hooks-rst.R' 'hooks-textile.R' 'hooks.R' 'output.R' 'package.R' 'pandoc.R' 'params.R' 'parser.R' 'pattern.R' 'rocco.R' 'spin.R' 'table.R' 'template.R' 'utils-conversion.R' 'utils-rd2html.R' 'utils-string.R' 'utils-sweave.R' 'utils-upload.R' 'utils-vignettes.R' 'zzz.R'", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Yihui Xie [aut, cre] (), Abhraneel Sarma [ctb], Adam Vogt [ctb], Alastair Andrew [ctb], Alex Zvoleff [ctb], Amar Al-Zubaidi [ctb], Andre Simon [ctb] (the CSS files under inst/themes/ were derived from the Highlight package http://www.andre-simon.de), Aron Atkins [ctb], Aaron Wolen [ctb], Ashley Manton [ctb], Atsushi Yasumoto [ctb] (), Ben Baumer [ctb], Brian Diggs [ctb], Brian Zhang [ctb], Bulat Yapparov [ctb], Cassio Pereira [ctb], Christophe Dervieux [ctb], David Hall [ctb], David Hugh-Jones [ctb], David Robinson [ctb], Doug Hemken [ctb], Duncan Murdoch [ctb], Elio Campitelli [ctb], Ellis Hughes [ctb], Emily Riederer [ctb], Fabian Hirschmann [ctb], Fitch Simeon [ctb], Forest Fang [ctb], Frank E Harrell Jr [ctb] (the Sweavel package at inst/misc/Sweavel.sty), Garrick Aden-Buie [ctb], Gregoire Detrez [ctb], Hadley Wickham [ctb], Hao Zhu [ctb], Heewon Jeon [ctb], Henrik Bengtsson [ctb], Hiroaki Yutani [ctb], Ian Lyttle [ctb], Hodges Daniel [ctb], Jacob Bien [ctb], Jake Burkhead [ctb], James Manton [ctb], Jared Lander [ctb], Jason Punyon [ctb], Javier Luraschi [ctb], Jeff Arnold [ctb], Jenny Bryan [ctb], Jeremy Ashkenas [ctb, cph] (the CSS file at inst/misc/docco-classic.css), Jeremy Stephens [ctb], Jim Hester [ctb], Joe Cheng [ctb], Johannes Ranke [ctb], John Honaker [ctb], John Muschelli [ctb], Jonathan Keane [ctb], JJ Allaire [ctb], Johan Toloe [ctb], Jonathan Sidi [ctb], Joseph Larmarange [ctb], Julien Barnier [ctb], Kaiyin Zhong [ctb], Kamil Slowikowski [ctb], Karl Forner [ctb], Kevin K. Smith [ctb], Kirill Mueller [ctb], Kohske Takahashi [ctb], Lorenz Walthert [ctb], Lucas Gallindo [ctb], Marius Hofert [ctb], Martin Modrák [ctb], Michael Chirico [ctb], Michael Friendly [ctb], Michal Bojanowski [ctb], Michel Kuhlmann [ctb], Miller Patrick [ctb], Nacho Caballero [ctb], Nick Salkowski [ctb], Niels Richard Hansen [ctb], Noam Ross [ctb], Obada Mahdi [ctb], Pavel N. Krivitsky [ctb] (), Pedro Faria [ctb], Qiang Li [ctb], Ramnath Vaidyanathan [ctb], Richard Cotton [ctb], Robert Krzyzanowski [ctb], Rodrigo Copetti [ctb], Romain Francois [ctb], Ruaridh Williamson [ctb], Sagiru Mati [ctb] (), Scott Kostyshak [ctb], Sebastian Meyer [ctb], Sietse Brouwer [ctb], Simon de Bernard [ctb], Sylvain Rousseau [ctb], Taiyun Wei [ctb], Thibaut Assus [ctb], Thibaut Lamadon [ctb], Thomas Leeper [ctb], Tim Mastny [ctb], Tom Torsney-Weir [ctb], Trevor Davis [ctb], Viktoras Veitas [ctb], Weicheng Zhu [ctb], Wush Wu [ctb], Zachary Foster [ctb], Zhian N. Kamvar [ctb] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Yihui Xie ", - "Repository": "CRAN" - }, - "labeling": { - "Package": "labeling", - "Version": "0.4.3", - "Source": "Repository", - "Type": "Package", - "Title": "Axis Labeling", - "Date": "2023-08-29", - "Author": "Justin Talbot,", - "Maintainer": "Nuno Sempere ", - "Description": "Functions which provide a range of axis labeling algorithms.", - "License": "MIT + file LICENSE | Unlimited", - "Collate": "'labeling.R'", - "NeedsCompilation": "no", - "Imports": [ - "stats", - "graphics" - ], - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "labelled": { - "Package": "labelled", - "Version": "2.14.0", - "Source": "Repository", - "Type": "Package", - "Title": "Manipulating Labelled Data", - "Maintainer": "Joseph Larmarange ", - "Authors@R": "c( person(\"Joseph\", \"Larmarange\", email = \"joseph@larmarange.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7097-700X\")), person(\"Daniel\", \"Ludecke\", role = \"ctb\"), person(\"Hadley\", \"Wickham\", role = \"ctb\"), person(\"Michal\", \"Bojanowski\", role = \"ctb\"), person(\"François\", \"Briatte\", role = \"ctb\") )", - "Description": "Work with labelled data imported from 'SPSS' or 'Stata' with 'haven' or 'foreign'. This package provides useful functions to deal with \"haven_labelled\" and \"haven_labelled_spss\" classes introduced by 'haven' package.", - "License": "GPL (>= 3)", - "Encoding": "UTF-8", - "Depends": [ - "R (>= 3.2)" - ], - "Imports": [ - "haven (>= 2.4.1)", - "cli", - "dplyr (>= 1.1.0)", - "lifecycle", - "rlang (>= 1.1.0)", - "vctrs", - "stringr", - "tidyr", - "tidyselect" - ], - "Suggests": [ - "testthat (>= 3.2.0)", - "knitr", - "rmarkdown", - "questionr", - "snakecase", - "spelling" - ], - "Enhances": [ - "memisc" - ], - "URL": "https://larmarange.github.io/labelled/, https://github.com/larmarange/labelled", - "BugReports": "https://github.com/larmarange/labelled/issues", - "VignetteBuilder": "knitr", - "LazyData": "true", - "RoxygenNote": "7.3.2", - "Language": "en-US", - "Config/testthat/edition": "3", - "Config/Needs/check": "memisc", - "NeedsCompilation": "no", - "Author": "Joseph Larmarange [aut, cre] (), Daniel Ludecke [ctb], Hadley Wickham [ctb], Michal Bojanowski [ctb], François Briatte [ctb]", - "Repository": "CRAN" - }, - "later": { - "Package": "later", - "Version": "1.4.1", - "Source": "Repository", - "Type": "Package", - "Title": "Utilities for Scheduling Functions to Execute Later with Event Loops", - "Authors@R": "c( person(\"Winston\", \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@posit.co\"), person(\"Joe\", \"Cheng\", role = c(\"aut\"), email = \"joe@posit.co\"), person(\"Charlie\", \"Gao\", role = c(\"aut\"), email = \"charlie.gao@shikokuchuo.net\", comment = c(ORCID = \"0000-0002-0750-061X\")), person(family = \"Posit Software, PBC\", role = \"cph\"), person(\"Marcus\", \"Geelnard\", role = c(\"ctb\", \"cph\"), comment = \"TinyCThread library, https://tinycthread.github.io/\"), person(\"Evan\", \"Nemerson\", role = c(\"ctb\", \"cph\"), comment = \"TinyCThread library, https://tinycthread.github.io/\") )", - "Description": "Executes arbitrary R or C functions some time after the current time, after the R execution stack has emptied. The functions are scheduled in an event loop.", - "URL": "https://r-lib.github.io/later/, https://github.com/r-lib/later", - "BugReports": "https://github.com/r-lib/later/issues", - "License": "MIT + file LICENSE", - "Imports": [ - "Rcpp (>= 0.12.9)", - "rlang" - ], - "LinkingTo": [ - "Rcpp" - ], - "RoxygenNote": "7.3.2", - "Suggests": [ - "knitr", - "nanonext", - "R6", - "rmarkdown", - "testthat (>= 2.1.0)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Winston Chang [aut, cre], Joe Cheng [aut], Charlie Gao [aut] (), Posit Software, PBC [cph], Marcus Geelnard [ctb, cph] (TinyCThread library, https://tinycthread.github.io/), Evan Nemerson [ctb, cph] (TinyCThread library, https://tinycthread.github.io/)", - "Maintainer": "Winston Chang ", - "Repository": "CRAN" - }, - "lattice": { - "Package": "lattice", - "Version": "0.22-6", - "Source": "Repository", - "Date": "2024-03-20", - "Priority": "recommended", - "Title": "Trellis Graphics for R", - "Authors@R": "c(person(\"Deepayan\", \"Sarkar\", role = c(\"aut\", \"cre\"), email = \"deepayan.sarkar@r-project.org\", comment = c(ORCID = \"0000-0003-4107-1553\")), person(\"Felix\", \"Andrews\", role = \"ctb\"), person(\"Kevin\", \"Wright\", role = \"ctb\", comment = \"documentation\"), person(\"Neil\", \"Klepeis\", role = \"ctb\"), person(\"Johan\", \"Larsson\", role = \"ctb\", comment = \"miscellaneous improvements\"), person(\"Zhijian (Jason)\", \"Wen\", role = \"cph\", comment = \"filled contour code\"), person(\"Paul\", \"Murrell\", role = \"ctb\", email = \"paul@stat.auckland.ac.nz\"), person(\"Stefan\", \"Eng\", role = \"ctb\", comment = \"violin plot improvements\"), person(\"Achim\", \"Zeileis\", role = \"ctb\", comment = \"modern colors\"), person(\"Alexandre\", \"Courtiol\", role = \"ctb\", comment = \"generics for larrows, lpolygon, lrect and lsegments\") )", - "Description": "A powerful and elegant high-level data visualization system inspired by Trellis graphics, with an emphasis on multivariate data. Lattice is sufficient for typical graphics needs, and is also flexible enough to handle most nonstandard requirements. See ?Lattice for an introduction.", - "Depends": [ - "R (>= 4.0.0)" - ], - "Suggests": [ - "KernSmooth", - "MASS", - "latticeExtra", - "colorspace" - ], - "Imports": [ - "grid", - "grDevices", - "graphics", - "stats", - "utils" - ], - "Enhances": [ - "chron", - "zoo" - ], - "LazyLoad": "yes", - "LazyData": "yes", - "License": "GPL (>= 2)", - "URL": "https://lattice.r-forge.r-project.org/", - "BugReports": "https://github.com/deepayan/lattice/issues", - "NeedsCompilation": "yes", - "Author": "Deepayan Sarkar [aut, cre] (), Felix Andrews [ctb], Kevin Wright [ctb] (documentation), Neil Klepeis [ctb], Johan Larsson [ctb] (miscellaneous improvements), Zhijian (Jason) Wen [cph] (filled contour code), Paul Murrell [ctb], Stefan Eng [ctb] (violin plot improvements), Achim Zeileis [ctb] (modern colors), Alexandre Courtiol [ctb] (generics for larrows, lpolygon, lrect and lsegments)", - "Maintainer": "Deepayan Sarkar ", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "lazyeval": { - "Package": "lazyeval", - "Version": "0.2.2", - "Source": "Repository", - "Title": "Lazy (Non-Standard) Evaluation", - "Description": "An alternative approach to non-standard evaluation using formulas. Provides a full implementation of LISP style 'quasiquotation', making it easier to generate code with other code.", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", ,\"hadley@rstudio.com\", c(\"aut\", \"cre\")), person(\"RStudio\", role = \"cph\") )", - "License": "GPL-3", - "LazyData": "true", - "Depends": [ - "R (>= 3.1.0)" - ], - "Suggests": [ - "knitr", - "rmarkdown (>= 0.2.65)", - "testthat", - "covr" - ], - "VignetteBuilder": "knitr", - "RoxygenNote": "6.1.1", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre], RStudio [cph]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "lifecycle": { - "Package": "lifecycle", - "Version": "1.0.4", - "Source": "Repository", - "Title": "Manage the Life Cycle of your Package Functions", - "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Manage the life cycle of your exported functions with shared conventions, documentation badges, and user-friendly deprecation warnings.", - "License": "MIT + file LICENSE", - "URL": "https://lifecycle.r-lib.org/, https://github.com/r-lib/lifecycle", - "BugReports": "https://github.com/r-lib/lifecycle/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli (>= 3.4.0)", - "glue", - "rlang (>= 1.1.0)" - ], - "Suggests": [ - "covr", - "crayon", - "knitr", - "lintr", - "rmarkdown", - "testthat (>= 3.0.1)", - "tibble", - "tidyverse", - "tools", - "vctrs", - "withr" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate, usethis", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.1", - "NeedsCompilation": "no", - "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Lionel Henry ", - "Repository": "RSPM" - }, - "lmom": { - "Package": "lmom", - "Version": "3.2", - "Source": "Repository", - "Date": "2024-09-29", - "Title": "L-Moments", - "Author": "J. R. M. Hosking [aut, cre]", - "Maintainer": "J. R. M. Hosking ", - "Authors@R": "person(given = c(\"J.\", \"R.\", \"M.\"), family = \"Hosking\", role = c(\"aut\", \"cre\"), email = \"jrmhosking@gmail.com\")", - "Description": "Functions related to L-moments: computation of L-moments and trimmed L-moments of distributions and data samples; parameter estimation; L-moment ratio diagram; plot vs. quantiles of an extreme-value distribution.", - "Depends": [ - "R (>= 3.0.0)" - ], - "Imports": [ - "stats", - "graphics" - ], - "License": "Common Public License Version 1.0", - "NeedsCompilation": "yes", - "Repository": "CRAN" - }, - "logger": { - "Package": "logger", - "Version": "0.4.0", - "Source": "Repository", - "Type": "Package", - "Title": "A Lightweight, Modern and Flexible Logging Utility", - "Date": "2024-10-19", - "Authors@R": "c( person(\"Gergely\", \"Daróczi\", , \"daroczig@rapporter.net\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-3149-8537\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"System1\", role = \"fnd\") )", - "Description": "Inspired by the the 'futile.logger' R package and 'logging' Python module, this utility provides a flexible and extensible way of formatting and delivering log messages with low overhead.", - "License": "MIT + file LICENSE", - "URL": "https://daroczig.github.io/logger/", - "BugReports": "https://github.com/daroczig/logger/issues", - "Depends": [ - "R (>= 4.0.0)" - ], - "Imports": [ - "utils" - ], - "Suggests": [ - "botor", - "covr", - "crayon", - "devtools", - "glue", - "jsonlite", - "knitr", - "mirai (>= 1.3.0)", - "pander", - "parallel", - "R.utils", - "rmarkdown", - "roxygen2", - "RPushbullet", - "rsyslog", - "shiny", - "slackr (>= 1.4.1)", - "syslognet", - "telegram", - "testthat (>= 3.0.0)", - "withr" - ], - "Enhances": [ - "futile.logger", - "log4r", - "logging" - ], - "VignetteBuilder": "knitr", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "TRUE", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Gergely Daróczi [aut, cre] (), Hadley Wickham [aut] (), System1 [fnd]", - "Maintainer": "Gergely Daróczi ", - "Repository": "CRAN" - }, - "magrittr": { - "Package": "magrittr", - "Version": "2.0.3", - "Source": "Repository", - "Type": "Package", - "Title": "A Forward-Pipe Operator for R", - "Authors@R": "c( person(\"Stefan Milton\", \"Bache\", , \"stefan@stefanbache.dk\", role = c(\"aut\", \"cph\"), comment = \"Original author and creator of magrittr\"), person(\"Hadley\", \"Wickham\", , \"hadley@rstudio.com\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@rstudio.com\", role = \"cre\"), person(\"RStudio\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides a mechanism for chaining commands with a new forward-pipe operator, %>%. This operator will forward a value, or the result of an expression, into the next function call/expression. There is flexible support for the type of right-hand side expressions. For more information, see package vignette. To quote Rene Magritte, \"Ceci n'est pas un pipe.\"", - "License": "MIT + file LICENSE", - "URL": "https://magrittr.tidyverse.org, https://github.com/tidyverse/magrittr", - "BugReports": "https://github.com/tidyverse/magrittr/issues", - "Depends": [ - "R (>= 3.4.0)" - ], - "Suggests": [ - "covr", - "knitr", - "rlang", - "rmarkdown", - "testthat" - ], - "VignetteBuilder": "knitr", - "ByteCompile": "Yes", - "Config/Needs/website": "tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.1.2", - "NeedsCompilation": "yes", - "Author": "Stefan Milton Bache [aut, cph] (Original author and creator of magrittr), Hadley Wickham [aut], Lionel Henry [cre], RStudio [cph, fnd]", - "Maintainer": "Lionel Henry ", - "Repository": "CRAN" - }, - "memoise": { - "Package": "memoise", - "Version": "2.0.1", - "Source": "Repository", - "Title": "'Memoisation' of Functions", - "Authors@R": "c(person(given = \"Hadley\", family = \"Wickham\", role = \"aut\", email = \"hadley@rstudio.com\"), person(given = \"Jim\", family = \"Hester\", role = \"aut\"), person(given = \"Winston\", family = \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@rstudio.com\"), person(given = \"Kirill\", family = \"Müller\", role = \"aut\", email = \"krlmlr+r@mailbox.org\"), person(given = \"Daniel\", family = \"Cook\", role = \"aut\", email = \"danielecook@gmail.com\"), person(given = \"Mark\", family = \"Edmondson\", role = \"ctb\", email = \"r@sunholo.com\"))", - "Description": "Cache the results of a function so that when you call it again with the same arguments it returns the previously computed value.", - "License": "MIT + file LICENSE", - "URL": "https://memoise.r-lib.org, https://github.com/r-lib/memoise", - "BugReports": "https://github.com/r-lib/memoise/issues", - "Imports": [ - "rlang (>= 0.4.10)", - "cachem" - ], - "Suggests": [ - "digest", - "aws.s3", - "covr", - "googleAuthR", - "googleCloudStorageR", - "httr", - "testthat" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.1.2", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut], Jim Hester [aut], Winston Chang [aut, cre], Kirill Müller [aut], Daniel Cook [aut], Mark Edmondson [ctb]", - "Maintainer": "Winston Chang ", - "Repository": "RSPM" - }, - "mgcv": { - "Package": "mgcv", - "Version": "1.9-1", - "Source": "Repository", - "Author": "Simon Wood ", - "Maintainer": "Simon Wood ", - "Title": "Mixed GAM Computation Vehicle with Automatic Smoothness Estimation", - "Description": "Generalized additive (mixed) models, some of their extensions and other generalized ridge regression with multiple smoothing parameter estimation by (Restricted) Marginal Likelihood, Generalized Cross Validation and similar, or using iterated nested Laplace approximation for fully Bayesian inference. See Wood (2017) for an overview. Includes a gam() function, a wide variety of smoothers, 'JAGS' support and distributions beyond the exponential family.", - "Priority": "recommended", - "Depends": [ - "R (>= 3.6.0)", - "nlme (>= 3.1-64)" - ], - "Imports": [ - "methods", - "stats", - "graphics", - "Matrix", - "splines", - "utils" - ], - "Suggests": [ - "parallel", - "survival", - "MASS" - ], - "LazyLoad": "yes", - "ByteCompile": "yes", - "License": "GPL (>= 2)", - "NeedsCompilation": "yes", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "mime": { - "Package": "mime", - "Version": "0.12", - "Source": "Repository", - "Type": "Package", - "Title": "Map Filenames to MIME Types", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Jeffrey\", \"Horner\", role = \"ctb\"), person(\"Beilei\", \"Bian\", role = \"ctb\") )", - "Description": "Guesses the MIME type from a filename extension using the data derived from /etc/mime.types in UNIX-type systems.", - "Imports": [ - "tools" - ], - "License": "GPL", - "URL": "https://github.com/yihui/mime", - "BugReports": "https://github.com/yihui/mime/issues", - "RoxygenNote": "7.1.1", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Yihui Xie [aut, cre] (), Jeffrey Horner [ctb], Beilei Bian [ctb]", - "Maintainer": "Yihui Xie ", - "Repository": "RSPM" - }, - "munsell": { - "Package": "munsell", - "Version": "0.5.1", - "Source": "Repository", - "Type": "Package", - "Title": "Utilities for Using Munsell Colours", - "Author": "Charlotte Wickham ", - "Maintainer": "Charlotte Wickham ", - "Description": "Provides easy access to, and manipulation of, the Munsell colours. Provides a mapping between Munsell's original notation (e.g. \"5R 5/10\") and hexadecimal strings suitable for use directly in R graphics. Also provides utilities to explore slices through the Munsell colour tree, to transform Munsell colours and display colour palettes.", - "Suggests": [ - "ggplot2", - "testthat" - ], - "Imports": [ - "colorspace", - "methods" - ], - "License": "MIT + file LICENSE", - "URL": "https://cran.r-project.org/package=munsell, https://github.com/cwickham/munsell/", - "RoxygenNote": "7.3.1", - "Encoding": "UTF-8", - "BugReports": "https://github.com/cwickham/munsell/issues", - "NeedsCompilation": "no", - "Repository": "RSPM" - }, - "mvtnorm": { - "Package": "mvtnorm", - "Version": "1.3-3", - "Source": "Repository", - "Title": "Multivariate Normal and t Distributions", - "Date": "2025-01-09", - "Authors@R": "c(person(\"Alan\", \"Genz\", role = \"aut\"), person(\"Frank\", \"Bretz\", role = \"aut\"), person(\"Tetsuhisa\", \"Miwa\", role = \"aut\"), person(\"Xuefei\", \"Mi\", role = \"aut\"), person(\"Friedrich\", \"Leisch\", role = \"ctb\"), person(\"Fabian\", \"Scheipl\", role = \"ctb\"), person(\"Bjoern\", \"Bornkamp\", role = \"ctb\", comment = c(ORCID = \"0000-0002-6294-8185\")), person(\"Martin\", \"Maechler\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8685-9910\")), person(\"Torsten\", \"Hothorn\", role = c(\"aut\", \"cre\"), email = \"Torsten.Hothorn@R-project.org\", comment = c(ORCID = \"0000-0001-8301-0471\")))", - "Description": "Computes multivariate normal and t probabilities, quantiles, random deviates, and densities. Log-likelihoods for multivariate Gaussian models and Gaussian copulae parameterised by Cholesky factors of covariance or precision matrices are implemented for interval-censored and exact data, or a mix thereof. Score functions for these log-likelihoods are available. A class representing multiple lower triangular matrices and corresponding methods are part of this package.", - "Imports": [ - "stats" - ], - "Depends": [ - "R(>= 3.5.0)" - ], - "Suggests": [ - "qrng", - "numDeriv" - ], - "License": "GPL-2", - "URL": "http://mvtnorm.R-forge.R-project.org", - "NeedsCompilation": "yes", - "Author": "Alan Genz [aut], Frank Bretz [aut], Tetsuhisa Miwa [aut], Xuefei Mi [aut], Friedrich Leisch [ctb], Fabian Scheipl [ctb], Bjoern Bornkamp [ctb] (), Martin Maechler [ctb] (), Torsten Hothorn [aut, cre] ()", - "Maintainer": "Torsten Hothorn ", - "Repository": "CRAN" - }, - "nlme": { - "Package": "nlme", - "Version": "3.1-167", - "Source": "Repository", - "Date": "2025-01-27", - "Priority": "recommended", - "Title": "Linear and Nonlinear Mixed Effects Models", - "Authors@R": "c(person(\"José\", \"Pinheiro\", role = \"aut\", comment = \"S version\"), person(\"Douglas\", \"Bates\", role = \"aut\", comment = \"up to 2007\"), person(\"Saikat\", \"DebRoy\", role = \"ctb\", comment = \"up to 2002\"), person(\"Deepayan\", \"Sarkar\", role = \"ctb\", comment = \"up to 2005\"), person(\"EISPACK authors\", role = \"ctb\", comment = \"src/rs.f\"), person(\"Siem\", \"Heisterkamp\", role = \"ctb\", comment = \"Author fixed sigma\"), person(\"Bert\", \"Van Willigen\",role = \"ctb\", comment = \"Programmer fixed sigma\"), person(\"Johannes\", \"Ranke\", role = \"ctb\", comment = \"varConstProp()\"), person(\"R Core Team\", email = \"R-core@R-project.org\", role = c(\"aut\", \"cre\"), comment = c(ROR = \"02zz1nj61\")))", - "Contact": "see 'MailingList'", - "Description": "Fit and compare Gaussian linear and nonlinear mixed-effects models.", - "Depends": [ - "R (>= 3.6.0)" - ], - "Imports": [ - "graphics", - "stats", - "utils", - "lattice" - ], - "Suggests": [ - "MASS", - "SASmixed" - ], - "LazyData": "yes", - "Encoding": "UTF-8", - "License": "GPL (>= 2)", - "BugReports": "https://bugs.r-project.org", - "MailingList": "R-help@r-project.org", - "URL": "https://svn.r-project.org/R-packages/trunk/nlme/", - "NeedsCompilation": "yes", - "Author": "José Pinheiro [aut] (S version), Douglas Bates [aut] (up to 2007), Saikat DebRoy [ctb] (up to 2002), Deepayan Sarkar [ctb] (up to 2005), EISPACK authors [ctb] (src/rs.f), Siem Heisterkamp [ctb] (Author fixed sigma), Bert Van Willigen [ctb] (Programmer fixed sigma), Johannes Ranke [ctb] (varConstProp()), R Core Team [aut, cre] (02zz1nj61)", - "Maintainer": "R Core Team ", - "Repository": "CRAN" - }, - "officer": { - "Package": "officer", - "Version": "0.6.7", - "Source": "Repository", - "Type": "Package", - "Title": "Manipulation of Microsoft Word and PowerPoint Documents", - "Authors@R": "c( person(\"David\", \"Gohel\", , \"david.gohel@ardata.fr\", role = c(\"aut\", \"cre\")), person(\"Stefan\", \"Moog\", , \"moogs@gmx.de\", role = \"aut\"), person(\"Mark\", \"Heckmann\", , \"heckmann.mark@gmail.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-0736-7417\")), person(\"ArData\", role = \"cph\"), person(\"Frank\", \"Hangler\", , \"frank@plotandscatter.com\", role = \"ctb\", comment = \"function body_replace_all_text\"), person(\"Liz\", \"Sander\", , \"lsander@civisanalytics.com\", role = \"ctb\", comment = \"several documentation fixes\"), person(\"Anton\", \"Victorson\", , \"anton@victorson.se\", role = \"ctb\", comment = \"fixes xml structures\"), person(\"Jon\", \"Calder\", , \"jonmcalder@gmail.com\", role = \"ctb\", comment = \"update vignettes\"), person(\"John\", \"Harrold\", , \"john.m.harrold@gmail.com\", role = \"ctb\", comment = \"function annotate_base\"), person(\"John\", \"Muschelli\", , \"muschellij2@gmail.com\", role = \"ctb\", comment = \"google doc compatibility\"), person(\"Bill\", \"Denney\", , \"wdenney@humanpredictions.com\", role = \"ctb\", comment = c(ORCID = \"0000-0002-5759-428X\", \"function as.matrix.rpptx\")), person(\"Nikolai\", \"Beck\", , \"beck.nikolai@gmail.com\", role = \"ctb\", comment = \"set speaker notes for .pptx documents\"), person(\"Greg\", \"Leleu\", , \"gregoire.leleu@gmail.com\", role = \"ctb\", comment = \"fields functionality in ppt\"), person(\"Majid\", \"Eismann\", role = \"ctb\"), person(\"Hongyuan\", \"Jia\", , \"hongyuanjia@cqust.edu.cn\", role = \"ctb\", comment = c(ORCID = \"0000-0002-0075-8183\")) )", - "Description": "Access and manipulate 'Microsoft Word', 'RTF' and 'Microsoft PowerPoint' documents from R. The package focuses on tabular and graphical reporting from R; it also provides two functions that let users get document content into data objects. A set of functions lets add and remove images, tables and paragraphs of text in new or existing documents. The package does not require any installation of Microsoft products to be able to write Microsoft files.", - "License": "MIT + file LICENSE", - "URL": "https://ardata-fr.github.io/officeverse/, https://davidgohel.github.io/officer/", - "BugReports": "https://github.com/davidgohel/officer/issues", - "Imports": [ - "cli", - "graphics", - "grDevices", - "openssl", - "R6", - "ragg", - "stats", - "utils", - "uuid", - "xml2 (>= 1.1.0)", - "zip (>= 2.1.0)" - ], - "Suggests": [ - "devEMF", - "doconv (>= 0.3.0)", - "ggplot2", - "knitr", - "magick", - "rmarkdown", - "rsvg", - "testthat" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "David Gohel [aut, cre], Stefan Moog [aut], Mark Heckmann [aut] (), ArData [cph], Frank Hangler [ctb] (function body_replace_all_text), Liz Sander [ctb] (several documentation fixes), Anton Victorson [ctb] (fixes xml structures), Jon Calder [ctb] (update vignettes), John Harrold [ctb] (function annotate_base), John Muschelli [ctb] (google doc compatibility), Bill Denney [ctb] (, function as.matrix.rpptx), Nikolai Beck [ctb] (set speaker notes for .pptx documents), Greg Leleu [ctb] (fields functionality in ppt), Majid Eismann [ctb], Hongyuan Jia [ctb] ()", - "Maintainer": "David Gohel ", - "Repository": "CRAN" - }, - "openssl": { - "Package": "openssl", - "Version": "2.3.2", - "Source": "Repository", - "Type": "Package", - "Title": "Toolkit for Encryption, Signatures and Certificates Based on OpenSSL", - "Authors@R": "c(person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Oliver\", \"Keyes\", role = \"ctb\"))", - "Description": "Bindings to OpenSSL libssl and libcrypto, plus custom SSH key parsers. Supports RSA, DSA and EC curves P-256, P-384, P-521, and curve25519. Cryptographic signatures can either be created and verified manually or via x509 certificates. AES can be used in cbc, ctr or gcm mode for symmetric encryption; RSA for asymmetric (public key) encryption or EC for Diffie Hellman. High-level envelope functions combine RSA and AES for encrypting arbitrary sized data. Other utilities include key generators, hash functions (md5, sha1, sha256, etc), base64 encoder, a secure random number generator, and 'bignum' math methods for manually performing crypto calculations on large multibyte integers.", - "License": "MIT + file LICENSE", - "URL": "https://jeroen.r-universe.dev/openssl", - "BugReports": "https://github.com/jeroen/openssl/issues", - "SystemRequirements": "OpenSSL >= 1.0.2", - "VignetteBuilder": "knitr", - "Imports": [ - "askpass" - ], - "Suggests": [ - "curl", - "testthat (>= 2.1.0)", - "digest", - "knitr", - "rmarkdown", - "jsonlite", - "jose", - "sodium" - ], - "RoxygenNote": "7.3.2", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] (), Oliver Keyes [ctb]", - "Maintainer": "Jeroen Ooms ", - "Repository": "CRAN" - }, - "osprey": { - "Package": "osprey", - "Version": "0.1.16.9018", - "Source": "Repository", - "Type": "Package", - "Title": "R Package to Create TLGs", - "Date": "2025-01-31", - "Authors@R": "c( person(\"Nina\", \"Qi\", , \"qit3@gene.com\", role = c(\"aut\", \"cre\")), person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"aut\"), person(\"Liming\", \"Li\", , \"liming.li@roche.com\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")), person(\"Molly\", \"He\", role = \"ctb\"), person(\"Carolyn\", \"Zhang\", role = \"ctb\"), person(\"Tina\", \"Cho\", role = \"ctb\") )", - "Description": "Community effort to collect TLG code and create a catalogue.", - "License": "Apache License 2.0 | file LICENSE", - "URL": "https://insightsengineering.github.io/osprey/, https://github.com/insightsengineering/osprey/", - "BugReports": "https://github.com/insightsengineering/osprey/issues", - "Depends": [ - "dplyr (>= 0.8.0)", - "ggplot2 (>= 3.5.0)", - "R (>= 3.6)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "cowplot", - "DescTools (>= 0.99.53)", - "grDevices", - "grid", - "gridExtra", - "gtable (>= 0.3.4)", - "methods", - "rlang (>= 1.1.0)", - "stats", - "stringr (>= 1.4.1)", - "tibble (>= 2.0.0)", - "tidyr (>= 1.0.0)" - ], - "Suggests": [ - "knitr (>= 1.42)", - "nestcolor (>= 0.1.0)", - "rmarkdown (>= 2.23)", - "tern (>= 0.7.10)", - "testthat (>= 2.0)" - ], - "Config/Needs/verdepcheck": "tidyverse/dplyr, tidyverse/ggplot2, mllg/checkmate, wilkelab/cowplot, AndriSignorell/DescTools, baptiste/gridExtra, r-lib/gtable, r-lib/rlang, tidyverse/stringr, tidyverse/tibble, tidyverse/tidyr, yihui/knitr, insightsengineering/nestcolor, rstudio/rmarkdown, insightsengineering/tern, r-lib/testthat", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "LazyData": "true", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Config/pak/sysreqs": "make libicu-dev libssl-dev libx11-dev zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/osprey", - "RemoteRef": "HEAD", - "RemoteSha": "eff27e6d997cf23a13d9c3e7d0134d88afebff45", - "NeedsCompilation": "no", - "Author": "Nina Qi [aut, cre], Dawid Kaledkowski [aut], Chendi Liao [aut], Liming Li [aut], F. Hoffmann-La Roche AG [cph, fnd], Molly He [ctb], Carolyn Zhang [ctb], Tina Cho [ctb]", - "Maintainer": "Nina Qi " - }, - "pillar": { - "Package": "pillar", - "Version": "1.10.1", - "Source": "Repository", - "Title": "Coloured Formatting for Columns", - "Authors@R": "c(person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Hadley\", family = \"Wickham\", role = \"aut\"), person(given = \"RStudio\", role = \"cph\"))", - "Description": "Provides 'pillar' and 'colonnade' generics designed for formatting columns of data using the full range of colours provided by modern terminals.", - "License": "MIT + file LICENSE", - "URL": "https://pillar.r-lib.org/, https://github.com/r-lib/pillar", - "BugReports": "https://github.com/r-lib/pillar/issues", - "Imports": [ - "cli (>= 2.3.0)", - "glue", - "lifecycle", - "rlang (>= 1.0.2)", - "utf8 (>= 1.1.0)", - "utils", - "vctrs (>= 0.5.0)" - ], - "Suggests": [ - "bit64", - "DBI", - "debugme", - "DiagrammeR", - "dplyr", - "formattable", - "ggplot2", - "knitr", - "lubridate", - "nanotime", - "nycflights13", - "palmerpenguins", - "rmarkdown", - "scales", - "stringi", - "survival", - "testthat (>= 3.1.1)", - "tibble", - "units (>= 0.7.2)", - "vdiffr", - "withr" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2.9000", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "true", - "Config/testthat/start-first": "format_multi_fuzz, format_multi_fuzz_2, format_multi, ctl_colonnade, ctl_colonnade_1, ctl_colonnade_2", - "Config/autostyle/scope": "line_breaks", - "Config/autostyle/strict": "true", - "Config/gha/extra-packages": "DiagrammeR=?ignore-before-r=3.5.0", - "Config/Needs/website": "tidyverse/tidytemplate", - "NeedsCompilation": "no", - "Author": "Kirill Müller [aut, cre] (), Hadley Wickham [aut], RStudio [cph]", - "Maintainer": "Kirill Müller ", - "Repository": "CRAN" - }, - "pkgbuild": { - "Package": "pkgbuild", - "Version": "1.4.6", - "Source": "Repository", - "Title": "Find Tools Needed to Build R Packages", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides functions used to build R packages. Locates compilers needed to build R packages on various platforms and ensures the PATH is configured appropriately so R can use them.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/pkgbuild, https://pkgbuild.r-lib.org", - "BugReports": "https://github.com/r-lib/pkgbuild/issues", - "Depends": [ - "R (>= 3.5)" - ], - "Imports": [ - "callr (>= 3.2.0)", - "cli (>= 3.4.0)", - "desc", - "processx", - "R6" - ], - "Suggests": [ - "covr", - "cpp11", - "knitr", - "Rcpp", - "rmarkdown", - "testthat (>= 3.2.0)", - "withr (>= 2.3.0)" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut], Jim Hester [aut], Gábor Csárdi [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - }, - "pkgconfig": { - "Package": "pkgconfig", - "Version": "2.0.3", - "Source": "Repository", - "Title": "Private Configuration for 'R' Packages", - "Author": "Gábor Csárdi", - "Maintainer": "Gábor Csárdi ", - "Description": "Set configuration options on a per-package basis. Options set by a given package only apply to that package, other packages are unaffected.", - "License": "MIT + file LICENSE", - "LazyData": "true", - "Imports": [ - "utils" - ], - "Suggests": [ - "covr", - "testthat", - "disposables (>= 1.0.3)" - ], - "URL": "https://github.com/r-lib/pkgconfig#readme", - "BugReports": "https://github.com/r-lib/pkgconfig/issues", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Repository": "RSPM" - }, - "pkgload": { - "Package": "pkgload", - "Version": "1.4.0", - "Source": "Repository", - "Title": "Simulate Package Installation and Attach", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", role = \"aut\"), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"R Core team\", role = \"ctb\", comment = \"Some namespace and vignette code extracted from base R\") )", - "Description": "Simulates the process of installing a package and then attaching it. This is a key part of the 'devtools' package as it allows you to rapidly iterate while developing a package.", - "License": "GPL-3", - "URL": "https://github.com/r-lib/pkgload, https://pkgload.r-lib.org", - "BugReports": "https://github.com/r-lib/pkgload/issues", - "Depends": [ - "R (>= 3.4.0)" - ], - "Imports": [ - "cli (>= 3.3.0)", - "desc", - "fs", - "glue", - "lifecycle", - "methods", - "pkgbuild", - "processx", - "rlang (>= 1.1.1)", - "rprojroot", - "utils", - "withr (>= 2.4.3)" - ], - "Suggests": [ - "bitops", - "jsonlite", - "mathjaxr", - "pak", - "Rcpp", - "remotes", - "rstudioapi", - "testthat (>= 3.2.1.1)", - "usethis" - ], - "Config/Needs/website": "tidyverse/tidytemplate, ggplot2", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "TRUE", - "Config/testthat/start-first": "dll", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut], Winston Chang [aut], Jim Hester [aut], Lionel Henry [aut, cre], Posit Software, PBC [cph, fnd], R Core team [ctb] (Some namespace and vignette code extracted from base R)", - "Maintainer": "Lionel Henry ", - "Repository": "RSPM" - }, - "plotly": { - "Package": "plotly", - "Version": "4.10.4", - "Source": "Repository", - "Title": "Create Interactive Web Graphics via 'plotly.js'", - "Authors@R": "c(person(\"Carson\", \"Sievert\", role = c(\"aut\", \"cre\"), email = \"cpsievert1@gmail.com\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Chris\", \"Parmer\", role = \"aut\", email = \"chris@plot.ly\"), person(\"Toby\", \"Hocking\", role = \"aut\", email = \"tdhock5@gmail.com\"), person(\"Scott\", \"Chamberlain\", role = \"aut\", email = \"myrmecocystus@gmail.com\"), person(\"Karthik\", \"Ram\", role = \"aut\", email = \"karthik.ram@gmail.com\"), person(\"Marianne\", \"Corvellec\", role = \"aut\", email = \"marianne.corvellec@igdore.org\", comment = c(ORCID = \"0000-0002-1994-3581\")), person(\"Pedro\", \"Despouy\", role = \"aut\", email = \"pedro@plot.ly\"), person(\"Salim\", \"Brüggemann\", role = \"ctb\", email = \"salim-b@pm.me\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Plotly Technologies Inc.\", role = \"cph\"))", - "License": "MIT + file LICENSE", - "Description": "Create interactive web graphics from 'ggplot2' graphs and/or a custom interface to the (MIT-licensed) JavaScript library 'plotly.js' inspired by the grammar of graphics.", - "URL": "https://plotly-r.com, https://github.com/plotly/plotly.R, https://plotly.com/r/", - "BugReports": "https://github.com/plotly/plotly.R/issues", - "Depends": [ - "R (>= 3.2.0)", - "ggplot2 (>= 3.0.0)" - ], - "Imports": [ - "tools", - "scales", - "httr (>= 1.3.0)", - "jsonlite (>= 1.6)", - "magrittr", - "digest", - "viridisLite", - "base64enc", - "htmltools (>= 0.3.6)", - "htmlwidgets (>= 1.5.2.9001)", - "tidyr (>= 1.0.0)", - "RColorBrewer", - "dplyr", - "vctrs", - "tibble", - "lazyeval (>= 0.2.0)", - "rlang (>= 0.4.10)", - "crosstalk", - "purrr", - "data.table", - "promises" - ], - "Suggests": [ - "MASS", - "maps", - "hexbin", - "ggthemes", - "GGally", - "ggalluvial", - "testthat", - "knitr", - "shiny (>= 1.1.0)", - "shinytest (>= 1.3.0)", - "curl", - "rmarkdown", - "Cairo", - "broom", - "webshot", - "listviewer", - "dendextend", - "sf", - "png", - "IRdisplay", - "processx", - "plotlyGeoAssets", - "forcats", - "withr", - "palmerpenguins", - "rversions", - "reticulate", - "rsvg" - ], - "LazyData": "true", - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "Config/Needs/check": "tidyverse/ggplot2, rcmdcheck, devtools, reshape2", - "NeedsCompilation": "no", - "Author": "Carson Sievert [aut, cre] (), Chris Parmer [aut], Toby Hocking [aut], Scott Chamberlain [aut], Karthik Ram [aut], Marianne Corvellec [aut] (), Pedro Despouy [aut], Salim Brüggemann [ctb] (), Plotly Technologies Inc. [cph]", - "Maintainer": "Carson Sievert ", - "Repository": "CRAN" - }, - "prettyunits": { - "Package": "prettyunits", - "Version": "1.2.0", - "Source": "Repository", - "Title": "Pretty, Human Readable Formatting of Quantities", - "Authors@R": "c( person(\"Gabor\", \"Csardi\", email=\"csardi.gabor@gmail.com\", role=c(\"aut\", \"cre\")), person(\"Bill\", \"Denney\", email=\"wdenney@humanpredictions.com\", role=c(\"ctb\"), comment=c(ORCID=\"0000-0002-5759-428X\")), person(\"Christophe\", \"Regouby\", email=\"christophe.regouby@free.fr\", role=c(\"ctb\")) )", - "Description": "Pretty, human readable formatting of quantities. Time intervals: '1337000' -> '15d 11h 23m 20s'. Vague time intervals: '2674000' -> 'about a month ago'. Bytes: '1337' -> '1.34 kB'. Rounding: '99' with 3 significant digits -> '99.0' p-values: '0.00001' -> '<0.0001'. Colors: '#FF0000' -> 'red'. Quantities: '1239437' -> '1.24 M'.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/prettyunits", - "BugReports": "https://github.com/r-lib/prettyunits/issues", - "Depends": [ - "R(>= 2.10)" - ], - "Suggests": [ - "codetools", - "covr", - "testthat" - ], - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Gabor Csardi [aut, cre], Bill Denney [ctb] (), Christophe Regouby [ctb]", - "Maintainer": "Gabor Csardi ", - "Repository": "RSPM" - }, - "processx": { - "Package": "processx", - "Version": "3.8.5", - "Source": "Repository", - "Title": "Execute and Control System Processes", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\", \"cph\"), comment = c(ORCID = \"0000-0001-7098-9676\")), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Ascent Digital Services\", role = c(\"cph\", \"fnd\")) )", - "Description": "Tools to run system processes in the background. It can check if a background process is running; wait on a background process to finish; get the exit status of finished processes; kill background processes. It can read the standard output and error of the processes, using non-blocking connections. 'processx' can poll a process for standard output or error, with a timeout. It can also poll several processes at once.", - "License": "MIT + file LICENSE", - "URL": "https://processx.r-lib.org, https://github.com/r-lib/processx", - "BugReports": "https://github.com/r-lib/processx/issues", - "Depends": [ - "R (>= 3.4.0)" - ], - "Imports": [ - "ps (>= 1.2.0)", - "R6", - "utils" - ], - "Suggests": [ - "callr (>= 3.7.3)", - "cli (>= 3.3.0)", - "codetools", - "covr", - "curl", - "debugme", - "parallel", - "rlang (>= 1.0.2)", - "testthat (>= 3.0.0)", - "webfakes", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1.9000", - "NeedsCompilation": "yes", - "Author": "Gábor Csárdi [aut, cre, cph] (), Winston Chang [aut], Posit Software, PBC [cph, fnd], Ascent Digital Services [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - }, - "progress": { - "Package": "progress", - "Version": "1.2.3", - "Source": "Repository", - "Title": "Terminal Progress Bars", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Rich\", \"FitzJohn\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Configurable Progress bars, they may include percentage, elapsed time, and/or the estimated completion time. They work in terminals, in 'Emacs' 'ESS', 'RStudio', 'Windows' 'Rgui' and the 'macOS' 'R.app'. The package also provides a 'C++' 'API', that works with or without 'Rcpp'.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/progress#readme, http://r-lib.github.io/progress/", - "BugReports": "https://github.com/r-lib/progress/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "crayon", - "hms", - "prettyunits", - "R6" - ], - "Suggests": [ - "Rcpp", - "testthat (>= 3.0.0)", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Gábor Csárdi [aut, cre], Rich FitzJohn [aut], Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "RSPM" - }, - "promises": { - "Package": "promises", - "Version": "1.3.2", - "Source": "Repository", - "Type": "Package", - "Title": "Abstractions for Promise-Based Asynchronous Programming", - "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides fundamental abstractions for doing asynchronous programming in R using promises. Asynchronous programming is useful for allowing a single R process to orchestrate multiple tasks in the background while also attending to something else. Semantics are similar to 'JavaScript' promises, but with a syntax that is idiomatic R.", - "License": "MIT + file LICENSE", - "URL": "https://rstudio.github.io/promises/, https://github.com/rstudio/promises", - "BugReports": "https://github.com/rstudio/promises/issues", - "Imports": [ - "fastmap (>= 1.1.0)", - "later", - "magrittr (>= 1.5)", - "R6", - "Rcpp", - "rlang", - "stats" - ], - "Suggests": [ - "future (>= 1.21.0)", - "knitr", - "purrr", - "rmarkdown", - "spelling", - "testthat", - "vembedr" - ], - "LinkingTo": [ - "later", - "Rcpp" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "rsconnect", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Joe Cheng [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Joe Cheng ", - "Repository": "CRAN" - }, - "proxy": { - "Package": "proxy", - "Version": "0.4-27", - "Source": "Repository", - "Type": "Package", - "Title": "Distance and Similarity Measures", - "Authors@R": "c(person(given = \"David\", family = \"Meyer\", role = c(\"aut\", \"cre\"), email = \"David.Meyer@R-project.org\"), person(given = \"Christian\", family = \"Buchta\", role = \"aut\"))", - "Description": "Provides an extensible framework for the efficient calculation of auto- and cross-proximities, along with implementations of the most popular ones.", - "Depends": [ - "R (>= 3.4.0)" - ], - "Imports": [ - "stats", - "utils" - ], - "Suggests": [ - "cba" - ], - "Collate": "registry.R database.R dist.R similarities.R dissimilarities.R util.R seal.R", - "License": "GPL-2", - "NeedsCompilation": "yes", - "Author": "David Meyer [aut, cre], Christian Buchta [aut]", - "Maintainer": "David Meyer ", - "Repository": "CRAN" - }, - "ps": { - "Package": "ps", - "Version": "1.8.1", - "Source": "Repository", - "Title": "List, Query, Manipulate System Processes", - "Authors@R": "c( person(\"Jay\", \"Loden\", role = \"aut\"), person(\"Dave\", \"Daeschler\", role = \"aut\"), person(\"Giampaolo\", \"Rodola'\", role = \"aut\"), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "List, query and manipulate all system processes, on 'Windows', 'Linux' and 'macOS'.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/ps, https://ps.r-lib.org/", - "BugReports": "https://github.com/r-lib/ps/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "utils" - ], - "Suggests": [ - "callr", - "covr", - "curl", - "pillar", - "pingr", - "processx (>= 3.1.0)", - "R6", - "rlang", - "testthat (>= 3.0.0)", - "webfakes", - "withr" - ], - "Biarch": "true", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Jay Loden [aut], Dave Daeschler [aut], Giampaolo Rodola' [aut], Gábor Csárdi [aut, cre], Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - }, - "purrr": { - "Package": "purrr", - "Version": "1.0.4", - "Source": "Repository", - "Title": "Functional Programming Tools", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\"), comment = c(ROR = \"03wc8by49\")) )", - "Description": "A complete and consistent functional programming toolkit for R.", - "License": "MIT + file LICENSE", - "URL": "https://purrr.tidyverse.org/, https://github.com/tidyverse/purrr", - "BugReports": "https://github.com/tidyverse/purrr/issues", - "Depends": [ - "R (>= 4.0)" - ], - "Imports": [ - "cli (>= 3.6.1)", - "lifecycle (>= 1.0.3)", - "magrittr (>= 1.5.0)", - "rlang (>= 1.1.1)", - "vctrs (>= 0.6.3)" - ], - "Suggests": [ - "covr", - "dplyr (>= 0.7.8)", - "httr", - "knitr", - "lubridate", - "rmarkdown", - "testthat (>= 3.0.0)", - "tibble", - "tidyselect" - ], - "LinkingTo": [ - "cli" - ], - "VignetteBuilder": "knitr", - "Biarch": "true", - "Config/build/compilation-database": "true", - "Config/Needs/website": "tidyverse/tidytemplate, tidyr", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "TRUE", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre] (), Lionel Henry [aut], Posit Software, PBC [cph, fnd] (03wc8by49)", - "Maintainer": "Hadley Wickham ", - "Repository": "CRAN" - }, - "ragg": { - "Package": "ragg", - "Version": "1.3.3", - "Source": "Repository", - "Type": "Package", - "Title": "Graphic Devices Based on AGG", - "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Maxim\", \"Shemanarev\", role = c(\"aut\", \"cph\"), comment = \"Author of AGG\"), person(\"Tony\", \"Juricic\", , \"tonygeek@yahoo.com\", role = c(\"ctb\", \"cph\"), comment = \"Contributor to AGG\"), person(\"Milan\", \"Marusinec\", , \"milan@marusinec.sk\", role = c(\"ctb\", \"cph\"), comment = \"Contributor to AGG\"), person(\"Spencer\", \"Garrett\", role = \"ctb\", comment = \"Contributor to AGG\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Maintainer": "Thomas Lin Pedersen ", - "Description": "Anti-Grain Geometry (AGG) is a high-quality and high-performance 2D drawing library. The 'ragg' package provides a set of graphic devices based on AGG to use as alternative to the raster devices provided through the 'grDevices' package.", - "License": "MIT + file LICENSE", - "URL": "https://ragg.r-lib.org, https://github.com/r-lib/ragg", - "BugReports": "https://github.com/r-lib/ragg/issues", - "Imports": [ - "systemfonts (>= 1.0.3)", - "textshaping (>= 0.3.0)" - ], - "Suggests": [ - "covr", - "graphics", - "grid", - "testthat (>= 3.0.0)" - ], - "LinkingTo": [ - "systemfonts", - "textshaping" - ], - "Config/Needs/website": "ggplot2, devoid, magick, bench, tidyr, ggridges, hexbin, sessioninfo, pkgdown, tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "SystemRequirements": "freetype2, libpng, libtiff, libjpeg", - "Config/testthat/edition": "3", - "NeedsCompilation": "yes", - "Author": "Thomas Lin Pedersen [cre, aut] (), Maxim Shemanarev [aut, cph] (Author of AGG), Tony Juricic [ctb, cph] (Contributor to AGG), Milan Marusinec [ctb, cph] (Contributor to AGG), Spencer Garrett [ctb] (Contributor to AGG), Posit, PBC [cph, fnd]", - "Repository": "RSPM" - }, - "rappdirs": { - "Package": "rappdirs", - "Version": "0.3.3", - "Source": "Repository", - "Type": "Package", - "Title": "Application Directories: Determine Where to Save Data, Caches, and Logs", - "Authors@R": "c(person(given = \"Hadley\", family = \"Wickham\", role = c(\"trl\", \"cre\", \"cph\"), email = \"hadley@rstudio.com\"), person(given = \"RStudio\", role = \"cph\"), person(given = \"Sridhar\", family = \"Ratnakumar\", role = \"aut\"), person(given = \"Trent\", family = \"Mick\", role = \"aut\"), person(given = \"ActiveState\", role = \"cph\", comment = \"R/appdir.r, R/cache.r, R/data.r, R/log.r translated from appdirs\"), person(given = \"Eddy\", family = \"Petrisor\", role = \"ctb\"), person(given = \"Trevor\", family = \"Davis\", role = c(\"trl\", \"aut\")), person(given = \"Gabor\", family = \"Csardi\", role = \"ctb\"), person(given = \"Gregory\", family = \"Jefferis\", role = \"ctb\"))", - "Description": "An easy way to determine which directories on the users computer you should use to save data, caches and logs. A port of Python's 'Appdirs' () to R.", - "License": "MIT + file LICENSE", - "URL": "https://rappdirs.r-lib.org, https://github.com/r-lib/rappdirs", - "BugReports": "https://github.com/r-lib/rappdirs/issues", - "Depends": [ - "R (>= 3.2)" - ], - "Suggests": [ - "roxygen2", - "testthat (>= 3.0.0)", - "covr", - "withr" - ], - "Copyright": "Original python appdirs module copyright (c) 2010 ActiveState Software Inc. R port copyright Hadley Wickham, RStudio. See file LICENSE for details.", - "Encoding": "UTF-8", - "RoxygenNote": "7.1.1", - "Config/testthat/edition": "3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [trl, cre, cph], RStudio [cph], Sridhar Ratnakumar [aut], Trent Mick [aut], ActiveState [cph] (R/appdir.r, R/cache.r, R/data.r, R/log.r translated from appdirs), Eddy Petrisor [ctb], Trevor Davis [trl, aut], Gabor Csardi [ctb], Gregory Jefferis [ctb]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "reactR": { - "Package": "reactR", - "Version": "0.6.1", - "Source": "Repository", - "Type": "Package", - "Title": "React Helpers", - "Date": "2024-09-14", - "Authors@R": "c( person( \"Facebook\", \"Inc\" , role = c(\"aut\", \"cph\") , comment = \"React library in lib, https://reactjs.org/; see AUTHORS for full list of contributors\" ), person( \"Michel\",\"Weststrate\", , role = c(\"aut\", \"cph\") , comment = \"mobx library in lib, https://github.com/mobxjs\" ), person( \"Kent\", \"Russell\" , role = c(\"aut\", \"cre\") , comment = \"R interface\" , email = \"kent.russell@timelyportfolio.com\" ), person( \"Alan\", \"Dipert\" , role = c(\"aut\") , comment = \"R interface\" , email = \"alan@rstudio.com\" ), person( \"Greg\", \"Lin\" , role = c(\"aut\") , comment = \"R interface\" , email = \"glin@glin.io\" ) )", - "Maintainer": "Kent Russell ", - "Description": "Make it easy to use 'React' in R with 'htmlwidget' scaffolds, helper dependency functions, an embedded 'Babel' 'transpiler', and examples.", - "URL": "https://github.com/react-R/reactR", - "BugReports": "https://github.com/react-R/reactR/issues", - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "Imports": [ - "htmltools" - ], - "Suggests": [ - "htmlwidgets (>= 1.5.3)", - "rmarkdown", - "shiny", - "V8", - "knitr", - "usethis", - "jsonlite" - ], - "RoxygenNote": "7.3.2", - "VignetteBuilder": "knitr", - "NeedsCompilation": "no", - "Author": "Facebook Inc [aut, cph] (React library in lib, https://reactjs.org/; see AUTHORS for full list of contributors), Michel Weststrate [aut, cph] (mobx library in lib, https://github.com/mobxjs), Kent Russell [aut, cre] (R interface), Alan Dipert [aut] (R interface), Greg Lin [aut] (R interface)", - "Repository": "RSPM" - }, - "reactable": { - "Package": "reactable", - "Version": "0.4.4", - "Source": "Repository", - "Type": "Package", - "Title": "Interactive Data Tables for R", - "Authors@R": "c( person(\"Greg\", \"Lin\", email = \"glin@glin.io\", role = c(\"aut\", \"cre\")), person(\"Tanner\", \"Linsley\", role = c(\"ctb\", \"cph\"), comment = \"React Table library\"), person(family = \"Emotion team and other contributors\", role = c(\"ctb\", \"cph\"), comment = \"Emotion library\"), person(\"Kent\", \"Russell\", role = c(\"ctb\", \"cph\"), comment = \"reactR package\"), person(\"Ramnath\", \"Vaidyanathan\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Joe\", \"Cheng\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"JJ\", \"Allaire\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Yihui\", \"Xie\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(\"Kenton\", \"Russell\", role = c(\"ctb\", \"cph\"), comment = \"htmlwidgets package\"), person(family = \"Facebook, Inc. and its affiliates\", role = c(\"ctb\", \"cph\"), comment = \"React library\"), person(family = \"FormatJS\", role = c(\"ctb\", \"cph\"), comment = \"FormatJS libraries\"), person(family = \"Feross Aboukhadijeh, and other contributors\", role = c(\"ctb\", \"cph\"), comment = \"buffer library\"), person(\"Roman\", \"Shtylman\", role = c(\"ctb\", \"cph\"), comment = \"process library\"), person(\"James\", \"Halliday\", role = c(\"ctb\", \"cph\"), comment = \"stream-browserify library\"), person(family = \"Posit Software, PBC\", role = c(\"fnd\", \"cph\")) )", - "Description": "Interactive data tables for R, based on the 'React Table' JavaScript library. Provides an HTML widget that can be used in 'R Markdown' or 'Quarto' documents, 'Shiny' applications, or viewed from an R console.", - "License": "MIT + file LICENSE", - "URL": "https://glin.github.io/reactable/, https://github.com/glin/reactable", - "BugReports": "https://github.com/glin/reactable/issues", - "Depends": [ - "R (>= 3.1)" - ], - "Imports": [ - "digest", - "htmltools (>= 0.5.2)", - "htmlwidgets (>= 1.5.3)", - "jsonlite", - "reactR" - ], - "Suggests": [ - "covr", - "crosstalk", - "dplyr", - "fontawesome", - "knitr", - "leaflet", - "MASS", - "rmarkdown", - "shiny", - "sparkline", - "testthat", - "tippy", - "V8" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.2.1", - "Config/testthat/edition": "3", - "NeedsCompilation": "no", - "Author": "Greg Lin [aut, cre], Tanner Linsley [ctb, cph] (React Table library), Emotion team and other contributors [ctb, cph] (Emotion library), Kent Russell [ctb, cph] (reactR package), Ramnath Vaidyanathan [ctb, cph] (htmlwidgets package), Joe Cheng [ctb, cph] (htmlwidgets package), JJ Allaire [ctb, cph] (htmlwidgets package), Yihui Xie [ctb, cph] (htmlwidgets package), Kenton Russell [ctb, cph] (htmlwidgets package), Facebook, Inc. and its affiliates [ctb, cph] (React library), FormatJS [ctb, cph] (FormatJS libraries), Feross Aboukhadijeh, and other contributors [ctb, cph] (buffer library), Roman Shtylman [ctb, cph] (process library), James Halliday [ctb, cph] (stream-browserify library), Posit Software, PBC [fnd, cph]", - "Maintainer": "Greg Lin ", - "Repository": "RSPM" - }, - "readr": { - "Package": "readr", - "Version": "2.1.5", - "Source": "Repository", - "Title": "Read Rectangular Text Data", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Romain\", \"Francois\", role = \"ctb\"), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Shelby\", \"Bearrows\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"https://github.com/mandreyel/\", role = \"cph\", comment = \"mio library\"), person(\"Jukka\", \"Jylänki\", role = c(\"ctb\", \"cph\"), comment = \"grisu3 implementation\"), person(\"Mikkel\", \"Jørgensen\", role = c(\"ctb\", \"cph\"), comment = \"grisu3 implementation\") )", - "Description": "The goal of 'readr' is to provide a fast and friendly way to read rectangular data (like 'csv', 'tsv', and 'fwf'). It is designed to flexibly parse many types of data found in the wild, while still cleanly failing when data unexpectedly changes.", - "License": "MIT + file LICENSE", - "URL": "https://readr.tidyverse.org, https://github.com/tidyverse/readr", - "BugReports": "https://github.com/tidyverse/readr/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli (>= 3.2.0)", - "clipr", - "crayon", - "hms (>= 0.4.1)", - "lifecycle (>= 0.2.0)", - "methods", - "R6", - "rlang", - "tibble", - "utils", - "vroom (>= 1.6.0)" - ], - "Suggests": [ - "covr", - "curl", - "datasets", - "knitr", - "rmarkdown", - "spelling", - "stringi", - "testthat (>= 3.2.0)", - "tzdb (>= 0.1.1)", - "waldo", - "withr", - "xml2" - ], - "LinkingTo": [ - "cpp11", - "tzdb (>= 0.1.1)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "false", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut], Jim Hester [aut], Romain Francois [ctb], Jennifer Bryan [aut, cre] (), Shelby Bearrows [ctb], Posit Software, PBC [cph, fnd], https://github.com/mandreyel/ [cph] (mio library), Jukka Jylänki [ctb, cph] (grisu3 implementation), Mikkel Jørgensen [ctb, cph] (grisu3 implementation)", - "Maintainer": "Jennifer Bryan ", - "Repository": "RSPM" - }, - "readxl": { - "Package": "readxl", - "Version": "1.4.3", - "Source": "Repository", - "Title": "Read Excel Files", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\"), comment = \"Copyright holder of all R code and all C/C++ code without explicit copyright attribution\"), person(\"Marcin\", \"Kalicinski\", role = c(\"ctb\", \"cph\"), comment = \"Author of included RapidXML code\"), person(\"Komarov Valery\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Christophe Leitienne\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Bob Colbert\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"David Hoerl\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\"), person(\"Evan Miller\", role = c(\"ctb\", \"cph\"), comment = \"Author of included libxls code\") )", - "Description": "Import excel files into R. Supports '.xls' via the embedded 'libxls' C library and '.xlsx' via the embedded 'RapidXML' C++ library . Works on Windows, Mac and Linux without external dependencies.", - "License": "MIT + file LICENSE", - "URL": "https://readxl.tidyverse.org, https://github.com/tidyverse/readxl", - "BugReports": "https://github.com/tidyverse/readxl/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cellranger", - "tibble (>= 2.0.1)", - "utils" - ], - "Suggests": [ - "covr", - "knitr", - "rmarkdown", - "testthat (>= 3.1.6)", - "withr" - ], - "LinkingTo": [ - "cpp11 (>= 0.4.0)", - "progress" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate, tidyverse", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Note": "libxls v1.6.2 (patched) 45abe77", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut] (), Jennifer Bryan [aut, cre] (), Posit, PBC [cph, fnd] (Copyright holder of all R code and all C/C++ code without explicit copyright attribution), Marcin Kalicinski [ctb, cph] (Author of included RapidXML code), Komarov Valery [ctb, cph] (Author of included libxls code), Christophe Leitienne [ctb, cph] (Author of included libxls code), Bob Colbert [ctb, cph] (Author of included libxls code), David Hoerl [ctb, cph] (Author of included libxls code), Evan Miller [ctb, cph] (Author of included libxls code)", - "Maintainer": "Jennifer Bryan ", - "Repository": "RSPM" - }, - "rematch": { - "Package": "rematch", - "Version": "2.0.0", - "Source": "Repository", - "Title": "Match Regular Expressions with a Nicer 'API'", - "Author": "Gabor Csardi", - "Maintainer": "Gabor Csardi ", - "Description": "A small wrapper on 'regexpr' to extract the matches and captured groups from the match of a regular expression to a character vector.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/gaborcsardi/rematch", - "BugReports": "https://github.com/gaborcsardi/rematch/issues", - "RoxygenNote": "5.0.1.9000", - "Suggests": [ - "covr", - "testthat" - ], - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Repository": "RSPM" - }, - "renv": { - "Package": "renv", - "Version": "1.1.1", - "Source": "Repository", - "Type": "Package", - "Title": "Project Environments", - "Authors@R": "c( person(\"Kevin\", \"Ushey\", role = c(\"aut\", \"cre\"), email = \"kevin@rstudio.com\", comment = c(ORCID = \"0000-0003-2880-7407\")), person(\"Hadley\", \"Wickham\", role = c(\"aut\"), email = \"hadley@rstudio.com\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A dependency management toolkit for R. Using 'renv', you can create and manage project-local R libraries, save the state of these libraries to a 'lockfile', and later restore your library as required. Together, these tools can help make your projects more isolated, portable, and reproducible.", - "License": "MIT + file LICENSE", - "URL": "https://rstudio.github.io/renv/, https://github.com/rstudio/renv", - "BugReports": "https://github.com/rstudio/renv/issues", - "Imports": [ - "utils" - ], - "Suggests": [ - "BiocManager", - "cli", - "compiler", - "covr", - "cpp11", - "devtools", - "gitcreds", - "jsonlite", - "jsonvalidate", - "knitr", - "miniUI", - "modules", - "packrat", - "pak", - "R6", - "remotes", - "reticulate", - "rmarkdown", - "rstudioapi", - "shiny", - "testthat", - "uuid", - "waldo", - "yaml", - "webfakes" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "true", - "Config/testthat/start-first": "bioconductor,python,install,restore,snapshot,retrieve,remotes", - "NeedsCompilation": "no", - "Author": "Kevin Ushey [aut, cre] (), Hadley Wickham [aut] (), Posit Software, PBC [cph, fnd]", - "Maintainer": "Kevin Ushey ", - "Repository": "CRAN" - }, - "rlang": { - "Package": "rlang", - "Version": "1.1.5", - "Source": "Repository", - "Title": "Functions for Base Types and Core R and 'Tidyverse' Features", - "Description": "A toolbox for working with base types, core R features like the condition system, and core 'Tidyverse' features like tidy evaluation.", - "Authors@R": "c( person(\"Lionel\", \"Henry\", ,\"lionel@posit.co\", c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", ,\"hadley@posit.co\", \"aut\"), person(given = \"mikefc\", email = \"mikefc@coolbutuseless.com\", role = \"cph\", comment = \"Hash implementation based on Mike's xxhashlite\"), person(given = \"Yann\", family = \"Collet\", role = \"cph\", comment = \"Author of the embedded xxHash library\"), person(given = \"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "License": "MIT + file LICENSE", - "ByteCompile": "true", - "Biarch": "true", - "Depends": [ - "R (>= 3.5.0)" - ], - "Imports": [ - "utils" - ], - "Suggests": [ - "cli (>= 3.1.0)", - "covr", - "crayon", - "fs", - "glue", - "knitr", - "magrittr", - "methods", - "pillar", - "rmarkdown", - "stats", - "testthat (>= 3.0.0)", - "tibble", - "usethis", - "vctrs (>= 0.2.3)", - "withr" - ], - "Enhances": [ - "winch" - ], - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "URL": "https://rlang.r-lib.org, https://github.com/r-lib/rlang", - "BugReports": "https://github.com/r-lib/rlang/issues", - "Config/testthat/edition": "3", - "Config/Needs/website": "dplyr, tidyverse/tidytemplate", - "NeedsCompilation": "yes", - "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut], mikefc [cph] (Hash implementation based on Mike's xxhashlite), Yann Collet [cph] (Author of the embedded xxHash library), Posit, PBC [cph, fnd]", - "Maintainer": "Lionel Henry ", - "Repository": "CRAN" - }, - "rlistings": { - "Package": "rlistings", - "Version": "0.2.10.9002", - "Source": "Repository", - "Title": "Clinical Trial Style Data Readout Listings", - "Date": "2025-02-06", - "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Listings are often part of the submission of clinical trial data in regulatory settings. We provide a framework for the specific formatting features often used when displaying large datasets in that context.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/rlistings/, https://github.com/insightsengineering/rlistings/", - "BugReports": "https://github.com/insightsengineering/rlistings/issues", - "Depends": [ - "formatters (>= 0.5.10)", - "methods", - "tibble (>= 2.0.0)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "grDevices", - "grid", - "stats", - "utils" - ], - "Suggests": [ - "dplyr (>= 1.0.2)", - "knitr (>= 1.42)", - "lifecycle (>= 0.2.0)", - "rmarkdown (>= 2.23)", - "stringi (>= 1.6)", - "testthat (>= 3.1.5)", - "withr (>= 2.0.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/Needs/verdepcheck": "insightsengineering/formatters, tidyverse/tibble, mllg/checkmate, tidyverse/dplyr, yihui/knitr, r-lib/lifecycle, rstudio/rmarkdown, gagolews/stringi, r-lib/testthat, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Gabriel Becker [aut] (original creator of the package), Adrian Waddell [aut], Joe Zhu [aut, cre] (), Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Joe Zhu ", - "Repository": "RSPM" - }, - "rmarkdown": { - "Package": "rmarkdown", - "Version": "2.29", - "Source": "Repository", - "Type": "Package", - "Title": "Dynamic Documents for R", - "Authors@R": "c( person(\"JJ\", \"Allaire\", , \"jj@posit.co\", role = \"aut\"), person(\"Yihui\", \"Xie\", , \"xie@yihui.name\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Christophe\", \"Dervieux\", , \"cderv@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Jonathan\", \"McPherson\", , \"jonathan@posit.co\", role = \"aut\"), person(\"Javier\", \"Luraschi\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevin@posit.co\", role = \"aut\"), person(\"Aron\", \"Atkins\", , \"aron@posit.co\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Joe\", \"Cheng\", , \"joe@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", , \"winston@posit.co\", role = \"aut\"), person(\"Richard\", \"Iannone\", , \"rich@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Andrew\", \"Dunning\", role = \"ctb\", comment = c(ORCID = \"0000-0003-0464-5036\")), person(\"Atsushi\", \"Yasumoto\", role = c(\"ctb\", \"cph\"), comment = c(ORCID = \"0000-0002-8335-495X\", cph = \"Number sections Lua filter\")), person(\"Barret\", \"Schloerke\", role = \"ctb\"), person(\"Carson\", \"Sievert\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Devon\", \"Ryan\", , \"dpryan79@gmail.com\", role = \"ctb\", comment = c(ORCID = \"0000-0002-8549-0971\")), person(\"Frederik\", \"Aust\", , \"frederik.aust@uni-koeln.de\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4900-788X\")), person(\"Jeff\", \"Allen\", , \"jeff@posit.co\", role = \"ctb\"), person(\"JooYoung\", \"Seo\", role = \"ctb\", comment = c(ORCID = \"0000-0002-4064-6012\")), person(\"Malcolm\", \"Barrett\", role = \"ctb\"), person(\"Rob\", \"Hyndman\", , \"Rob.Hyndman@monash.edu\", role = \"ctb\"), person(\"Romain\", \"Lesur\", role = \"ctb\"), person(\"Roy\", \"Storey\", role = \"ctb\"), person(\"Ruben\", \"Arslan\", , \"ruben.arslan@uni-goettingen.de\", role = \"ctb\"), person(\"Sergio\", \"Oller\", role = \"ctb\"), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(, \"jQuery UI contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery UI library; authors listed in inst/rmd/h/jqueryui/AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(, \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Alexander\", \"Farkas\", role = c(\"ctb\", \"cph\"), comment = \"html5shiv library\"), person(\"Scott\", \"Jehl\", role = c(\"ctb\", \"cph\"), comment = \"Respond.js library\"), person(\"Ivan\", \"Sagalaev\", role = c(\"ctb\", \"cph\"), comment = \"highlight.js library\"), person(\"Greg\", \"Franko\", role = c(\"ctb\", \"cph\"), comment = \"tocify library\"), person(\"John\", \"MacFarlane\", role = c(\"ctb\", \"cph\"), comment = \"Pandoc templates\"), person(, \"Google, Inc.\", role = c(\"ctb\", \"cph\"), comment = \"ioslides library\"), person(\"Dave\", \"Raggett\", role = \"ctb\", comment = \"slidy library\"), person(, \"W3C\", role = \"cph\", comment = \"slidy library\"), person(\"Dave\", \"Gandy\", role = c(\"ctb\", \"cph\"), comment = \"Font-Awesome\"), person(\"Ben\", \"Sperry\", role = \"ctb\", comment = \"Ionicons\"), person(, \"Drifty\", role = \"cph\", comment = \"Ionicons\"), person(\"Aidan\", \"Lister\", role = c(\"ctb\", \"cph\"), comment = \"jQuery StickyTabs\"), person(\"Benct Philip\", \"Jonsson\", role = c(\"ctb\", \"cph\"), comment = \"pagebreak Lua filter\"), person(\"Albert\", \"Krewinkel\", role = c(\"ctb\", \"cph\"), comment = \"pagebreak Lua filter\") )", - "Description": "Convert R Markdown documents into a variety of formats.", - "License": "GPL-3", - "URL": "https://github.com/rstudio/rmarkdown, https://pkgs.rstudio.com/rmarkdown/", - "BugReports": "https://github.com/rstudio/rmarkdown/issues", - "Depends": [ - "R (>= 3.0)" - ], - "Imports": [ - "bslib (>= 0.2.5.1)", - "evaluate (>= 0.13)", - "fontawesome (>= 0.5.0)", - "htmltools (>= 0.5.1)", - "jquerylib", - "jsonlite", - "knitr (>= 1.43)", - "methods", - "tinytex (>= 0.31)", - "tools", - "utils", - "xfun (>= 0.36)", - "yaml (>= 2.1.19)" - ], - "Suggests": [ - "digest", - "dygraphs", - "fs", - "rsconnect", - "downlit (>= 0.4.0)", - "katex (>= 1.4.0)", - "sass (>= 0.4.0)", - "shiny (>= 1.6.0)", - "testthat (>= 3.0.3)", - "tibble", - "vctrs", - "cleanrmd", - "withr (>= 2.4.2)", - "xml2" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "rstudio/quillt, pkgdown", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "SystemRequirements": "pandoc (>= 1.14) - http://pandoc.org", - "NeedsCompilation": "no", - "Author": "JJ Allaire [aut], Yihui Xie [aut, cre] (), Christophe Dervieux [aut] (), Jonathan McPherson [aut], Javier Luraschi [aut], Kevin Ushey [aut], Aron Atkins [aut], Hadley Wickham [aut], Joe Cheng [aut], Winston Chang [aut], Richard Iannone [aut] (), Andrew Dunning [ctb] (), Atsushi Yasumoto [ctb, cph] (, Number sections Lua filter), Barret Schloerke [ctb], Carson Sievert [ctb] (), Devon Ryan [ctb] (), Frederik Aust [ctb] (), Jeff Allen [ctb], JooYoung Seo [ctb] (), Malcolm Barrett [ctb], Rob Hyndman [ctb], Romain Lesur [ctb], Roy Storey [ctb], Ruben Arslan [ctb], Sergio Oller [ctb], Posit Software, PBC [cph, fnd], jQuery UI contributors [ctb, cph] (jQuery UI library; authors listed in inst/rmd/h/jqueryui/AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Alexander Farkas [ctb, cph] (html5shiv library), Scott Jehl [ctb, cph] (Respond.js library), Ivan Sagalaev [ctb, cph] (highlight.js library), Greg Franko [ctb, cph] (tocify library), John MacFarlane [ctb, cph] (Pandoc templates), Google, Inc. [ctb, cph] (ioslides library), Dave Raggett [ctb] (slidy library), W3C [cph] (slidy library), Dave Gandy [ctb, cph] (Font-Awesome), Ben Sperry [ctb] (Ionicons), Drifty [cph] (Ionicons), Aidan Lister [ctb, cph] (jQuery StickyTabs), Benct Philip Jonsson [ctb, cph] (pagebreak Lua filter), Albert Krewinkel [ctb, cph] (pagebreak Lua filter)", - "Maintainer": "Yihui Xie ", - "Repository": "CRAN" - }, - "rootSolve": { - "Package": "rootSolve", - "Version": "1.8.2.4", - "Source": "Repository", - "Title": "Nonlinear Root Finding, Equilibrium and Steady-State Analysis of Ordinary Differential Equations", - "Authors@R": "c(person(\"Karline\",\"Soetaert\", role = c(\"aut\", \"cre\"), email = \"karline.soetaert@nioz.nl\"), person(\"Alan C.\",\"Hindmarsh\", role = \"ctb\", comment = \"files lsodes.f, sparse.f\"), person(\"S.C.\",\"Eisenstat\", role = \"ctb\", comment = \"file sparse.f\"), person(\"Cleve\",\"Moler\", role = \"ctb\", comment = \"file dlinpk.f\"), person(\"Jack\",\"Dongarra\", role = \"ctb\", comment = \"file dlinpk.f\"), person(\"Youcef\", \"Saad\", role = \"ctb\", comment = \"file dsparsk.f\"))", - "Maintainer": "Karline Soetaert ", - "Author": "Karline Soetaert [aut, cre], Alan C. Hindmarsh [ctb] (files lsodes.f, sparse.f), S.C. Eisenstat [ctb] (file sparse.f), Cleve Moler [ctb] (file dlinpk.f), Jack Dongarra [ctb] (file dlinpk.f), Youcef Saad [ctb] (file dsparsk.f)", - "Depends": [ - "R (>= 2.01)" - ], - "Imports": [ - "stats", - "graphics", - "grDevices" - ], - "Description": "Routines to find the root of nonlinear functions, and to perform steady-state and equilibrium analysis of ordinary differential equations (ODE). Includes routines that: (1) generate gradient and jacobian matrices (full and banded), (2) find roots of non-linear equations by the 'Newton-Raphson' method, (3) estimate steady-state conditions of a system of (differential) equations in full, banded or sparse form, using the 'Newton-Raphson' method, or by dynamically running, (4) solve the steady-state conditions for uni-and multicomponent 1-D, 2-D, and 3-D partial differential equations, that have been converted to ordinary differential equations by numerical differencing (using the method-of-lines approach). Includes fortran code.", - "License": "GPL (>= 2)", - "NeedsCompilation": "yes", - "Repository": "CRAN" - }, - "rprojroot": { - "Package": "rprojroot", - "Version": "2.0.4", - "Source": "Repository", - "Title": "Finding Files in Project Subdirectories", - "Authors@R": "person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\"))", - "Description": "Robust, reliable and flexible paths to files below a project root. The 'root' of a project is defined as a directory that matches a certain criterion, e.g., it contains a certain regular file.", - "License": "MIT + file LICENSE", - "URL": "https://rprojroot.r-lib.org/, https://github.com/r-lib/rprojroot", - "BugReports": "https://github.com/r-lib/rprojroot/issues", - "Depends": [ - "R (>= 3.0.0)" - ], - "Suggests": [ - "covr", - "knitr", - "lifecycle", - "mockr", - "rlang", - "rmarkdown", - "testthat (>= 3.0.0)", - "withr" - ], - "VignetteBuilder": "knitr", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Kirill Müller [aut, cre] ()", - "Maintainer": "Kirill Müller ", - "Repository": "RSPM" - }, - "rstudioapi": { - "Package": "rstudioapi", - "Version": "0.17.1", - "Source": "Repository", - "Title": "Safely Access the RStudio API", - "Description": "Access the RStudio API (if available) and provide informative error messages when it's not.", - "Authors@R": "c( person(\"Kevin\", \"Ushey\", role = c(\"aut\", \"cre\"), email = \"kevin@rstudio.com\"), person(\"JJ\", \"Allaire\", role = c(\"aut\"), email = \"jj@posit.co\"), person(\"Hadley\", \"Wickham\", role = c(\"aut\"), email = \"hadley@posit.co\"), person(\"Gary\", \"Ritchie\", role = c(\"aut\"), email = \"gary@posit.co\"), person(family = \"RStudio\", role = \"cph\") )", - "Maintainer": "Kevin Ushey ", - "License": "MIT + file LICENSE", - "URL": "https://rstudio.github.io/rstudioapi/, https://github.com/rstudio/rstudioapi", - "BugReports": "https://github.com/rstudio/rstudioapi/issues", - "RoxygenNote": "7.3.2", - "Suggests": [ - "testthat", - "knitr", - "rmarkdown", - "clipr", - "covr" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Kevin Ushey [aut, cre], JJ Allaire [aut], Hadley Wickham [aut], Gary Ritchie [aut], RStudio [cph]", - "Repository": "CRAN" - }, - "rtables": { - "Package": "rtables", - "Version": "0.6.11.9004", - "Source": "Repository", - "Title": "Reporting Tables", - "Date": "2025-02-06", - "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"aut\", comment = \"Original creator of the package\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Daniel\", \"Sabanés Bové\", , \"daniel.sabanes_bove@roche.com\", role = \"ctb\"), person(\"Maximilian\", \"Mordig\", , \"maximilian_oliver.mordig@roche.com\", role = \"ctb\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"ctb\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Reporting tables often have structure that goes beyond simple rectangular data. The 'rtables' package provides a framework for declaring complex multi-level tabulations and then applying them to data. This framework models both tabulation and the resulting tables as hierarchical, tree-like objects which support sibling sub-tables, arbitrary splitting or grouping of data in row and column dimensions, cells containing multiple values, and the concept of contextual summary computations. A convenient pipe-able interface is provided for declaring table layouts and the corresponding computations, and then applying them to data.", - "License": "Apache License 2.0 | file LICENSE", - "URL": "https://github.com/insightsengineering/rtables, https://insightsengineering.github.io/rtables/", - "BugReports": "https://github.com/insightsengineering/rtables/issues", - "Depends": [ - "formatters (>= 0.5.10)", - "magrittr (>= 1.5)", - "methods", - "R (>= 2.10)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "htmltools (>= 0.5.4)", - "lifecycle (>= 0.2.0)", - "stats", - "stringi (>= 1.6)" - ], - "Suggests": [ - "broom (>= 1.0.5)", - "car (>= 3.0-13)", - "dplyr (>= 1.0.5)", - "knitr (>= 1.42)", - "r2rtf (>= 0.3.2)", - "rmarkdown (>= 2.23)", - "survival (>= 3.3-1)", - "testthat (>= 3.2.1)", - "tibble (>= 3.2.1)", - "tidyr (>= 1.1.3)", - "withr (>= 2.0.0)", - "xml2 (>= 1.3.5)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/Needs/verdepcheck": "insightsengineering/formatters, tidyverse/magrittr, mllg/checkmate, rstudio/htmltools, gagolews/stringi, tidymodels/broom, cran/car, tidyverse/dplyr, davidgohel/flextable, yihui/knitr, r-lib/lifecycle, davidgohel/officer, Merck/r2rtf, rstudio/rmarkdown, therneau/survival, r-lib/testthat, tidyverse/tibble, tidyverse/tidyr, r-lib/withr, r-lib/xml2", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Collate": "'00tabletrees.R' 'Viewer.R' 'argument_conventions.R' 'as_html.R' 'utils.R' 'colby_constructors.R' 'compare_rtables.R' 'format_rcell.R' 'indent.R' 'make_subset_expr.R' 'custom_split_funs.R' 'default_split_funs.R' 'make_split_fun.R' 'summary.R' 'package.R' 'tree_accessors.R' 'tt_afun_utils.R' 'tt_as_df.R' 'tt_compare_tables.R' 'tt_compatibility.R' 'tt_dotabulation.R' 'tt_paginate.R' 'tt_pos_and_access.R' 'tt_showmethods.R' 'tt_sort.R' 'tt_test_afuns.R' 'tt_toString.R' 'tt_export.R' 'index_footnotes.R' 'tt_from_df.R' 'validate_table_struct.R' 'zzz_constants.R'", - "NeedsCompilation": "no", - "Author": "Gabriel Becker [aut] (Original creator of the package), Adrian Waddell [aut], Daniel Sabanés Bové [ctb], Maximilian Mordig [ctb], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [ctb], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Joe Zhu ", - "Repository": "RSPM" - }, - "rtables.officer": { - "Package": "rtables.officer", - "Version": "0.0.2", - "Source": "Repository", - "Title": "Exporting Tools for 'rtables'", - "Date": "2025-01-14", - "Authors@R": "c( person(\"Gabriel\", \"Becker\", , \"gabembecker@gmail.com\", role = \"ctb\"), person(\"Davide\", \"Garolini\", , \"davide.garolini@roche.com\", role = \"aut\"), person(\"Emily\", \"de la Rua\", , \"emily.de_la_rua@contractors.roche.com\", role = \"aut\"), person(\"Abinaya\", \"Yogasekaram\", , \"abinaya.yogasekaram@contractors.roche.com\", role = \"aut\"), person(\"Joe\", \"Zhu\", , \"joe.zhu@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-7566-2787\")), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Designed to create and display complex tables with R, the 'rtables' R package allows cells in an 'rtables' object to contain any high-dimensional data structure, which can then be displayed with cell-specific formatting instructions. Additionally, the 'rtables.officer' package supports export formats related to the Microsoft Office software suite, including Microsoft Word ('docx') and Microsoft PowerPoint ('pptx').", - "License": "Apache License 2.0", - "URL": "https://github.com/insightsengineering/rtables.officer, https://insightsengineering.github.io/rtables.officer/", - "BugReports": "https://github.com/insightsengineering/rtables.officer/issues", - "Depends": [ - "formatters (>= 0.5.10)", - "magrittr (>= 1.5)", - "methods", - "R (>= 2.10)", - "rtables (>= 0.6.11)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "flextable (>= 0.9.6)", - "lifecycle (>= 0.2.0)", - "officer (>= 0.6.6)", - "stats", - "stringi (>= 1.6)" - ], - "Suggests": [ - "broom (>= 1.0.5)", - "car (>= 3.0-13)", - "dplyr (>= 1.0.5)", - "knitr (>= 1.42)", - "r2rtf (>= 0.3.2)", - "rmarkdown (>= 2.23)", - "survival (>= 3.3-1)", - "testthat (>= 3.0.4)", - "tibble (>= 3.2.1)", - "tidyr (>= 1.1.3)", - "withr (>= 2.0.0)", - "xml2 (>= 1.1.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/Needs/verdepcheck": "insightsengineering/formatters, insightsengineering/rtables, tidyverse/magrittr, mllg/checkmate, rstudio/htmltools, gagolews/stringi, tidymodels/broom, cran/car, tidyverse/dplyr, davidgohel/flextable, yihui/knitr, r-lib/lifecycle, davidgohel/officer, Merck/r2rtf, rstudio/rmarkdown, therneau/survival, r-lib/testthat, tidyverse/tibble, tidyverse/tidyr, r-lib/withr, r-lib/xml2", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.3.2", - "Collate": "'package.R' 'export_as_docx.R' 'as_flextable.R'", - "NeedsCompilation": "no", - "Author": "Gabriel Becker [ctb], Davide Garolini [aut], Emily de la Rua [aut], Abinaya Yogasekaram [aut], Joe Zhu [aut, cre] (), F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Joe Zhu ", - "Repository": "CRAN" - }, - "sass": { - "Package": "sass", - "Version": "0.4.9", - "Source": "Repository", - "Type": "Package", - "Title": "Syntactically Awesome Style Sheets ('Sass')", - "Description": "An 'SCSS' compiler, powered by the 'LibSass' library. With this, R developers can use variables, inheritance, and functions to generate dynamic style sheets. The package uses the 'Sass CSS' extension language, which is stable, powerful, and CSS compatible.", - "Authors@R": "c( person(\"Joe\", \"Cheng\", , \"joe@rstudio.com\", \"aut\"), person(\"Timothy\", \"Mastny\", , \"tim.mastny@gmail.com\", \"aut\"), person(\"Richard\", \"Iannone\", , \"rich@rstudio.com\", \"aut\", comment = c(ORCID = \"0000-0003-3925-190X\")), person(\"Barret\", \"Schloerke\", , \"barret@rstudio.com\", \"aut\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Carson\", \"Sievert\", , \"carson@rstudio.com\", c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Christophe\", \"Dervieux\", , \"cderv@rstudio.com\", c(\"ctb\"), comment = c(ORCID = \"0000-0003-4474-2498\")), person(family = \"RStudio\", role = c(\"cph\", \"fnd\")), person(family = \"Sass Open Source Foundation\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Greter\", \"Marcel\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Mifsud\", \"Michael\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Hampton\", \"Catlin\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Natalie\", \"Weizenbaum\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Chris\", \"Eppstein\", role = c(\"ctb\", \"cph\"), comment = \"LibSass library\"), person(\"Adams\", \"Joseph\", role = c(\"ctb\", \"cph\"), comment = \"json.cpp\"), person(\"Trifunovic\", \"Nemanja\", role = c(\"ctb\", \"cph\"), comment = \"utf8.h\") )", - "License": "MIT + file LICENSE", - "URL": "https://rstudio.github.io/sass/, https://github.com/rstudio/sass", - "BugReports": "https://github.com/rstudio/sass/issues", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "SystemRequirements": "GNU make", - "Imports": [ - "fs (>= 1.2.4)", - "rlang (>= 0.4.10)", - "htmltools (>= 0.5.1)", - "R6", - "rappdirs" - ], - "Suggests": [ - "testthat", - "knitr", - "rmarkdown", - "withr", - "shiny", - "curl" - ], - "VignetteBuilder": "knitr", - "Config/testthat/edition": "3", - "NeedsCompilation": "yes", - "Author": "Joe Cheng [aut], Timothy Mastny [aut], Richard Iannone [aut] (), Barret Schloerke [aut] (), Carson Sievert [aut, cre] (), Christophe Dervieux [ctb] (), RStudio [cph, fnd], Sass Open Source Foundation [ctb, cph] (LibSass library), Greter Marcel [ctb, cph] (LibSass library), Mifsud Michael [ctb, cph] (LibSass library), Hampton Catlin [ctb, cph] (LibSass library), Natalie Weizenbaum [ctb, cph] (LibSass library), Chris Eppstein [ctb, cph] (LibSass library), Adams Joseph [ctb, cph] (json.cpp), Trifunovic Nemanja [ctb, cph] (utf8.h)", - "Maintainer": "Carson Sievert ", - "Repository": "RSPM" - }, - "scales": { - "Package": "scales", - "Version": "1.3.0", - "Source": "Repository", - "Title": "Scale Functions for Visualization", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\")), person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Dana\", \"Seidel\", role = \"aut\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Graphical scales map data to aesthetics, and provide methods for automatically determining breaks and labels for axes and legends.", - "License": "MIT + file LICENSE", - "URL": "https://scales.r-lib.org, https://github.com/r-lib/scales", - "BugReports": "https://github.com/r-lib/scales/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli", - "farver (>= 2.0.3)", - "glue", - "labeling", - "lifecycle", - "munsell (>= 0.5)", - "R6", - "RColorBrewer", - "rlang (>= 1.0.0)", - "viridisLite" - ], - "Suggests": [ - "bit64", - "covr", - "dichromat", - "ggplot2", - "hms (>= 0.5.0)", - "stringi", - "testthat (>= 3.0.0)" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyLoad": "yes", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut], Thomas Lin Pedersen [cre, aut] (), Dana Seidel [aut], Posit, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "RSPM" - }, - "shiny": { - "Package": "shiny", - "Version": "1.10.0", - "Source": "Repository", - "Type": "Package", - "Title": "Web Application Framework for R", - "Authors@R": "c( person(\"Winston\", \"Chang\", role = c(\"aut\", \"cre\"), email = \"winston@posit.co\", comment = c(ORCID = \"0000-0002-1576-2126\")), person(\"Joe\", \"Cheng\", role = \"aut\", email = \"joe@posit.co\"), person(\"JJ\", \"Allaire\", role = \"aut\", email = \"jj@posit.co\"), person(\"Carson\", \"Sievert\", role = \"aut\", email = \"carson@posit.co\", comment = c(ORCID = \"0000-0002-4958-2844\")), person(\"Barret\", \"Schloerke\", role = \"aut\", email = \"barret@posit.co\", comment = c(ORCID = \"0000-0001-9986-114X\")), person(\"Yihui\", \"Xie\", role = \"aut\", email = \"yihui@posit.co\"), person(\"Jeff\", \"Allen\", role = \"aut\"), person(\"Jonathan\", \"McPherson\", role = \"aut\", email = \"jonathan@posit.co\"), person(\"Alan\", \"Dipert\", role = \"aut\"), person(\"Barbara\", \"Borges\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(family = \"jQuery Foundation\", role = \"cph\", comment = \"jQuery library and jQuery UI library\"), person(family = \"jQuery contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt\"), person(family = \"jQuery UI contributors\", role = c(\"ctb\", \"cph\"), comment = \"jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt\"), person(\"Mark\", \"Otto\", role = \"ctb\", comment = \"Bootstrap library\"), person(\"Jacob\", \"Thornton\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Bootstrap contributors\", role = \"ctb\", comment = \"Bootstrap library\"), person(family = \"Twitter, Inc\", role = \"cph\", comment = \"Bootstrap library\"), person(\"Prem Nawaz\", \"Khan\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Victor\", \"Tsaran\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Dennis\", \"Lembree\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Srinivasu\", \"Chakravarthula\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(\"Cathy\", \"O'Connor\", role = \"ctb\", comment = \"Bootstrap accessibility plugin\"), person(family = \"PayPal, Inc\", role = \"cph\", comment = \"Bootstrap accessibility plugin\"), person(\"Stefan\", \"Petre\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap-datepicker library\"), person(\"Andrew\", \"Rowls\", role = c(\"ctb\", \"cph\"), comment = \"Bootstrap-datepicker library\"), person(\"Brian\", \"Reavis\", role = c(\"ctb\", \"cph\"), comment = \"selectize.js library\"), person(\"Salmen\", \"Bejaoui\", role = c(\"ctb\", \"cph\"), comment = \"selectize-plugin-a11y library\"), person(\"Denis\", \"Ineshin\", role = c(\"ctb\", \"cph\"), comment = \"ion.rangeSlider library\"), person(\"Sami\", \"Samhuri\", role = c(\"ctb\", \"cph\"), comment = \"Javascript strftime library\"), person(family = \"SpryMedia Limited\", role = c(\"ctb\", \"cph\"), comment = \"DataTables library\"), person(\"John\", \"Fraser\", role = c(\"ctb\", \"cph\"), comment = \"showdown.js library\"), person(\"John\", \"Gruber\", role = c(\"ctb\", \"cph\"), comment = \"showdown.js library\"), person(\"Ivan\", \"Sagalaev\", role = c(\"ctb\", \"cph\"), comment = \"highlight.js library\"), person(family = \"R Core Team\", role = c(\"ctb\", \"cph\"), comment = \"tar implementation from R\") )", - "Description": "Makes it incredibly easy to build interactive web applications with R. Automatic \"reactive\" binding between inputs and outputs and extensive prebuilt widgets make it possible to build beautiful, responsive, and powerful applications with minimal effort.", - "License": "GPL-3 | file LICENSE", - "Depends": [ - "R (>= 3.0.2)", - "methods" - ], - "Imports": [ - "utils", - "grDevices", - "httpuv (>= 1.5.2)", - "mime (>= 0.3)", - "jsonlite (>= 0.9.16)", - "xtable", - "fontawesome (>= 0.4.0)", - "htmltools (>= 0.5.4)", - "R6 (>= 2.0)", - "sourcetools", - "later (>= 1.0.0)", - "promises (>= 1.3.2)", - "tools", - "crayon", - "rlang (>= 0.4.10)", - "fastmap (>= 1.1.1)", - "withr", - "commonmark (>= 1.7)", - "glue (>= 1.3.2)", - "bslib (>= 0.6.0)", - "cachem (>= 1.1.0)", - "lifecycle (>= 0.2.0)" - ], - "Suggests": [ - "coro (>= 1.1.0)", - "datasets", - "DT", - "Cairo (>= 1.5-5)", - "testthat (>= 3.0.0)", - "knitr (>= 1.6)", - "markdown", - "rmarkdown", - "ggplot2", - "reactlog (>= 1.0.0)", - "magrittr", - "yaml", - "future", - "dygraphs", - "ragg", - "showtext", - "sass" - ], - "URL": "https://shiny.posit.co/, https://github.com/rstudio/shiny", - "BugReports": "https://github.com/rstudio/shiny/issues", - "Collate": "'globals.R' 'app-state.R' 'app_template.R' 'bind-cache.R' 'bind-event.R' 'bookmark-state-local.R' 'bookmark-state.R' 'bootstrap-deprecated.R' 'bootstrap-layout.R' 'conditions.R' 'map.R' 'utils.R' 'bootstrap.R' 'busy-indicators-spinners.R' 'busy-indicators.R' 'cache-utils.R' 'deprecated.R' 'devmode.R' 'diagnose.R' 'extended-task.R' 'fileupload.R' 'graph.R' 'reactives.R' 'reactive-domains.R' 'history.R' 'hooks.R' 'html-deps.R' 'image-interact-opts.R' 'image-interact.R' 'imageutils.R' 'input-action.R' 'input-checkbox.R' 'input-checkboxgroup.R' 'input-date.R' 'input-daterange.R' 'input-file.R' 'input-numeric.R' 'input-password.R' 'input-radiobuttons.R' 'input-select.R' 'input-slider.R' 'input-submit.R' 'input-text.R' 'input-textarea.R' 'input-utils.R' 'insert-tab.R' 'insert-ui.R' 'jqueryui.R' 'knitr.R' 'middleware-shiny.R' 'middleware.R' 'timer.R' 'shiny.R' 'mock-session.R' 'modal.R' 'modules.R' 'notifications.R' 'priorityqueue.R' 'progress.R' 'react.R' 'reexports.R' 'render-cached-plot.R' 'render-plot.R' 'render-table.R' 'run-url.R' 'runapp.R' 'serializers.R' 'server-input-handlers.R' 'server-resource-paths.R' 'server.R' 'shiny-options.R' 'shiny-package.R' 'shinyapp.R' 'shinyui.R' 'shinywrappers.R' 'showcase.R' 'snapshot.R' 'staticimports.R' 'tar.R' 'test-export.R' 'test-server.R' 'test.R' 'update-input.R' 'utils-lang.R' 'version_bs_date_picker.R' 'version_ion_range_slider.R' 'version_jquery.R' 'version_jqueryui.R' 'version_selectize.R' 'version_strftime.R' 'viewer.R'", - "RoxygenNote": "7.3.2", - "Encoding": "UTF-8", - "RdMacros": "lifecycle", - "Config/testthat/edition": "3", - "Config/Needs/check": "shinytest2", - "NeedsCompilation": "no", - "Author": "Winston Chang [aut, cre] (), Joe Cheng [aut], JJ Allaire [aut], Carson Sievert [aut] (), Barret Schloerke [aut] (), Yihui Xie [aut], Jeff Allen [aut], Jonathan McPherson [aut], Alan Dipert [aut], Barbara Borges [aut], Posit Software, PBC [cph, fnd], jQuery Foundation [cph] (jQuery library and jQuery UI library), jQuery contributors [ctb, cph] (jQuery library; authors listed in inst/www/shared/jquery-AUTHORS.txt), jQuery UI contributors [ctb, cph] (jQuery UI library; authors listed in inst/www/shared/jqueryui/AUTHORS.txt), Mark Otto [ctb] (Bootstrap library), Jacob Thornton [ctb] (Bootstrap library), Bootstrap contributors [ctb] (Bootstrap library), Twitter, Inc [cph] (Bootstrap library), Prem Nawaz Khan [ctb] (Bootstrap accessibility plugin), Victor Tsaran [ctb] (Bootstrap accessibility plugin), Dennis Lembree [ctb] (Bootstrap accessibility plugin), Srinivasu Chakravarthula [ctb] (Bootstrap accessibility plugin), Cathy O'Connor [ctb] (Bootstrap accessibility plugin), PayPal, Inc [cph] (Bootstrap accessibility plugin), Stefan Petre [ctb, cph] (Bootstrap-datepicker library), Andrew Rowls [ctb, cph] (Bootstrap-datepicker library), Brian Reavis [ctb, cph] (selectize.js library), Salmen Bejaoui [ctb, cph] (selectize-plugin-a11y library), Denis Ineshin [ctb, cph] (ion.rangeSlider library), Sami Samhuri [ctb, cph] (Javascript strftime library), SpryMedia Limited [ctb, cph] (DataTables library), John Fraser [ctb, cph] (showdown.js library), John Gruber [ctb, cph] (showdown.js library), Ivan Sagalaev [ctb, cph] (highlight.js library), R Core Team [ctb, cph] (tar implementation from R)", - "Maintainer": "Winston Chang ", - "Repository": "CRAN" - }, - "shinyWidgets": { - "Package": "shinyWidgets", - "Version": "0.8.7", - "Source": "Repository", - "Title": "Custom Inputs Widgets for Shiny", - "Authors@R": "c( person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"David\", \"Granjon\", role = \"aut\"), person(\"Ian\", \"Fellows\", role = \"ctb\", comment = \"Methods for mutating vertical tabs & updateMultiInput\"), person(\"Wil\", \"Davis\", role = \"ctb\", comment = \"numericRangeInput function\"), person(\"Spencer\", \"Matthews\", role = \"ctb\", comment = \"autoNumeric methods\"), person(family = \"JavaScript and CSS libraries authors\", role = c(\"ctb\", \"cph\"), comment = \"All authors are listed in LICENSE.md\") )", - "Description": "Collection of custom input controls and user interface components for 'Shiny' applications. Give your applications a unique and colorful style !", - "URL": "https://github.com/dreamRs/shinyWidgets, https://dreamrs.github.io/shinyWidgets/", - "BugReports": "https://github.com/dreamRs/shinyWidgets/issues", - "License": "GPL-3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.3.2", - "Depends": [ - "R (>= 3.1.0)" - ], - "Imports": [ - "bslib", - "sass", - "shiny (>= 1.6.0)", - "htmltools (>= 0.5.1)", - "jsonlite", - "grDevices", - "rlang" - ], - "Suggests": [ - "testthat", - "covr", - "ggplot2", - "DT", - "scales", - "shinydashboard", - "shinydashboardPlus" - ], - "NeedsCompilation": "no", - "Author": "Victor Perrier [aut, cre, cph], Fanny Meyer [aut], David Granjon [aut], Ian Fellows [ctb] (Methods for mutating vertical tabs & updateMultiInput), Wil Davis [ctb] (numericRangeInput function), Spencer Matthews [ctb] (autoNumeric methods), JavaScript and CSS libraries authors [ctb, cph] (All authors are listed in LICENSE.md)", - "Maintainer": "Victor Perrier ", - "Repository": "CRAN" - }, - "shinybusy": { - "Package": "shinybusy", - "Version": "0.3.3", - "Source": "Repository", - "Title": "Busy Indicators and Notifications for 'Shiny' Applications", - "Authors@R": "c(person(\"Fanny\", \"Meyer\", role = \"aut\"), person(\"Victor\", \"Perrier\", email = \"victor.perrier@dreamrs.fr\", role = c(\"aut\", \"cre\")), person(\"Silex Technologies\", comment = \"https://www.silex-ip.com\", role = \"fnd\"))", - "Description": "Add indicators (spinner, progress bar, gif) in your 'shiny' applications to show the user that the server is busy. And other tools to let your users know something is happening (send notifications, reports, ...).", - "License": "GPL-3", - "Encoding": "UTF-8", - "Imports": [ - "htmltools", - "shiny", - "jsonlite", - "htmlwidgets" - ], - "RoxygenNote": "7.3.1", - "URL": "https://github.com/dreamRs/shinybusy, https://dreamrs.github.io/shinybusy/", - "BugReports": "https://github.com/dreamRs/shinybusy/issues", - "Suggests": [ - "testthat", - "covr", - "knitr", - "rmarkdown" - ], - "VignetteBuilder": "knitr", - "NeedsCompilation": "no", - "Author": "Fanny Meyer [aut], Victor Perrier [aut, cre], Silex Technologies [fnd] (https://www.silex-ip.com)", - "Maintainer": "Victor Perrier ", - "Repository": "CRAN" - }, - "shinycssloaders": { - "Package": "shinycssloaders", - "Version": "1.1.0", - "Source": "Repository", - "Title": "Add Loading Animations to a 'shiny' Output While It's Recalculating", - "Authors@R": "c( person(\"Dean\",\"Attali\",email=\"daattali@gmail.com\",role=c(\"aut\",\"cre\"), comment = c(\"Maintainer/developer of shinycssloaders since 2019\", ORCID=\"0000-0002-5645-3493\")), person(\"Andras\",\"Sali\",email=\"andras.sali@alphacruncher.hu\",role=c(\"aut\"),comment=\"Original creator of shinycssloaders package\"), person(\"Luke\",\"Hass\",role=c(\"ctb\",\"cph\"),comment=\"Author of included CSS loader code\") )", - "Description": "When a 'Shiny' output (such as a plot, table, map, etc.) is recalculating, it remains visible but gets greyed out. Using 'shinycssloaders', you can add a loading animation (\"spinner\") to outputs instead. By wrapping a 'Shiny' output in 'withSpinner()', a spinner will automatically appear while the output is recalculating. You can also manually show and hide the spinner, or add a full-page spinner to cover the entire page. See the demo online at .", - "License": "MIT + file LICENSE", - "URL": "https://github.com/daattali/shinycssloaders, https://daattali.com/shiny/shinycssloaders-demo/", - "BugReports": "https://github.com/daattali/shinycssloaders/issues", - "Depends": [ - "R (>= 3.1)" - ], - "Imports": [ - "digest", - "glue", - "grDevices", - "htmltools (>= 0.3.5)", - "shiny" - ], - "Suggests": [ - "knitr", - "shinydisconnect", - "shinyjs" - ], - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Dean Attali [aut, cre] (Maintainer/developer of shinycssloaders since 2019, ), Andras Sali [aut] (Original creator of shinycssloaders package), Luke Hass [ctb, cph] (Author of included CSS loader code)", - "Maintainer": "Dean Attali ", - "Repository": "CRAN" - }, - "shinyjs": { - "Package": "shinyjs", - "Version": "2.1.0", - "Source": "Repository", - "Title": "Easily Improve the User Experience of Your Shiny Apps in Seconds", - "Authors@R": "person(\"Dean\", \"Attali\", email = \"daattali@gmail.com\", role = c(\"aut\", \"cre\"), comment= c(ORCID=\"0000-0002-5645-3493\"))", - "Description": "Perform common useful JavaScript operations in Shiny apps that will greatly improve your apps without having to know any JavaScript. Examples include: hiding an element, disabling an input, resetting an input back to its original value, delaying code execution by a few seconds, and many more useful functions for both the end user and the developer. 'shinyjs' can also be used to easily call your own custom JavaScript functions from R.", - "URL": "https://deanattali.com/shinyjs/", - "BugReports": "https://github.com/daattali/shinyjs/issues", - "Depends": [ - "R (>= 3.1.0)" - ], - "Imports": [ - "digest (>= 0.6.8)", - "jsonlite", - "shiny (>= 1.0.0)" - ], - "Suggests": [ - "htmltools (>= 0.2.9)", - "knitr (>= 1.7)", - "rmarkdown", - "shinyAce", - "shinydisconnect", - "testthat (>= 0.9.1)" - ], - "License": "MIT + file LICENSE", - "VignetteBuilder": "knitr", - "RoxygenNote": "7.1.1", - "Encoding": "UTF-8", - "NeedsCompilation": "no", - "Author": "Dean Attali [aut, cre] ()", - "Maintainer": "Dean Attali ", - "Repository": "RSPM" - }, - "sourcetools": { - "Package": "sourcetools", - "Version": "0.1.7-1", - "Source": "Repository", - "Type": "Package", - "Title": "Tools for Reading, Tokenizing and Parsing R Code", - "Author": "Kevin Ushey", - "Maintainer": "Kevin Ushey ", - "Description": "Tools for the reading and tokenization of R code. The 'sourcetools' package provides both an R and C++ interface for the tokenization of R code, and helpers for interacting with the tokenized representation of R code.", - "License": "MIT + file LICENSE", - "Depends": [ - "R (>= 3.0.2)" - ], - "Suggests": [ - "testthat" - ], - "RoxygenNote": "5.0.1", - "BugReports": "https://github.com/kevinushey/sourcetools/issues", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "Repository": "RSPM" - }, - "stringi": { - "Package": "stringi", - "Version": "1.8.4", - "Source": "Repository", - "Date": "2024-05-06", - "Title": "Fast and Portable Character String Processing Facilities", - "Description": "A collection of character string/text/natural language processing tools for pattern searching (e.g., with 'Java'-like regular expressions or the 'Unicode' collation algorithm), random string generation, case mapping, string transliteration, concatenation, sorting, padding, wrapping, Unicode normalisation, date-time formatting and parsing, and many more. They are fast, consistent, convenient, and - thanks to 'ICU' (International Components for Unicode) - portable across all locales and platforms. Documentation about 'stringi' is provided via its website at and the paper by Gagolewski (2022, ).", - "URL": "https://stringi.gagolewski.com/, https://github.com/gagolews/stringi, https://icu.unicode.org/", - "BugReports": "https://github.com/gagolews/stringi/issues", - "SystemRequirements": "ICU4C (>= 61, optional)", - "Type": "Package", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "tools", - "utils", - "stats" - ], - "Biarch": "TRUE", - "License": "file LICENSE", - "Author": "Marek Gagolewski [aut, cre, cph] (), Bartek Tartanus [ctb], and others (stringi source code); Unicode, Inc. and others (ICU4C source code, Unicode Character Database)", - "Maintainer": "Marek Gagolewski ", - "RoxygenNote": "7.2.3", - "Encoding": "UTF-8", - "NeedsCompilation": "yes", - "License_is_FOSS": "yes", - "Repository": "RSPM" - }, - "stringr": { - "Package": "stringr", - "Version": "1.5.1", - "Source": "Repository", - "Title": "Simple, Consistent Wrappers for Common String Operations", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\", \"cph\")), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A consistent, simple and easy to use set of wrappers around the fantastic 'stringi' package. All function and argument names (and positions) are consistent, all functions deal with \"NA\"'s and zero length vectors in the same way, and the output from one function is easy to feed into the input of another.", - "License": "MIT + file LICENSE", - "URL": "https://stringr.tidyverse.org, https://github.com/tidyverse/stringr", - "BugReports": "https://github.com/tidyverse/stringr/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli", - "glue (>= 1.6.1)", - "lifecycle (>= 1.0.3)", - "magrittr", - "rlang (>= 1.0.0)", - "stringi (>= 1.5.3)", - "vctrs (>= 0.4.0)" - ], - "Suggests": [ - "covr", - "dplyr", - "gt", - "htmltools", - "htmlwidgets", - "knitr", - "rmarkdown", - "testthat (>= 3.0.0)", - "tibble" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Hadley Wickham [aut, cre, cph], Posit Software, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "styler": { - "Package": "styler", - "Version": "1.10.3", - "Source": "Repository", - "Type": "Package", - "Title": "Non-Invasive Pretty Printing of R Code", - "Authors@R": "c(person(given = \"Kirill\", family = \"Müller\", role = \"aut\", email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Lorenz\", family = \"Walthert\", role = c(\"cre\", \"aut\"), email = \"lorenz.walthert@icloud.com\"), person(given = \"Indrajeet\", family = \"Patil\", role = \"ctb\", email = \"patilindrajeet.science@gmail.com\", comment = c(ORCID = \"0000-0003-1995-6531\", Twitter = \"@patilindrajeets\")))", - "Description": "Pretty-prints R code without changing the user's formatting intent.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/styler, https://styler.r-lib.org", - "BugReports": "https://github.com/r-lib/styler/issues", - "Depends": [ - "R (>= 3.6.0)" - ], - "Imports": [ - "cli (>= 3.1.1)", - "magrittr (>= 2.0.0)", - "purrr (>= 0.2.3)", - "R.cache (>= 0.15.0)", - "rlang (>= 1.0.0)", - "rprojroot (>= 1.1)", - "tools", - "vctrs (>= 0.4.1)", - "withr (>= 2.3.0)" - ], - "Suggests": [ - "data.tree (>= 0.1.6)", - "digest", - "here", - "knitr", - "prettycode", - "rmarkdown", - "roxygen2", - "rstudioapi (>= 0.7)", - "tibble (>= 1.4.2)", - "testthat (>= 3.0.0)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.1", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "true", - "Collate": "'addins.R' 'communicate.R' 'compat-dplyr.R' 'compat-tidyr.R' 'detect-alignment-utils.R' 'detect-alignment.R' 'environments.R' 'expr-is.R' 'indent.R' 'initialize.R' 'io.R' 'nest.R' 'nested-to-tree.R' 'parse.R' 'reindent.R' 'token-define.R' 'relevel.R' 'roxygen-examples-add-remove.R' 'roxygen-examples-find.R' 'roxygen-examples-parse.R' 'roxygen-examples.R' 'rules-indention.R' 'rules-line-breaks.R' 'rules-spaces.R' 'rules-tokens.R' 'serialize.R' 'set-assert-args.R' 'style-guides.R' 'styler-package.R' 'stylerignore.R' 'testing-mocks.R' 'testing-public-api.R' 'ui-caching.R' 'testing.R' 'token-create.R' 'transform-block.R' 'transform-code.R' 'transform-files.R' 'ui-styling.R' 'unindent.R' 'utils-cache.R' 'utils-files.R' 'utils-navigate-nest.R' 'utils-strings.R' 'utils.R' 'vertical.R' 'visit.R' 'zzz.R'", - "NeedsCompilation": "no", - "Author": "Kirill Müller [aut] (), Lorenz Walthert [cre, aut], Indrajeet Patil [ctb] (, @patilindrajeets)", - "Maintainer": "Lorenz Walthert ", - "Repository": "CRAN" - }, - "sys": { - "Package": "sys", - "Version": "3.4.3", - "Source": "Repository", - "Type": "Package", - "Title": "Powerful and Reliable Tools for Running System Commands in R", - "Authors@R": "c(person(\"Jeroen\", \"Ooms\", role = c(\"aut\", \"cre\"), email = \"jeroenooms@gmail.com\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = \"ctb\"))", - "Description": "Drop-in replacements for the base system2() function with fine control and consistent behavior across platforms. Supports clean interruption, timeout, background tasks, and streaming STDIN / STDOUT / STDERR over binary or text connections. Arguments on Windows automatically get encoded and quoted to work on different locales.", - "License": "MIT + file LICENSE", - "URL": "https://jeroen.r-universe.dev/sys", - "BugReports": "https://github.com/jeroen/sys/issues", - "Encoding": "UTF-8", - "RoxygenNote": "7.1.1", - "Suggests": [ - "unix (>= 1.4)", - "spelling", - "testthat" - ], - "Language": "en-US", - "NeedsCompilation": "yes", - "Author": "Jeroen Ooms [aut, cre] (), Gábor Csárdi [ctb]", - "Maintainer": "Jeroen Ooms ", - "Repository": "RSPM" - }, - "systemfonts": { - "Package": "systemfonts", - "Version": "1.2.1", - "Source": "Repository", - "Type": "Package", - "Title": "System Native Font Finding", - "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Jeroen\", \"Ooms\", , \"jeroen@berkeley.edu\", role = \"aut\", comment = c(ORCID = \"0000-0002-4035-0289\")), person(\"Devon\", \"Govett\", role = \"aut\", comment = \"Author of font-manager\"), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides system native access to the font catalogue. As font handling varies between systems it is difficult to correctly locate installed fonts across different operating systems. The 'systemfonts' package provides bindings to the native libraries on Windows, macOS and Linux for finding font files that can then be used further by e.g. graphic devices. The main use is intended to be from compiled code but 'systemfonts' also provides access from R.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/systemfonts, https://systemfonts.r-lib.org", - "BugReports": "https://github.com/r-lib/systemfonts/issues", - "Depends": [ - "R (>= 3.2.0)" - ], - "Suggests": [ - "covr", - "farver", - "graphics", - "knitr", - "rmarkdown", - "testthat (>= 2.1.0)" - ], - "LinkingTo": [ - "cpp11 (>= 0.2.1)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "SystemRequirements": "fontconfig, freetype2", - "Config/Needs/website": "tidyverse/tidytemplate", - "Imports": [ - "grid", - "jsonlite", - "lifecycle", - "tools", - "utils" - ], - "Config/build/compilation-database": "true", - "NeedsCompilation": "yes", - "Author": "Thomas Lin Pedersen [aut, cre] (), Jeroen Ooms [aut] (), Devon Govett [aut] (Author of font-manager), Posit, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "CRAN" - }, - "teal": { - "Package": "teal", - "Version": "0.15.2.9131", - "Source": "Repository", - "Type": "Package", - "Title": "Exploratory Web Apps for Analyzing Clinical Trials Data", - "Date": "2025-02-12", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\"), person(\"Vedha\", \"Viyash\", , \"vedha.viyash@roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Adrian\", \"Waddell\", , \"adrian.waddell@gene.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"Tadeusz\", \"Lewandowski\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")), person(\"Maximilian\", \"Mordig\", role = \"ctb\") )", - "Description": "A 'shiny' based interactive exploration framework for analyzing clinical trials data. 'teal' currently provides a dynamic filtering facility and different data viewers. 'teal' 'shiny' applications are built using standard 'shiny' modules.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal/, https://github.com/insightsengineering/teal/", - "BugReports": "https://github.com/insightsengineering/teal/issues", - "Depends": [ - "R (>= 4.1)", - "shiny (>= 1.8.1)", - "teal.data (>= 0.7.0)", - "teal.slice (>= 0.6.0)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "cli", - "htmltools", - "jsonlite", - "lifecycle (>= 0.2.0)", - "logger (>= 0.2.0)", - "methods", - "rlang (>= 1.0.0)", - "shinyjs", - "stats", - "teal.code (>= 0.6.0)", - "teal.logger (>= 0.3.1)", - "teal.reporter (>= 0.4.0)", - "teal.widgets (>= 0.4.3)", - "tools", - "utils" - ], - "Suggests": [ - "bslib", - "ggplot2 (>= 3.4.0)", - "knitr (>= 1.42)", - "mirai (>= 1.1.1)", - "MultiAssayExperiment", - "R6", - "renv (>= 1.0.11)", - "rmarkdown (>= 2.23)", - "roxy.shinylive", - "rvest (>= 1.0.0)", - "shinytest2", - "shinyvalidate", - "testthat (>= 3.2.0)", - "withr (>= 2.1.0)", - "yaml (>= 1.1.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "rstudio/shiny, insightsengineering/teal.data, insightsengineering/teal.slice, mllg/checkmate, jeroen/jsonlite, r-lib/lifecycle, daroczig/logger, shikokuchuo/mirai, r-lib/cli, shikokuchuo/nanonext, rstudio/renv, r-lib/rlang, daattali/shinyjs, insightsengineering/teal.code, insightsengineering/teal.logger, insightsengineering/teal.reporter, insightsengineering/teal.widgets, rstudio/bslib, yihui/knitr, bioc::MultiAssayExperiment, r-lib/R6, rstudio/rmarkdown, tidyverse/rvest, rstudio/shinytest2, rstudio/shinyvalidate, r-lib/testthat, r-lib/withr, yaml=vubiostat/r-yaml, rstudio/htmltools, bioc::matrixStats, insightsengineering/roxy.shinylive", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE, packages = c(\"roxy.shinylive\"))", - "RoxygenNote": "7.3.2", - "Collate": "'TealAppDriver.R' 'checkmate.R' 'dummy_functions.R' 'include_css_js.R' 'modules.R' 'init.R' 'landing_popup_module.R' 'module_bookmark_manager.R' 'module_data_summary.R' 'module_filter_data.R' 'module_filter_manager.R' 'module_init_data.R' 'module_nested_tabs.R' 'module_session_info.R' 'module_snapshot_manager.R' 'module_teal.R' 'module_teal_data.R' 'module_teal_lockfile.R' 'module_teal_with_splash.R' 'module_transform_data.R' 'reporter_previewer_module.R' 'show_rcode_modal.R' 'tdata.R' 'teal.R' 'teal_data_module.R' 'teal_data_module-eval_code.R' 'teal_data_module-within.R' 'teal_data_utils.R' 'teal_modifiers.R' 'teal_reporter.R' 'teal_slices-store.R' 'teal_slices.R' 'teal_transform_module.R' 'utils.R' 'validate_inputs.R' 'validations.R' 'zzz.R'", - "Config/pak/sysreqs": "libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev make libharfbuzz-dev libicu-dev libjpeg-dev libpng-dev libtiff-dev libxml2-dev libssl-dev zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal", - "RemoteRef": "HEAD", - "RemoteSha": "c75f39ed4f4eb989059e7a22aace4a8cfb020bc6", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre] (), Pawel Rucki [aut], Aleksander Chlebowski [aut] (), Andre Verissimo [aut] (), Kartikeya Kirar [aut], Vedha Viyash [aut], Marcin Kosinski [aut], Adrian Waddell [aut], Chendi Liao [rev], Dony Unardi [rev], Nikolas Burkoff [aut], Mahmoud Hallal [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Tadeusz Lewandowski [aut], F. Hoffmann-La Roche AG [cph, fnd], Maximilian Mordig [ctb]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.code": { - "Package": "teal.code", - "Version": "0.6.0.9002", - "Source": "Repository", - "Type": "Package", - "Title": "Code Storage and Execution Class for 'teal' Applications", - "Date": "2025-02-04", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", , \"nikolas.burkoff@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", , \"maciej.nasinski@contractors.roche.com\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", , \"konrad.pagacz@contractors.roche.com\", role = \"aut\"), person(\"Junlue\", \"Zhao\", , \"zhaoj88@gene.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Introduction of 'qenv' S4 class, that facilitates code execution and reproducibility in 'teal' applications.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal.code/, https://github.com/insightsengineering/teal.code", - "BugReports": "https://github.com/insightsengineering/teal.code/issues", - "Depends": [ - "methods", - "R (>= 4.0)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "cli (>= 3.4.0)", - "grDevices", - "lifecycle (>= 0.2.0)", - "rlang (>= 1.1.0)", - "stats", - "utils" - ], - "Suggests": [ - "knitr (>= 1.42)", - "rmarkdown (>= 2.23)", - "shiny (>= 1.6.0)", - "testthat (>= 3.1.8)", - "withr (>= 2.0.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "mllg/checkmate, r-lib/cli, r-lib/lifecycle, r-lib/rlang, r-lib/cli, yihui/knitr, rstudio/rmarkdown, rstudio/shiny, r-lib/testthat, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Collate": "'qenv-c.R' 'qenv-class.R' 'qenv-errors.R' 'qenv-concat.R' 'qenv-constructor.R' 'qenv-eval_code.R' 'qenv-extract.R' 'qenv-get_code.R' 'qenv-get_env.R' 'qenv-get_messages.r' 'qenv-get_var.R' 'qenv-get_warnings.R' 'qenv-join.R' 'qenv-length.R' 'qenv-show.R' 'qenv-within.R' 'teal.code-package.R' 'utils-get_code_dependency.R' 'utils.R'", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.code", - "RemoteRef": "HEAD", - "RemoteSha": "b336941dcc830a9b01fc8e206831cc4367599161", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre], Aleksander Chlebowski [aut], Marcin Kosinski [aut], Pawel Rucki [aut], Nikolas Burkoff [aut], Mahmoud Hallal [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.data": { - "Package": "teal.data", - "Version": "0.7.0.9001", - "Source": "Repository", - "Type": "Package", - "Title": "Data Model for 'teal' Applications", - "Date": "2025-01-31", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides a 'teal_data' class as a unified data model for 'teal' applications focusing on reproducibility and relational data.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal.data/, https://github.com/insightsengineering/teal.data/", - "BugReports": "https://github.com/insightsengineering/teal.data/issues", - "Depends": [ - "R (>= 4.0)", - "teal.code (>= 0.6.0)" - ], - "Imports": [ - "checkmate (>= 2.1.0)", - "lifecycle (>= 0.2.0)", - "methods", - "rlang (>= 1.1.0)", - "stats", - "utils" - ], - "Suggests": [ - "knitr (>= 1.42)", - "rmarkdown (>= 2.23)", - "testthat (>= 3.2.2)", - "withr (>= 2.0.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "insightsengineering/teal.code, mllg/checkmate, r-lib/lifecycle, r-lib/rlang, yihui/knitr, rstudio/rmarkdown, r-lib/testthat, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "LazyData": "true", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Collate": "'cdisc_data.R' 'data.R' 'formatters_var_labels.R' 'deprecated.R' 'dummy_function.R' 'join_key.R' 'join_keys-c.R' 'join_keys-extract.R' 'join_keys-names.R' 'join_keys-parents.R' 'join_keys-print.R' 'join_keys-utils.R' 'join_keys.R' 'teal.data.R' 'teal_data-class.R' 'teal_data-constructor.R' 'teal_data-extract.R' 'teal_data-get_code.R' 'teal_data-names.R' 'teal_data-show.R' 'testhat-helpers.R' 'topological_sort.R' 'verify.R' 'zzz.R'", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.data", - "RemoteRef": "HEAD", - "RemoteSha": "9100800ce0572092f6f2e0288d099e6b77ab160c", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre] (), Aleksander Chlebowski [aut] (), Marcin Kosinski [aut], Andre Verissimo [aut] (), Pawel Rucki [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.logger": { - "Package": "teal.logger", - "Version": "0.3.1.9001", - "Source": "Repository", - "Title": "Logging Setup for the 'teal' Family of Packages", - "Date": "2025-02-06", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Utilizing the 'logger' framework to record events within a package, specific to 'teal' family of packages. Supports logging namespaces, hierarchical logging, various log destinations, vectorization, and more.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal.logger/, https://github.com/insightsengineering/teal.logger/", - "BugReports": "https://github.com/insightsengineering/teal.logger/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "glue (>= 1.0.0)", - "lifecycle (>= 0.2.0)", - "logger (>= 0.3.0)", - "methods", - "shiny (>= 1.6.0)", - "utils", - "withr (>= 2.1.0)" - ], - "Suggests": [ - "knitr (>= 1.42)", - "rmarkdown (>= 2.23)", - "testthat (>= 3.1.7)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "tidyverse/glue, r-lib/lifecycle, daroczig/logger, rstudio/shiny, r-lib/withr, yihui/knitr, rstudio/rmarkdown, r-lib/testthat", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Config/pak/sysreqs": "make zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.logger", - "RemoteRef": "HEAD", - "RemoteSha": "99657d4725f47966d9f7502f7d266947228011d6", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre], Konrad Pagacz [aut], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.reporter": { - "Package": "teal.reporter", - "Version": "0.4.0.9003", - "Source": "Repository", - "Title": "Reporting Tools for 'shiny' Modules", - "Date": "2025-01-31", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\", comment = c(ORCID = \"0009-0005-1258-4757\")), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Prebuilt 'shiny' modules containing tools for the generation of 'rmarkdown' reports, supporting reproducible research and analysis.", - "License": "Apache License 2.0", - "URL": "https://github.com/insightsengineering/teal.reporter, https://insightsengineering.github.io/teal.reporter/", - "BugReports": "https://github.com/insightsengineering/teal.reporter/issues", - "Imports": [ - "bslib", - "checkmate (>= 2.1.0)", - "flextable (>= 0.9.2)", - "grid", - "htmltools (>= 0.5.4)", - "knitr (>= 1.42)", - "lifecycle (>= 0.2.0)", - "R6", - "rlistings (>= 0.2.10)", - "rmarkdown (>= 2.23)", - "rtables (>= 0.6.11)", - "rtables.officer (>= 0.0.2)", - "shiny (>= 1.6.0)", - "shinybusy (>= 0.3.2)", - "shinyWidgets (>= 0.5.1)", - "yaml (>= 1.1.0)", - "zip (>= 1.1.0)" - ], - "Suggests": [ - "DT (>= 0.13)", - "formatR (>= 1.5)", - "formatters (>= 0.5.10)", - "ggplot2 (>= 3.4.3)", - "lattice (>= 0.18-4)", - "png", - "testthat (>= 3.2.2)", - "tinytex", - "withr (>= 2.0.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "rstudio/bslib, mllg/checkmate, davidgohel/flextable, rstudio/htmltools, yihui/knitr, r-lib/lifecycle, r-lib/R6, insightsengineering/rlistings, rstudio/rmarkdown, insightsengineering/rtables, insightsengineering/rtables.officer, rstudio/shiny, dreamRs/shinybusy, dreamRs/shinyWidgets, yaml=vubiostat/r-yaml, r-lib/zip, rstudio/DT, yihui/formatR, insightsengineering/formatters, tidyverse/ggplot2, deepayan/lattice, cran/png, r-lib/testthat, rstudio/tinytex, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Config/pak/sysreqs": "libcairo2-dev libfontconfig1-dev libfreetype6-dev libfribidi-dev make libharfbuzz-dev libicu-dev libjpeg-dev libpng-dev libtiff-dev libxml2-dev libssl-dev zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.reporter", - "RemoteRef": "HEAD", - "RemoteSha": "b19bdd307fe24c9678a984beb57bc6e9e5c1643f", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre] (), Kartikeya Kirar [aut] (), Marcin Kosinski [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Mahmoud Hallal [aut], Chendi Liao [rev], Dony Unardi [rev], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.slice": { - "Package": "teal.slice", - "Version": "0.6.0.9000", - "Source": "Repository", - "Type": "Package", - "Title": "Filter Module for 'teal' Applications", - "Date": "2025-02-04", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0001-9533-457X\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Aleksander\", \"Chlebowski\", , \"aleksander.chlebowski@contractors.roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0001-5018-6294\")), person(\"Andre\", \"Verissimo\", , \"andre.verissimo@roche.com\", role = \"aut\", comment = c(ORCID = \"0000-0002-2212-339X\")), person(\"Kartikeya\", \"Kirar\", , \"kartikeya.kirar@businesspartner.roche.com\", role = \"aut\"), person(\"Marcin\", \"Kosinski\", , \"marcin.kosinski.mk1@roche.com\", role = \"aut\"), person(\"Chendi\", \"Liao\", , \"chendi.liao@roche.com\", role = \"rev\"), person(\"Dony\", \"Unardi\", , \"unardid@gene.com\", role = \"rev\"), person(\"Andrew\", \"Bates\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Data filtering module for 'teal' applications. Allows for interactive filtering of data stored in 'data.frame' and 'MultiAssayExperiment' objects. Also displays filtered and unfiltered observation counts.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal.slice/, https://github.com/insightsengineering/teal.slice/", - "BugReports": "https://github.com/insightsengineering/teal.slice/issues", - "Depends": [ - "R (>= 4.0)" - ], - "Imports": [ - "bslib (>= 0.4.0)", - "checkmate (>= 2.1.0)", - "dplyr (>= 1.0.5)", - "grDevices", - "htmltools (>= 0.5.4)", - "jsonlite", - "lifecycle (>= 0.2.0)", - "logger (>= 0.3.0)", - "methods", - "plotly (>= 4.9.2.2)", - "R6 (>= 2.2.0)", - "rlang (>= 1.0.0)", - "shiny (>= 1.6.0)", - "shinycssloaders (>= 1.0.0)", - "shinyjs", - "shinyWidgets (>= 0.6.2)", - "teal.data (>= 0.7.0)", - "teal.logger (>= 0.3.1)", - "teal.widgets (>= 0.4.3)", - "utils" - ], - "Suggests": [ - "knitr (>= 1.42)", - "MultiAssayExperiment", - "rmarkdown (>= 2.23)", - "SummarizedExperiment", - "testthat (>= 3.2.2)", - "withr (>= 3.0.2)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "RdMacros": "lifecycle", - "Config/Needs/verdepcheck": "rstudio/shiny, rstudio/bslib, mllg/checkmate, tidyverse/dplyr, rstudio/htmltools, jeroen/jsonlite, r-lib/lifecycle, daroczig/logger, plotly/plotly, r-lib/R6, daattali/shinycssloaders, daattali/shinyjs, dreamRs/shinyWidgets, insightsengineering/teal.data, insightsengineering/teal.logger, insightsengineering/teal.widgets, yihui/knitr, bioc::MultiAssayExperiment, bioc::SummarizedExperiment, rstudio/rmarkdown, r-lib/testthat, r-lib/withr, bioc::matrixStats", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Config/pak/sysreqs": "make libicu-dev libssl-dev zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.slice", - "RemoteRef": "HEAD", - "RemoteSha": "7f261e0e59a95c29dd511ef64099c53c9617baf4", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre] (), Pawel Rucki [aut], Aleksander Chlebowski [aut] (), Andre Verissimo [aut] (), Kartikeya Kirar [aut], Marcin Kosinski [aut], Chendi Liao [rev], Dony Unardi [rev], Andrew Bates [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "teal.widgets": { - "Package": "teal.widgets", - "Version": "0.4.3.9000", - "Source": "Repository", - "Title": "'shiny' Widgets for 'teal' Applications", - "Date": "2025-01-31", - "Authors@R": "c( person(\"Dawid\", \"Kaledkowski\", , \"dawid.kaledkowski@roche.com\", role = c(\"aut\", \"cre\")), person(\"Pawel\", \"Rucki\", , \"pawel.rucki@roche.com\", role = \"aut\"), person(\"Mahmoud\", \"Hallal\", , \"mahmoud.hallal@roche.com\", role = \"aut\"), person(\"Nikolas\", \"Burkoff\", role = \"aut\"), person(\"Maciej\", \"Nasinski\", role = \"aut\"), person(\"Konrad\", \"Pagacz\", role = \"aut\"), person(\"Junlue\", \"Zhao\", role = \"aut\"), person(\"F. Hoffmann-La Roche AG\", role = c(\"cph\", \"fnd\")) )", - "Description": "Collection of 'shiny' widgets to support 'teal' applications. Enables the manipulation of application layout and plot or table settings.", - "License": "Apache License 2.0", - "URL": "https://insightsengineering.github.io/teal.widgets/, https://github.com/insightsengineering/teal.widgets", - "BugReports": "https://github.com/insightsengineering/teal.widgets/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "bslib", - "checkmate (>= 2.1.0)", - "ggplot2 (>= 3.4.3)", - "graphics", - "grDevices", - "htmltools (>= 0.5.4)", - "lifecycle (>= 0.2.0)", - "methods", - "rtables (>= 0.6.6)", - "shiny (>= 1.6.0)", - "shinyjs", - "shinyWidgets (>= 0.5.1)", - "styler (>= 1.2.0)" - ], - "Suggests": [ - "DT", - "knitr (>= 1.42)", - "lattice (>= 0.18-4)", - "magrittr (>= 1.5)", - "png", - "rmarkdown (>= 2.23)", - "rvest (>= 1.0.3)", - "shinytest2 (>= 0.2.0)", - "shinyvalidate", - "testthat (>= 3.1.5)", - "withr (>= 2.1.0)" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/Needs/verdepcheck": "rstudio/bslib, mllg/checkmate, tidyverse/ggplot2, rstudio/htmltools, r-lib/lifecycle, insightsengineering/rtables, rstudio/shiny, daattali/shinyjs, dreamRs/shinyWidgets, r-lib/styler, rstudio/DT, yihui/knitr, deepayan/lattice, tidyverse/magrittr, cran/png, tidyverse/rvest, rstudio/rmarkdown, rstudio/shinytest2, rstudio/shinyvalidate, r-lib/testthat, r-lib/withr", - "Config/Needs/website": "insightsengineering/nesttemplate", - "Encoding": "UTF-8", - "Language": "en-US", - "Roxygen": "list(markdown = TRUE)", - "RoxygenNote": "7.3.2", - "Config/pak/sysreqs": "make libicu-dev zlib1g-dev", - "Repository": "https://pharmaverse.r-universe.dev", - "RemoteUrl": "https://github.com/insightsengineering/teal.widgets", - "RemoteRef": "HEAD", - "RemoteSha": "ec4a5eed3915e4fa905a45e28b38ca13e78d09ac", - "NeedsCompilation": "no", - "Author": "Dawid Kaledkowski [aut, cre], Pawel Rucki [aut], Mahmoud Hallal [aut], Nikolas Burkoff [aut], Maciej Nasinski [aut], Konrad Pagacz [aut], Junlue Zhao [aut], F. Hoffmann-La Roche AG [cph, fnd]", - "Maintainer": "Dawid Kaledkowski " - }, - "textshaping": { - "Package": "textshaping", - "Version": "1.0.0", - "Source": "Repository", - "Title": "Bindings to the 'HarfBuzz' and 'Fribidi' Libraries for Text Shaping", - "Authors@R": "c( person(\"Thomas Lin\", \"Pedersen\", , \"thomas.pedersen@posit.co\", role = c(\"cre\", \"aut\"), comment = c(ORCID = \"0000-0002-5147-4711\")), person(\"Posit, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides access to the text shaping functionality in the 'HarfBuzz' library and the bidirectional algorithm in the 'Fribidi' library. 'textshaping' is a low-level utility package mainly for graphic devices that expands upon the font tool-set provided by the 'systemfonts' package.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/textshaping", - "BugReports": "https://github.com/r-lib/textshaping/issues", - "Depends": [ - "R (>= 3.2.0)" - ], - "Imports": [ - "lifecycle", - "stats", - "stringi", - "systemfonts (>= 1.1.0)", - "utils" - ], - "Suggests": [ - "covr", - "grDevices", - "grid", - "knitr", - "rmarkdown", - "testthat (>= 3.0.0)" - ], - "LinkingTo": [ - "cpp11 (>= 0.2.1)", - "systemfonts (>= 1.0.0)" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "SystemRequirements": "freetype2, harfbuzz, fribidi", - "Config/build/compilation-database": "true", - "Config/testthat/edition": "3", - "NeedsCompilation": "yes", - "Author": "Thomas Lin Pedersen [cre, aut] (), Posit, PBC [cph, fnd]", - "Maintainer": "Thomas Lin Pedersen ", - "Repository": "CRAN" - }, - "tibble": { - "Package": "tibble", - "Version": "3.2.1", - "Source": "Repository", - "Title": "Simple Data Frames", - "Authors@R": "c(person(given = \"Kirill\", family = \"M\\u00fcller\", role = c(\"aut\", \"cre\"), email = \"kirill@cynkra.com\", comment = c(ORCID = \"0000-0002-1416-3412\")), person(given = \"Hadley\", family = \"Wickham\", role = \"aut\", email = \"hadley@rstudio.com\"), person(given = \"Romain\", family = \"Francois\", role = \"ctb\", email = \"romain@r-enthusiasts.com\"), person(given = \"Jennifer\", family = \"Bryan\", role = \"ctb\", email = \"jenny@rstudio.com\"), person(given = \"RStudio\", role = c(\"cph\", \"fnd\")))", - "Description": "Provides a 'tbl_df' class (the 'tibble') with stricter checking and better formatting than the traditional data frame.", - "License": "MIT + file LICENSE", - "URL": "https://tibble.tidyverse.org/, https://github.com/tidyverse/tibble", - "BugReports": "https://github.com/tidyverse/tibble/issues", - "Depends": [ - "R (>= 3.4.0)" - ], - "Imports": [ - "fansi (>= 0.4.0)", - "lifecycle (>= 1.0.0)", - "magrittr", - "methods", - "pillar (>= 1.8.1)", - "pkgconfig", - "rlang (>= 1.0.2)", - "utils", - "vctrs (>= 0.4.2)" - ], - "Suggests": [ - "bench", - "bit64", - "blob", - "brio", - "callr", - "cli", - "covr", - "crayon (>= 1.3.4)", - "DiagrammeR", - "dplyr", - "evaluate", - "formattable", - "ggplot2", - "here", - "hms", - "htmltools", - "knitr", - "lubridate", - "mockr", - "nycflights13", - "pkgbuild", - "pkgload", - "purrr", - "rmarkdown", - "stringi", - "testthat (>= 3.0.2)", - "tidyr", - "withr" - ], - "VignetteBuilder": "knitr", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "true", - "Config/testthat/start-first": "vignette-formats, as_tibble, add, invariants", - "Config/autostyle/scope": "line_breaks", - "Config/autostyle/strict": "true", - "Config/autostyle/rmd": "false", - "Config/Needs/website": "tidyverse/tidytemplate", - "NeedsCompilation": "yes", - "Author": "Kirill Müller [aut, cre] (), Hadley Wickham [aut], Romain Francois [ctb], Jennifer Bryan [ctb], RStudio [cph, fnd]", - "Maintainer": "Kirill Müller ", - "Repository": "RSPM" - }, - "tidyr": { - "Package": "tidyr", - "Version": "1.3.1", - "Source": "Repository", - "Title": "Tidy Messy Data", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = \"aut\"), person(\"Maximilian\", \"Girlich\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevin@posit.co\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Tools to help to create tidy data, where each column is a variable, each row is an observation, and each cell contains a single value. 'tidyr' contains tools for changing the shape (pivoting) and hierarchy (nesting and 'unnesting') of a dataset, turning deeply nested lists into rectangular data frames ('rectangling'), and extracting values out of string columns. It also includes tools for working with missing values (both implicit and explicit).", - "License": "MIT + file LICENSE", - "URL": "https://tidyr.tidyverse.org, https://github.com/tidyverse/tidyr", - "BugReports": "https://github.com/tidyverse/tidyr/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "cli (>= 3.4.1)", - "dplyr (>= 1.0.10)", - "glue", - "lifecycle (>= 1.0.3)", - "magrittr", - "purrr (>= 1.0.1)", - "rlang (>= 1.1.1)", - "stringr (>= 1.5.0)", - "tibble (>= 2.1.1)", - "tidyselect (>= 1.2.0)", - "utils", - "vctrs (>= 0.5.2)" - ], - "Suggests": [ - "covr", - "data.table", - "knitr", - "readr", - "repurrrsive (>= 1.1.0)", - "rmarkdown", - "testthat (>= 3.0.0)" - ], - "LinkingTo": [ - "cpp11 (>= 0.4.0)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "LazyData": "true", - "RoxygenNote": "7.3.0", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre], Davis Vaughan [aut], Maximilian Girlich [aut], Kevin Ushey [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "tidyselect": { - "Package": "tidyselect", - "Version": "1.2.1", - "Source": "Repository", - "Title": "Select from a Set of Strings", - "Authors@R": "c( person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A backend for the selecting functions of the 'tidyverse'. It makes it easy to implement select-like functions in your own packages in a way that is consistent with other 'tidyverse' interfaces for selection.", - "License": "MIT + file LICENSE", - "URL": "https://tidyselect.r-lib.org, https://github.com/r-lib/tidyselect", - "BugReports": "https://github.com/r-lib/tidyselect/issues", - "Depends": [ - "R (>= 3.4)" - ], - "Imports": [ - "cli (>= 3.3.0)", - "glue (>= 1.3.0)", - "lifecycle (>= 1.0.3)", - "rlang (>= 1.0.4)", - "vctrs (>= 0.5.2)", - "withr" - ], - "Suggests": [ - "covr", - "crayon", - "dplyr", - "knitr", - "magrittr", - "rmarkdown", - "stringr", - "testthat (>= 3.1.1)", - "tibble (>= 2.1.3)" - ], - "VignetteBuilder": "knitr", - "ByteCompile": "true", - "Config/testthat/edition": "3", - "Config/Needs/website": "tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.0.9000", - "NeedsCompilation": "yes", - "Author": "Lionel Henry [aut, cre], Hadley Wickham [aut], Posit Software, PBC [cph, fnd]", - "Maintainer": "Lionel Henry ", - "Repository": "RSPM" - }, - "tinytex": { - "Package": "tinytex", - "Version": "0.54", - "Source": "Repository", - "Type": "Package", - "Title": "Helper Functions to Install and Maintain TeX Live, and Compile LaTeX Documents", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\", \"cph\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(given = \"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"Christophe\", \"Dervieux\", role = \"ctb\", comment = c(ORCID = \"0000-0003-4474-2498\")), person(\"Devon\", \"Ryan\", role = \"ctb\", email = \"dpryan79@gmail.com\", comment = c(ORCID = \"0000-0002-8549-0971\")), person(\"Ethan\", \"Heinzen\", role = \"ctb\"), person(\"Fernando\", \"Cagua\", role = \"ctb\"), person() )", - "Description": "Helper functions to install and maintain the 'LaTeX' distribution named 'TinyTeX' (), a lightweight, cross-platform, portable, and easy-to-maintain version of 'TeX Live'. This package also contains helper functions to compile 'LaTeX' documents, and install missing 'LaTeX' packages automatically.", - "Imports": [ - "xfun (>= 0.48)" - ], - "Suggests": [ - "testit", - "rstudioapi" - ], - "License": "MIT + file LICENSE", - "URL": "https://github.com/rstudio/tinytex", - "BugReports": "https://github.com/rstudio/tinytex/issues", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "NeedsCompilation": "no", - "Author": "Yihui Xie [aut, cre, cph] (), Posit Software, PBC [cph, fnd], Christophe Dervieux [ctb] (), Devon Ryan [ctb] (), Ethan Heinzen [ctb], Fernando Cagua [ctb]", - "Maintainer": "Yihui Xie ", - "Repository": "CRAN" - }, - "tzdb": { - "Package": "tzdb", - "Version": "0.4.0", - "Source": "Repository", - "Title": "Time Zone Database Information", - "Authors@R": "c( person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = c(\"aut\", \"cre\")), person(\"Howard\", \"Hinnant\", role = \"cph\", comment = \"Author of the included date library\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Provides an up-to-date copy of the Internet Assigned Numbers Authority (IANA) Time Zone Database. It is updated periodically to reflect changes made by political bodies to time zone boundaries, UTC offsets, and daylight saving time rules. Additionally, this package provides a C++ interface for working with the 'date' library. 'date' provides comprehensive support for working with dates and date-times, which this package exposes to make it easier for other R packages to utilize. Headers are provided for calendar specific calculations, along with a limited interface for time zone manipulations.", - "License": "MIT + file LICENSE", - "URL": "https://tzdb.r-lib.org, https://github.com/r-lib/tzdb", - "BugReports": "https://github.com/r-lib/tzdb/issues", - "Depends": [ - "R (>= 3.5.0)" - ], - "Suggests": [ - "covr", - "testthat (>= 3.0.0)" - ], - "LinkingTo": [ - "cpp11 (>= 0.4.2)" - ], - "Biarch": "yes", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Davis Vaughan [aut, cre], Howard Hinnant [cph] (Author of the included date library), Posit Software, PBC [cph, fnd]", - "Maintainer": "Davis Vaughan ", - "Repository": "RSPM" - }, - "utf8": { - "Package": "utf8", - "Version": "1.2.4", - "Source": "Repository", - "Title": "Unicode Text Processing", - "Authors@R": "c(person(given = c(\"Patrick\", \"O.\"), family = \"Perry\", role = c(\"aut\", \"cph\")), person(given = \"Kirill\", family = \"M\\u00fcller\", role = \"cre\", email = \"kirill@cynkra.com\"), person(given = \"Unicode, Inc.\", role = c(\"cph\", \"dtc\"), comment = \"Unicode Character Database\"))", - "Description": "Process and print 'UTF-8' encoded international text (Unicode). Input, validate, normalize, encode, format, and display.", - "License": "Apache License (== 2.0) | file LICENSE", - "URL": "https://ptrckprry.com/r-utf8/, https://github.com/patperry/r-utf8", - "BugReports": "https://github.com/patperry/r-utf8/issues", - "Depends": [ - "R (>= 2.10)" - ], - "Suggests": [ - "cli", - "covr", - "knitr", - "rlang", - "rmarkdown", - "testthat (>= 3.0.0)", - "withr" - ], - "VignetteBuilder": "knitr, rmarkdown", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Patrick O. Perry [aut, cph], Kirill Müller [cre], Unicode, Inc. [cph, dtc] (Unicode Character Database)", - "Maintainer": "Kirill Müller ", - "Repository": "RSPM" - }, - "uuid": { - "Package": "uuid", - "Version": "1.2-1", - "Source": "Repository", - "Title": "Tools for Generating and Handling of UUIDs", - "Author": "Simon Urbanek [aut, cre, cph] (https://urbanek.org, ), Theodore Ts'o [aut, cph] (libuuid)", - "Maintainer": "Simon Urbanek ", - "Authors@R": "c(person(\"Simon\", \"Urbanek\", role=c(\"aut\",\"cre\",\"cph\"), email=\"Simon.Urbanek@r-project.org\", comment=c(\"https://urbanek.org\", ORCID=\"0000-0003-2297-1732\")), person(\"Theodore\",\"Ts'o\", email=\"tytso@thunk.org\", role=c(\"aut\",\"cph\"), comment=\"libuuid\"))", - "Depends": [ - "R (>= 2.9.0)" - ], - "Description": "Tools for generating and handling of UUIDs (Universally Unique Identifiers).", - "License": "MIT + file LICENSE", - "URL": "https://www.rforge.net/uuid", - "BugReports": "https://github.com/s-u/uuid/issues", - "NeedsCompilation": "yes", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "vctrs": { - "Package": "vctrs", - "Version": "0.6.5", - "Source": "Repository", - "Title": "Vector Helpers", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = \"aut\"), person(\"Davis\", \"Vaughan\", , \"davis@posit.co\", role = c(\"aut\", \"cre\")), person(\"data.table team\", role = \"cph\", comment = \"Radix sort based on data.table's forder() and their contribution to R's order()\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Defines new notions of prototype and size that are used to provide tools for consistent and well-founded type-coercion and size-recycling, and are in turn connected to ideas of type- and size-stability useful for analysing function interfaces.", - "License": "MIT + file LICENSE", - "URL": "https://vctrs.r-lib.org/, https://github.com/r-lib/vctrs", - "BugReports": "https://github.com/r-lib/vctrs/issues", - "Depends": [ - "R (>= 3.5.0)" - ], - "Imports": [ - "cli (>= 3.4.0)", - "glue", - "lifecycle (>= 1.0.3)", - "rlang (>= 1.1.0)" - ], - "Suggests": [ - "bit64", - "covr", - "crayon", - "dplyr (>= 0.8.5)", - "generics", - "knitr", - "pillar (>= 1.4.4)", - "pkgdown (>= 2.0.1)", - "rmarkdown", - "testthat (>= 3.0.0)", - "tibble (>= 3.1.3)", - "waldo (>= 0.2.0)", - "withr", - "xml2", - "zeallot" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "Language": "en-GB", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut], Lionel Henry [aut], Davis Vaughan [aut, cre], data.table team [cph] (Radix sort based on data.table's forder() and their contribution to R's order()), Posit Software, PBC [cph, fnd]", - "Maintainer": "Davis Vaughan ", - "Repository": "RSPM" - }, - "viridisLite": { - "Package": "viridisLite", - "Version": "0.4.2", - "Source": "Repository", - "Type": "Package", - "Title": "Colorblind-Friendly Color Maps (Lite Version)", - "Date": "2023-05-02", - "Authors@R": "c( person(\"Simon\", \"Garnier\", email = \"garnier@njit.edu\", role = c(\"aut\", \"cre\")), person(\"Noam\", \"Ross\", email = \"noam.ross@gmail.com\", role = c(\"ctb\", \"cph\")), person(\"Bob\", \"Rudis\", email = \"bob@rud.is\", role = c(\"ctb\", \"cph\")), person(\"Marco\", \"Sciaini\", email = \"sciaini.marco@gmail.com\", role = c(\"ctb\", \"cph\")), person(\"Antônio Pedro\", \"Camargo\", role = c(\"ctb\", \"cph\")), person(\"Cédric\", \"Scherer\", email = \"scherer@izw-berlin.de\", role = c(\"ctb\", \"cph\")) )", - "Maintainer": "Simon Garnier ", - "Description": "Color maps designed to improve graph readability for readers with common forms of color blindness and/or color vision deficiency. The color maps are also perceptually-uniform, both in regular form and also when converted to black-and-white for printing. This is the 'lite' version of the 'viridis' package that also contains 'ggplot2' bindings for discrete and continuous color and fill scales and can be found at .", - "License": "MIT + file LICENSE", - "Encoding": "UTF-8", - "Depends": [ - "R (>= 2.10)" - ], - "Suggests": [ - "hexbin (>= 1.27.0)", - "ggplot2 (>= 1.0.1)", - "testthat", - "covr" - ], - "URL": "https://sjmgarnier.github.io/viridisLite/, https://github.com/sjmgarnier/viridisLite/", - "BugReports": "https://github.com/sjmgarnier/viridisLite/issues/", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "no", - "Author": "Simon Garnier [aut, cre], Noam Ross [ctb, cph], Bob Rudis [ctb, cph], Marco Sciaini [ctb, cph], Antônio Pedro Camargo [ctb, cph], Cédric Scherer [ctb, cph]", - "Repository": "CRAN" - }, - "vroom": { - "Package": "vroom", - "Version": "1.6.5", - "Source": "Repository", - "Title": "Read and Write Rectangular Text Data Quickly", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\", comment = c(ORCID = \"0000-0002-2739-7082\")), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\", comment = c(ORCID = \"0000-0003-4757-117X\")), person(\"Jennifer\", \"Bryan\", , \"jenny@posit.co\", role = c(\"aut\", \"cre\"), comment = c(ORCID = \"0000-0002-6983-2759\")), person(\"Shelby\", \"Bearrows\", role = \"ctb\"), person(\"https://github.com/mandreyel/\", role = \"cph\", comment = \"mio library\"), person(\"Jukka\", \"Jylänki\", role = \"cph\", comment = \"grisu3 implementation\"), person(\"Mikkel\", \"Jørgensen\", role = \"cph\", comment = \"grisu3 implementation\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "The goal of 'vroom' is to read and write data (like 'csv', 'tsv' and 'fwf') quickly. When reading it uses a quick initial indexing step, then reads the values lazily , so only the data you actually use needs to be read. The writer formats the data in parallel and writes to disk asynchronously from formatting.", - "License": "MIT + file LICENSE", - "URL": "https://vroom.r-lib.org, https://github.com/tidyverse/vroom", - "BugReports": "https://github.com/tidyverse/vroom/issues", - "Depends": [ - "R (>= 3.6)" - ], - "Imports": [ - "bit64", - "cli (>= 3.2.0)", - "crayon", - "glue", - "hms", - "lifecycle (>= 1.0.3)", - "methods", - "rlang (>= 0.4.2)", - "stats", - "tibble (>= 2.0.0)", - "tidyselect", - "tzdb (>= 0.1.1)", - "vctrs (>= 0.2.0)", - "withr" - ], - "Suggests": [ - "archive", - "bench (>= 1.1.0)", - "covr", - "curl", - "dplyr", - "forcats", - "fs", - "ggplot2", - "knitr", - "patchwork", - "prettyunits", - "purrr", - "rmarkdown", - "rstudioapi", - "scales", - "spelling", - "testthat (>= 2.1.0)", - "tidyr", - "utils", - "waldo", - "xml2" - ], - "LinkingTo": [ - "cpp11 (>= 0.2.0)", - "progress (>= 1.2.1)", - "tzdb (>= 0.1.1)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "nycflights13, tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Config/testthat/parallel": "false", - "Copyright": "file COPYRIGHTS", - "Encoding": "UTF-8", - "Language": "en-US", - "RoxygenNote": "7.2.3.9000", - "NeedsCompilation": "yes", - "Author": "Jim Hester [aut] (), Hadley Wickham [aut] (), Jennifer Bryan [aut, cre] (), Shelby Bearrows [ctb], https://github.com/mandreyel/ [cph] (mio library), Jukka Jylänki [cph] (grisu3 implementation), Mikkel Jørgensen [cph] (grisu3 implementation), Posit Software, PBC [cph, fnd]", - "Maintainer": "Jennifer Bryan ", - "Repository": "RSPM" - }, - "withr": { - "Package": "withr", - "Version": "3.0.2", - "Source": "Repository", - "Title": "Run Code 'With' Temporarily Modified Global State", - "Authors@R": "c( person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Lionel\", \"Henry\", , \"lionel@posit.co\", role = c(\"aut\", \"cre\")), person(\"Kirill\", \"Müller\", , \"krlmlr+r@mailbox.org\", role = \"aut\"), person(\"Kevin\", \"Ushey\", , \"kevinushey@gmail.com\", role = \"aut\"), person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = \"aut\"), person(\"Winston\", \"Chang\", role = \"aut\"), person(\"Jennifer\", \"Bryan\", role = \"ctb\"), person(\"Richard\", \"Cotton\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "A set of functions to run code 'with' safely and temporarily modified global state. Many of these functions were originally a part of the 'devtools' package, this provides a simple package with limited dependencies to provide access to these functions.", - "License": "MIT + file LICENSE", - "URL": "https://withr.r-lib.org, https://github.com/r-lib/withr#readme", - "BugReports": "https://github.com/r-lib/withr/issues", - "Depends": [ - "R (>= 3.6.0)" - ], - "Imports": [ - "graphics", - "grDevices" - ], - "Suggests": [ - "callr", - "DBI", - "knitr", - "methods", - "rlang", - "rmarkdown (>= 2.12)", - "RSQLite", - "testthat (>= 3.0.0)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "Collate": "'aaa.R' 'collate.R' 'connection.R' 'db.R' 'defer-exit.R' 'standalone-defer.R' 'defer.R' 'devices.R' 'local_.R' 'with_.R' 'dir.R' 'env.R' 'file.R' 'language.R' 'libpaths.R' 'locale.R' 'makevars.R' 'namespace.R' 'options.R' 'par.R' 'path.R' 'rng.R' 'seed.R' 'wrap.R' 'sink.R' 'tempfile.R' 'timezone.R' 'torture.R' 'utils.R' 'with.R'", - "NeedsCompilation": "no", - "Author": "Jim Hester [aut], Lionel Henry [aut, cre], Kirill Müller [aut], Kevin Ushey [aut], Hadley Wickham [aut], Winston Chang [aut], Jennifer Bryan [ctb], Richard Cotton [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Lionel Henry ", - "Repository": "CRAN" - }, - "xfun": { - "Package": "xfun", - "Version": "0.50", - "Source": "Repository", - "Type": "Package", - "Title": "Supporting Functions for Packages Maintained by 'Yihui Xie'", - "Authors@R": "c( person(\"Yihui\", \"Xie\", role = c(\"aut\", \"cre\", \"cph\"), email = \"xie@yihui.name\", comment = c(ORCID = \"0000-0003-0645-5666\")), person(\"Wush\", \"Wu\", role = \"ctb\"), person(\"Daijiang\", \"Li\", role = \"ctb\"), person(\"Xianying\", \"Tan\", role = \"ctb\"), person(\"Salim\", \"Brüggemann\", role = \"ctb\", email = \"salim-b@pm.me\", comment = c(ORCID = \"0000-0002-5329-5987\")), person(\"Christophe\", \"Dervieux\", role = \"ctb\"), person() )", - "Description": "Miscellaneous functions commonly used in other packages maintained by 'Yihui Xie'.", - "Depends": [ - "R (>= 3.2.0)" - ], - "Imports": [ - "grDevices", - "stats", - "tools" - ], - "Suggests": [ - "testit", - "parallel", - "codetools", - "methods", - "rstudioapi", - "tinytex (>= 0.30)", - "mime", - "litedown (>= 0.4)", - "commonmark", - "knitr (>= 1.47)", - "remotes", - "pak", - "rhub", - "renv", - "curl", - "xml2", - "jsonlite", - "magick", - "yaml", - "qs", - "rmarkdown" - ], - "License": "MIT + file LICENSE", - "URL": "https://github.com/yihui/xfun", - "BugReports": "https://github.com/yihui/xfun/issues", - "Encoding": "UTF-8", - "RoxygenNote": "7.3.2", - "VignetteBuilder": "litedown", - "NeedsCompilation": "yes", - "Author": "Yihui Xie [aut, cre, cph] (), Wush Wu [ctb], Daijiang Li [ctb], Xianying Tan [ctb], Salim Brüggemann [ctb] (), Christophe Dervieux [ctb]", - "Maintainer": "Yihui Xie ", - "Repository": "CRAN" - }, - "xml2": { - "Package": "xml2", - "Version": "1.3.6", - "Source": "Repository", - "Title": "Parse XML", - "Authors@R": "c( person(\"Hadley\", \"Wickham\", , \"hadley@posit.co\", role = c(\"aut\", \"cre\")), person(\"Jim\", \"Hester\", role = \"aut\"), person(\"Jeroen\", \"Ooms\", role = \"aut\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")), person(\"R Foundation\", role = \"ctb\", comment = \"Copy of R-project homepage cached as example\") )", - "Description": "Work with XML files using a simple, consistent interface. Built on top of the 'libxml2' C library.", - "License": "MIT + file LICENSE", - "URL": "https://xml2.r-lib.org/, https://github.com/r-lib/xml2", - "BugReports": "https://github.com/r-lib/xml2/issues", - "Depends": [ - "R (>= 3.6.0)" - ], - "Imports": [ - "cli", - "methods", - "rlang (>= 1.1.0)" - ], - "Suggests": [ - "covr", - "curl", - "httr", - "knitr", - "magrittr", - "mockery", - "rmarkdown", - "testthat (>= 3.0.0)" - ], - "VignetteBuilder": "knitr", - "Config/Needs/website": "tidyverse/tidytemplate", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "SystemRequirements": "libxml2: libxml2-dev (deb), libxml2-devel (rpm)", - "Collate": "'S4.R' 'as_list.R' 'xml_parse.R' 'as_xml_document.R' 'classes.R' 'format.R' 'import-standalone-obj-type.R' 'import-standalone-purrr.R' 'import-standalone-types-check.R' 'init.R' 'nodeset_apply.R' 'paths.R' 'utils.R' 'xml2-package.R' 'xml_attr.R' 'xml_children.R' 'xml_document.R' 'xml_find.R' 'xml_missing.R' 'xml_modify.R' 'xml_name.R' 'xml_namespaces.R' 'xml_node.R' 'xml_nodeset.R' 'xml_path.R' 'xml_schema.R' 'xml_serialize.R' 'xml_structure.R' 'xml_text.R' 'xml_type.R' 'xml_url.R' 'xml_write.R' 'zzz.R'", - "Config/testthat/edition": "3", - "NeedsCompilation": "yes", - "Author": "Hadley Wickham [aut, cre], Jim Hester [aut], Jeroen Ooms [aut], Posit Software, PBC [cph, fnd], R Foundation [ctb] (Copy of R-project homepage cached as example)", - "Maintainer": "Hadley Wickham ", - "Repository": "RSPM" - }, - "xtable": { - "Package": "xtable", - "Version": "1.8-4", - "Source": "Repository", - "Date": "2019-04-08", - "Title": "Export Tables to LaTeX or HTML", - "Authors@R": "c(person(\"David B.\", \"Dahl\", role=\"aut\"), person(\"David\", \"Scott\", role=c(\"aut\",\"cre\"), email=\"d.scott@auckland.ac.nz\"), person(\"Charles\", \"Roosen\", role=\"aut\"), person(\"Arni\", \"Magnusson\", role=\"aut\"), person(\"Jonathan\", \"Swinton\", role=\"aut\"), person(\"Ajay\", \"Shah\", role=\"ctb\"), person(\"Arne\", \"Henningsen\", role=\"ctb\"), person(\"Benno\", \"Puetz\", role=\"ctb\"), person(\"Bernhard\", \"Pfaff\", role=\"ctb\"), person(\"Claudio\", \"Agostinelli\", role=\"ctb\"), person(\"Claudius\", \"Loehnert\", role=\"ctb\"), person(\"David\", \"Mitchell\", role=\"ctb\"), person(\"David\", \"Whiting\", role=\"ctb\"), person(\"Fernando da\", \"Rosa\", role=\"ctb\"), person(\"Guido\", \"Gay\", role=\"ctb\"), person(\"Guido\", \"Schulz\", role=\"ctb\"), person(\"Ian\", \"Fellows\", role=\"ctb\"), person(\"Jeff\", \"Laake\", role=\"ctb\"), person(\"John\", \"Walker\", role=\"ctb\"), person(\"Jun\", \"Yan\", role=\"ctb\"), person(\"Liviu\", \"Andronic\", role=\"ctb\"), person(\"Markus\", \"Loecher\", role=\"ctb\"), person(\"Martin\", \"Gubri\", role=\"ctb\"), person(\"Matthieu\", \"Stigler\", role=\"ctb\"), person(\"Robert\", \"Castelo\", role=\"ctb\"), person(\"Seth\", \"Falcon\", role=\"ctb\"), person(\"Stefan\", \"Edwards\", role=\"ctb\"), person(\"Sven\", \"Garbade\", role=\"ctb\"), person(\"Uwe\", \"Ligges\", role=\"ctb\"))", - "Maintainer": "David Scott ", - "Imports": [ - "stats", - "utils" - ], - "Suggests": [ - "knitr", - "plm", - "zoo", - "survival" - ], - "VignetteBuilder": "knitr", - "Description": "Coerce data to LaTeX and HTML tables.", - "URL": "http://xtable.r-forge.r-project.org/", - "Depends": [ - "R (>= 2.10.0)" - ], - "License": "GPL (>= 2)", - "Repository": "RSPM", - "NeedsCompilation": "no", - "Author": "David B. Dahl [aut], David Scott [aut, cre], Charles Roosen [aut], Arni Magnusson [aut], Jonathan Swinton [aut], Ajay Shah [ctb], Arne Henningsen [ctb], Benno Puetz [ctb], Bernhard Pfaff [ctb], Claudio Agostinelli [ctb], Claudius Loehnert [ctb], David Mitchell [ctb], David Whiting [ctb], Fernando da Rosa [ctb], Guido Gay [ctb], Guido Schulz [ctb], Ian Fellows [ctb], Jeff Laake [ctb], John Walker [ctb], Jun Yan [ctb], Liviu Andronic [ctb], Markus Loecher [ctb], Martin Gubri [ctb], Matthieu Stigler [ctb], Robert Castelo [ctb], Seth Falcon [ctb], Stefan Edwards [ctb], Sven Garbade [ctb], Uwe Ligges [ctb]", - "Encoding": "UTF-8" - }, - "yaml": { - "Package": "yaml", - "Version": "2.3.10", - "Source": "Repository", - "Type": "Package", - "Title": "Methods to Convert R Data to YAML and Back", - "Date": "2024-07-22", - "Suggests": [ - "RUnit" - ], - "Author": "Shawn P Garbett [aut], Jeremy Stephens [aut, cre], Kirill Simonov [aut], Yihui Xie [ctb], Zhuoer Dong [ctb], Hadley Wickham [ctb], Jeffrey Horner [ctb], reikoch [ctb], Will Beasley [ctb], Brendan O'Connor [ctb], Gregory R. Warnes [ctb], Michael Quinn [ctb], Zhian N. Kamvar [ctb], Charlie Gao [ctb]", - "Maintainer": "Shawn Garbett ", - "License": "BSD_3_clause + file LICENSE", - "Description": "Implements the 'libyaml' 'YAML' 1.1 parser and emitter () for R.", - "URL": "https://github.com/vubiostat/r-yaml/", - "BugReports": "https://github.com/vubiostat/r-yaml/issues", - "NeedsCompilation": "yes", - "Repository": "RSPM", - "Encoding": "UTF-8" - }, - "zip": { - "Package": "zip", - "Version": "2.3.2", - "Source": "Repository", - "Title": "Cross-Platform 'zip' Compression", - "Authors@R": "c( person(\"Gábor\", \"Csárdi\", , \"csardi.gabor@gmail.com\", role = c(\"aut\", \"cre\")), person(\"Kuba\", \"Podgórski\", role = \"ctb\"), person(\"Rich\", \"Geldreich\", role = \"ctb\"), person(\"Posit Software, PBC\", role = c(\"cph\", \"fnd\")) )", - "Description": "Cross-Platform 'zip' Compression Library. A replacement for the 'zip' function, that does not require any additional external tools on any platform.", - "License": "MIT + file LICENSE", - "URL": "https://github.com/r-lib/zip, https://r-lib.github.io/zip/", - "BugReports": "https://github.com/r-lib/zip/issues", - "Suggests": [ - "covr", - "pillar", - "processx", - "R6", - "testthat", - "withr" - ], - "Config/Needs/website": "tidyverse/tidytemplate", - "Config/testthat/edition": "3", - "Encoding": "UTF-8", - "RoxygenNote": "7.2.3", - "NeedsCompilation": "yes", - "Author": "Gábor Csárdi [aut, cre], Kuba Podgórski [ctb], Rich Geldreich [ctb], Posit Software, PBC [cph, fnd]", - "Maintainer": "Gábor Csárdi ", - "Repository": "CRAN" - } - } -} diff --git a/inst/triggerTooltips/triggerTooltips.css b/inst/triggerTooltips/triggerTooltips.css deleted file mode 100644 index 5d639532b..000000000 --- a/inst/triggerTooltips/triggerTooltips.css +++ /dev/null @@ -1,43 +0,0 @@ -.teal-modules-general.trigger-tooltips-button { - border: none; - background: white; - opacity: 0.2; -} - -.teal-modules-general.trigger-tooltips-button:hover { - opacity: 0.6; -} - -.teal-modules-general.trigger-tooltips-button i { - font-size: 0.85em; -} - -.teal-modules-general.trigger-tooltips-button { - position: relative; -} - -.teal-modules-general.trigger-tooltips-button > .plotly-icon-tooltip { - visibility: hidden; - position: absolute; - top: 125%; - right: 0; - transform: translateX(0); - background: #121f3d; - color: #fff; - padding: 6px 10px; - border-radius: 3px; - z-index: 1000; - font-size: 12px; -} - -.teal-modules-general.trigger-tooltips-button:hover > .plotly-icon-tooltip { - visibility: visible; - opacity: 1; -} - -.teal-modules-general.trigger-tooltips-button > .plotly-icon-tooltip::after { - content: ""; - position: absolute; - bottom: 100%; - right: 10px; -} diff --git a/inst/triggerTooltips/triggerTooltips.js b/inst/triggerTooltips/triggerTooltips.js deleted file mode 100644 index 3ac743769..000000000 --- a/inst/triggerTooltips/triggerTooltips.js +++ /dev/null @@ -1,31 +0,0 @@ -triggerTooltips = function (message) { - const plotElement = document.getElementById(message.plotID); - const hoverPoints = message.tooltipPoints.map((point) => ({ - curveNumber: point.curve || 0, - pointNumber: point.index, - })); - Plotly.Fx.hover(plotElement, hoverPoints); -}; - -Shiny.addCustomMessageHandler("triggerTooltips", triggerTooltips); - -function triggerSelectedTooltips(plotID) { - const plotElement = document.getElementById(plotID); - const tooltipPoints = []; - - plotElement.data.forEach((trace, curveIndex) => { - if (trace.selectedpoints && Array.isArray(trace.selectedpoints)) { - trace.selectedpoints.forEach((pointIndex) => { - tooltipPoints.push({ - curve: curveIndex, - index: pointIndex, - }); - }); - } - }); - - triggerTooltips({ - plotID: plotID, - tooltipPoints: tooltipPoints, - }); -} diff --git a/man/dot-color_palette_discrete.Rd b/man/dot-color_palette_discrete.Rd deleted file mode 100644 index c1b3ef4b1..000000000 --- a/man/dot-color_palette_discrete.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module_colur_picker.R -\name{.color_palette_discrete} -\alias{.color_palette_discrete} -\title{Color palette discrete} -\usage{ -.color_palette_discrete(levels, color) -} -\arguments{ -\item{levels}{(\code{character}) values of possible variable levels} - -\item{color}{(\verb{named character}) valid color names (see \code{\link[=colors]{colors()}}) or hex-colors named by \code{levels}.} -} -\value{ -\code{character} with hex colors named by \code{levels}. -} -\description{ -To specify custom discrete colors to \code{plotly} or \code{ggplot} elements one needs to specify a vector named by -levels of variable used for coloring. This function allows to specify only some or none of the colors/levels -as the rest will be filled automatically. -} diff --git a/man/dot-make_reactable_columns_call.Rd b/man/dot-make_reactable_columns_call.Rd deleted file mode 100644 index 079641f10..000000000 --- a/man/dot-make_reactable_columns_call.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_t_reactable.R -\name{.make_reactable_columns_call} -\alias{.make_reactable_columns_call} -\title{Makes \code{reactable::colDef} call containing: -name = \if{html}{\out{}} -cell = \if{html}{\out{}} -Arguments of \code{\link[reactable:colDef]{reactable::colDef()}} are specified only if necessary} -\usage{ -.make_reactable_columns_call(dataset, col_defs) -} -\arguments{ -\item{dataset}{(\code{data.frame})} -} -\value{ -named list of \code{colDef} calls -} -\description{ -Makes \code{reactable::colDef} call containing: -name = \if{html}{\out{}} -cell = \if{html}{\out{}} -Arguments of \code{\link[reactable:colDef]{reactable::colDef()}} are specified only if necessary -} -\keyword{internal} diff --git a/man/dot-plotly_selected_filter_children.Rd b/man/dot-plotly_selected_filter_children.Rd deleted file mode 100644 index b6531a345..000000000 --- a/man/dot-plotly_selected_filter_children.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/utils.R -\name{.plotly_selected_filter_children} -\alias{.plotly_selected_filter_children} -\title{Filter children on \code{plotly_selected}} -\usage{ -.plotly_selected_filter_children( - data, - plot_dataname, - xvar, - yvar, - plotly_selected, - children_datanames -) -} -\arguments{ -\item{data}{(\verb{reactive teal_data})} - -\item{plot_dataname}{(\code{character(1)})} - -\item{xvar}{(\code{character(1)})} - -\item{yvar}{(\code{character(1)})} - -\item{plotly_selected}{(\code{reactive})} - -\item{children_datanames}{(\code{character})} -} -\description{ -Filters children datanames according to: -\itemize{ -\item selected x and y values on the plot (based on the parent dataset) -\item \code{\link[teal.data:join_keys]{teal.data::join_keys}} relationship between \code{children_datanames} -} -} diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd deleted file mode 100644 index 6257d9d2f..000000000 --- a/man/tm_t_reactables.Rd +++ /dev/null @@ -1,41 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/tm_t_reactable.R -\name{tm_t_reactables} -\alias{tm_t_reactables} -\title{\code{teal} module: Reactable} -\usage{ -tm_t_reactables( - label = "Table", - datanames = "all", - colnames = list(), - transformators = list(), - decorators = list(), - reactable_args = list() -) -} -\arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module or module group. -For \code{modules()} defaults to \code{"root"}. See \code{Details}.} - -\item{datanames}{(\code{character}) Names of the datasets relevant to the item. -There are 2 reserved values that have specific behaviors: -\itemize{ -\item The keyword \code{"all"} includes all datasets available in the data passed to the teal application. -\item \code{NULL} hides the sidebar panel completely. -\item If \code{transformators} are specified, their \code{datanames} are automatically added to this \code{datanames} -argument. -}} - -\item{transformators}{(\code{list} of \code{teal_transform_module}) that will be applied to transform module's data input. -To learn more check \code{vignette("transform-input-data", package = "teal")}.} - -\item{decorators}{\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} -(named \code{list} of lists of \code{teal_transform_module}) optional, -decorator for tables or plots included in the module output reported. -The decorators are applied to the respective output objects.} - -\item{reactable_args}{(\code{list}) any argument of \code{\link[reactable:reactable]{reactable::reactable()}}.} -} -\description{ -Wrapper module on \code{\link[reactable:reactable]{reactable::reactable()}} -} From 5cf93d7be00fcf3d35639f05e09a0e070c38300b Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 3 Nov 2025 09:51:49 +0100 Subject: [PATCH 152/158] remove values() after variables(multiple = TRUE) --- R/tm_a_regression.R | 3 +-- R/tm_g_scatterplot_picks.R | 8 +++----- R/tm_t_crosstable.R | 3 +-- R/tm_t_crosstable_picks.R | 3 +-- man/tm_a_regression.Rd | 2 +- man/tm_t_crosstable.Rd | 2 +- 6 files changed, 8 insertions(+), 13 deletions(-) diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index a793a2fda..2ec52c996 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -148,8 +148,7 @@ tm_a_regression <- function(label = "Regression Analysis", choices = is.numeric, selected = tidyselect::last_col(), multiple = TRUE - ), - teal.transform::values() + ) ), response, plot_height = c(600, 200, 2000), diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index 4a3b883e5..2f87ec128 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -16,17 +16,15 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", choices = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = NULL, multiple = TRUE - ), - teal.transform::values() + ) ), size_by = teal.transform::picks( teal.transform::datasets(), teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + choices = is.numeric, selected = NULL, multiple = TRUE - ), - teal.transform::values() + ) ), row_facet = teal.transform::picks( teal.transform::datasets(), diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index ae64b892b..1f20965be 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -169,8 +169,7 @@ tm_t_crosstable <- function(label = "Cross Table", teal.transform::variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple = TRUE, ordered = TRUE - ), - teal.transform::values() + ) ), y, show_percentage = TRUE, diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index cc6db627a..91bd86516 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -5,8 +5,7 @@ tm_t_crosstable.picks <- function(label = "Cross Table", teal.transform::variables( choices = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple = TRUE, ordered = TRUE - ), - teal.transform::values() + ) ), y = teal.transform::picks( teal.transform::datasets(), diff --git a/man/tm_a_regression.Rd b/man/tm_a_regression.Rd index 18a53477b..5ebd6b175 100644 --- a/man/tm_a_regression.Rd +++ b/man/tm_a_regression.Rd @@ -8,7 +8,7 @@ tm_a_regression( label = "Regression Analysis", regressor = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices = is.numeric, selected = tidyselect::last_col(), - multiple = TRUE), teal.transform::values()), + multiple = TRUE)), response, plot_height = c(600, 200, 2000), plot_width = NULL, diff --git a/man/tm_t_crosstable.Rd b/man/tm_t_crosstable.Rd index ccce911e0..9f7f3f48c 100644 --- a/man/tm_t_crosstable.Rd +++ b/man/tm_t_crosstable.Rd @@ -8,7 +8,7 @@ tm_t_crosstable( label = "Cross Table", x = teal.transform::picks(teal.transform::datasets(), teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple - = TRUE, ordered = TRUE), teal.transform::values()), + = TRUE, ordered = TRUE)), y, show_percentage = TRUE, show_total = TRUE, From 2556faea2c8bcb2eaf80a4f76204623693f94a55 Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 3 Nov 2025 11:22:24 +0100 Subject: [PATCH 153/158] remove values() after variables(multiple = TRUE) --- R/tm_a_regression_picks.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 7ff277c3b..23d5d5f83 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -6,8 +6,7 @@ tm_a_regression.picks <- function(label = "Regression Analysis", choices = is.numeric, selected = tidyselect::last_col(), multiple = TRUE - ), - teal.transform::values() + ) ), response = teal.transform::picks( teal.transform::datasets(), From b092e25274912f9c472ed2032fafeeb1732ae17c Mon Sep 17 00:00:00 2001 From: Dawid Kaledkowski Date: Mon, 3 Nov 2025 11:46:24 +0100 Subject: [PATCH 154/158] revert unnecessary differences with main --- R/plotly_with_settings.R | 10 ------- R/roxygen2_templates.R | 52 ---------------------------------- R/utils.R | 61 ++++++++++++++++++++++++++++++++++------ 3 files changed, 52 insertions(+), 71 deletions(-) delete mode 100644 R/plotly_with_settings.R diff --git a/R/plotly_with_settings.R b/R/plotly_with_settings.R deleted file mode 100644 index b40414302..000000000 --- a/R/plotly_with_settings.R +++ /dev/null @@ -1,10 +0,0 @@ -plotly_with_settings_ui <- function(id, height) { - ns <- NS(id) - plotly::plotlyOutput(ns("plot"), height = height) -} - -plotly_with_settings_srv <- function(id, plot) { - moduleServer(id, function(input, output, session) { - output$plot <- plotly::renderPlotly(plot()) - }) -} diff --git a/R/roxygen2_templates.R b/R/roxygen2_templates.R index 7e928a97f..8ff396409 100644 --- a/R/roxygen2_templates.R +++ b/R/roxygen2_templates.R @@ -14,55 +14,3 @@ roxygen_ggplot2_args_param <- function(...) { } # nocov end - -#' Shared parameters documentation -#' -#' Defines common arguments shared across multiple functions in the package -#' to avoid repetition by using `inheritParams`. -#' -#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of -#' `value`, `min`, and `max` intended for use with a slider UI element. -#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of -#' `value`, `min`, and `max` for a slider encoding the plot width. -#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not -#' rotate by default (`FALSE`). -#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. -#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] -#' with settings for the module plot. -#' The argument is merged with options variable `teal.ggplot2_args` and default module setup. -#' -#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")` -#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] -#' with settings for the module table. -#' The argument is merged with options variable `teal.basic_table_args` and default module setup. -#' -#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")` -#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, -#' providing context or a title. -#' with text placed before the output to put the output into context. For example a title. -#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, -#' adding context or further instructions. Elements like `shiny::helpText()` are useful. -#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. -#' - When the length of `alpha` is one: the plot points will have a fixed opacity. -#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on -#' vector of `value`, `min`, and `max`. -#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. -#' - When the length of `size` is one: the plot point sizes will have a fixed size. -#' - When the length of `size` is three: the plot points size are dynamically adjusted based on -#' vector of `value`, `min`, and `max`. -#' @param decorators `r lifecycle::badge("experimental")` -#' (named `list` of lists of `teal_transform_module`) optional, -#' decorator for tables or plots included in the module output reported. -#' The decorators are applied to the respective output objects. -#' -#' @param table_datanames (`character`) names of the datasets which should be listed below the plot -#' when some data points are selected. Objects named after `table_datanames` will be pulled from -#' `data` so it is important that data actually contains these datasets. Please be aware that -#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. -#' See section "Decorating Module" below for more details. -#' -#' @return Object of class `teal_module` to be used in `teal` applications. -#' -#' @name shared_params -#' @keywords internal -NULL diff --git a/R/utils.R b/R/utils.R index 4fbe862eb..6c7f8365b 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,3 +1,55 @@ +#' Shared parameters documentation +#' +#' Defines common arguments shared across multiple functions in the package +#' to avoid repetition by using `inheritParams`. +#' +#' @param plot_height (`numeric`) optional, specifies the plot height as a three-element vector of +#' `value`, `min`, and `max` intended for use with a slider UI element. +#' @param plot_width (`numeric`) optional, specifies the plot width as a three-element vector of +#' `value`, `min`, and `max` for a slider encoding the plot width. +#' @param rotate_xaxis_labels (`logical`) optional, whether to rotate plot X axis labels. Does not +#' rotate by default (`FALSE`). +#' @param ggtheme (`character`) optional, `ggplot2` theme to be used by default. Defaults to `"gray"`. +#' @param ggplot2_args (`ggplot2_args`) object created by [teal.widgets::ggplot2_args()] +#' with settings for the module plot. +#' The argument is merged with options variable `teal.ggplot2_args` and default module setup. +#' +#' For more details see the vignette: `vignette("custom-ggplot2-arguments", package = "teal.widgets")` +#' @param basic_table_args (`basic_table_args`) object created by [teal.widgets::basic_table_args()] +#' with settings for the module table. +#' The argument is merged with options variable `teal.basic_table_args` and default module setup. +#' +#' For more details see the vignette: `vignette("custom-basic-table-arguments", package = "teal.widgets")` +#' @param pre_output (`shiny.tag`) optional, text or UI element to be displayed before the module's output, +#' providing context or a title. +#' with text placed before the output to put the output into context. For example a title. +#' @param post_output (`shiny.tag`) optional, text or UI element to be displayed after the module's output, +#' adding context or further instructions. Elements like `shiny::helpText()` are useful. +#' @param alpha (`integer(1)` or `integer(3)`) optional, specifies point opacity. +#' - When the length of `alpha` is one: the plot points will have a fixed opacity. +#' - When the length of `alpha` is three: the plot points opacity are dynamically adjusted based on +#' vector of `value`, `min`, and `max`. +#' @param size (`integer(1)` or `integer(3)`) optional, specifies point size. +#' - When the length of `size` is one: the plot point sizes will have a fixed size. +#' - When the length of `size` is three: the plot points size are dynamically adjusted based on +#' vector of `value`, `min`, and `max`. +#' @param decorators `r lifecycle::badge("experimental")` +#' (named `list` of lists of `teal_transform_module`) optional, +#' decorator for tables or plots included in the module output reported. +#' The decorators are applied to the respective output objects. +#' +#' @param table_datanames (`character`) names of the datasets which should be listed below the plot +#' when some data points are selected. Objects named after `table_datanames` will be pulled from +#' `data` so it is important that data actually contains these datasets. Please be aware that +#' table datasets must be linked with `plot_dataname` by the relevant [join_keys()]. +#' See section "Decorating Module" below for more details. +#' +#' @return Object of class `teal_module` to be used in `teal` applications. +#' +#' @name shared_params +#' @keywords internal +NULL + #' Add labels for facets to a `ggplot2` object #' #' Enhances a `ggplot2` plot by adding labels that describe @@ -411,12 +463,3 @@ set_chunk_dims <- function(pws, q_r, inner_classes = NULL) { q }) } - -.update_cs_input <- function(inputId, data, cs) { - if (!missing(data) && !length(names(cs))) { - labels <- teal.data::col_labels(isolate(data()))[cs$choices] - names(cs$choices) <- labels - } - updateSelectInput(inputId = inputId, choices = cs$choices, selected = cs$selected) - if (length(cs$choices) < 2) shinyjs::hide(inputId) -} From 8cbcebf6f921b3d87e1d1ae75f7cf8fc7b92c417 Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Mon, 3 Nov 2025 10:54:31 +0000 Subject: [PATCH 155/158] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/shared_params.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/shared_params.Rd b/man/shared_params.Rd index 6c0cbfe2a..1b0299286 100644 --- a/man/shared_params.Rd +++ b/man/shared_params.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/roxygen2_templates.R +% Please edit documentation in R/utils.R \name{shared_params} \alias{shared_params} \title{Shared parameters documentation} From 7e0558be0083a10b33659c3abd7f030ae9232513 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Mar 2026 14:40:05 +0100 Subject: [PATCH 156/158] change teal.transform to teal.picks in DESCRIPTION file --- DESCRIPTION | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 7ba3e4dea..3a6e93117 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,7 +27,7 @@ Depends: R (>= 4.1), shiny (>= 1.8.1), teal (>= 1.0.0.9003), - teal.transform (>= 0.7.0) + teal.picks (>= 0.1.0) Imports: bslib (>= 0.8.0), checkmate (>= 2.1.0), @@ -83,7 +83,7 @@ VignetteBuilder: rmarkdown Remotes: insightsengineering/teal@redesign_extraction@main, - insightsengineering/teal.transform@redesign_extraction@main + insightsengineering/teal.picks@redesign_extraction@main Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, From 81861472758b465316aca1839ee5fdd7dfbf0328 Mon Sep 17 00:00:00 2001 From: m7pr Date: Wed, 4 Mar 2026 16:25:58 +0100 Subject: [PATCH 157/158] change teal.transform:: to teal.picks:: --- DESCRIPTION | 6 ++- R/tm_a_pca.R | 14 +++--- R/tm_a_pca_picks.R | 10 ++-- R/tm_a_regression.R | 32 ++++++------- R/tm_a_regression_picks.R | 36 +++++++------- R/tm_g_association.R | 30 ++++++------ R/tm_g_association_picks.R | 28 +++++------ R/tm_g_bivariate.R | 56 +++++++++++----------- R/tm_g_bivariate_picks.R | 58 +++++++++++------------ R/tm_g_distribution.R | 26 +++++------ R/tm_g_distribution_picks.R | 40 ++++++++-------- R/tm_g_response.R | 28 +++++------ R/tm_g_response_picks.R | 56 +++++++++++----------- R/tm_g_scatterplot.R | 80 ++++++++++++++++---------------- R/tm_g_scatterplot_picks.R | 70 ++++++++++++++-------------- R/tm_g_scatterplotmatrix.R | 36 +++++++------- R/tm_g_scatterplotmatrix_picks.R | 12 ++--- R/tm_outliers.R | 20 ++++---- R/tm_t_crosstable.R | 34 +++++++------- R/tm_t_crosstable_picks.R | 28 +++++------ 20 files changed, 351 insertions(+), 349 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 3a6e93117..42a9584e6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -27,7 +27,8 @@ Depends: R (>= 4.1), shiny (>= 1.8.1), teal (>= 1.0.0.9003), - teal.picks (>= 0.1.0) + teal.picks (>= 0.1.0), + teal.transform (>= 0.7.0) Imports: bslib (>= 0.8.0), checkmate (>= 2.1.0), @@ -83,7 +84,8 @@ VignetteBuilder: rmarkdown Remotes: insightsengineering/teal@redesign_extraction@main, - insightsengineering/teal.picks@redesign_extraction@main + insightsengineering/teal.picks@redesign_extraction@main, + insightsengineering/teal.transform@redesign_extraction@main Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr, diff --git a/R/tm_a_pca.R b/R/tm_a_pca.R index ca2f0db06..3563c1e39 100644 --- a/R/tm_a_pca.R +++ b/R/tm_a_pca.R @@ -66,9 +66,9 @@ #' modules = modules( #' tm_a_pca( #' "PCA", -#' dat = teal.transform::picks( +#' dat = teal.picks::picks( #' datasets("USArrests"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("Murder", "Assault", "UrbanPop", "Rape"), #' selected = c("Murder", "Assault"), #' multiple = TRUE @@ -99,9 +99,9 @@ #' data = data, #' modules = modules( #' tm_a_pca( -#' dat = teal.transform::picks( +#' dat = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("BMRKR1", "AGE", "EOSDY"), #' selected = c("BMRKR1", "AGE"), #' multiple = TRUE @@ -117,9 +117,9 @@ #' @export #' tm_a_pca <- function(label = "Principal Component Analysis", - dat = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + dat = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), selected = tidyselect::everything(), multiple = TRUE diff --git a/R/tm_a_pca_picks.R b/R/tm_a_pca_picks.R index ec0fdd65e..fe4742dcd 100644 --- a/R/tm_a_pca_picks.R +++ b/R/tm_a_pca_picks.R @@ -1,8 +1,8 @@ #' @export tm_a_pca.picks <- function(label = "Principal Component Analysis", - dat = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + dat = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = tidyselect::where(~ is.numeric(.x) && all(!is.na(.x))), selected = tidyselect::everything(), multiple = TRUE @@ -124,7 +124,7 @@ ui_a_pca.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("Data selection"), - teal.transform::picks_ui(id = ns("dat"), picks = dat) + teal.picks::picks_ui(id = ns("dat"), picks = dat) ), bslib::accordion( open = TRUE, @@ -229,7 +229,7 @@ srv_a_pca.picks <- function(id, data, dat, plot_height, plot_width, ggplot2_args moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(picks = list(dat = dat), data = data) + selectors <- teal.picks::picks_srv(picks = list(dat = dat), data = data) qenv <- reactive({ validate_input( diff --git a/R/tm_a_regression.R b/R/tm_a_regression.R index 2ec52c996..fdc974e75 100644 --- a/R/tm_a_regression.R +++ b/R/tm_a_regression.R @@ -11,13 +11,13 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' @param regressor (`picks`) Specification for regressor variables selection. -#' Created using [teal.transform::picks()], which allows selecting variables -#' to use as regressors in the regression model. `teal.transform::variables(multiple = TRUE)` allowed. +#' Created using [teal.picks::picks()], which allows selecting variables +#' to use as regressors in the regression model. `teal.picks::variables(multiple = TRUE)` allowed. #' @param response (`picks`) Specification for response variable selection. -#' Created using [teal.transform::picks()], which allows selecting a single numeric variable -#' to use as the response in the regression model. `teal.transform::variables(multiple = TRUE)` not allowed. +#' Created using [teal.picks::picks()], which allows selecting a single numeric variable +#' to use as the response in the regression model. `teal.picks::variables(multiple = TRUE)` not allowed. #' @param outlier (`picks`) Optional specification for outlier label variable selection. -#' Created using [teal.transform::picks()], which allows selecting a factor or character variable +#' Created using [teal.picks::picks()], which allows selecting a factor or character variable #' to label outlier points on the plots. #' @param default_plot_type (`numeric`) optional, defaults to "Response vs Regressor". #' 1. Response vs Regressor @@ -91,13 +91,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = teal.transform::picks( +#' response = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(choices = "uptake", selected = "uptake") +#' teal.picks::variables(choices = "uptake", selected = "uptake") #' ), -#' regressor = teal.transform::picks( +#' regressor = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) +#' teal.picks::variables(choices = c("conc", "Treatment"), selected = "conc", multiple = TRUE) #' ) #' ) #' ) @@ -124,13 +124,13 @@ #' modules = modules( #' tm_a_regression( #' label = "Regression", -#' response = teal.transform::picks( +#' response = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = "BMRKR1", selected = "BMRKR1") +#' teal.picks::variables(choices = "BMRKR1", selected = "BMRKR1") #' ), -#' regressor = teal.transform::picks( +#' regressor = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) +#' teal.picks::variables(choices = c("AGE", "SEX", "RACE"), selected = "AGE", multiple = TRUE) #' ) #' ) #' ) @@ -142,9 +142,9 @@ #' @export #' tm_a_regression <- function(label = "Regression Analysis", - regressor = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + regressor = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric, selected = tidyselect::last_col(), multiple = TRUE diff --git a/R/tm_a_regression_picks.R b/R/tm_a_regression_picks.R index 23d5d5f83..efae14d30 100644 --- a/R/tm_a_regression_picks.R +++ b/R/tm_a_regression_picks.R @@ -1,23 +1,23 @@ #' @export tm_a_regression.picks <- function(label = "Regression Analysis", - regressor = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + regressor = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric, selected = tidyselect::last_col(), multiple = TRUE ) ), - response = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(choices = is.numeric), - teal.transform::values() + response = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(choices = is.numeric), + teal.picks::values() ), - outlier = teal.transform::picks( + outlier = teal.picks::picks( regressor$datasets, - teal.transform::variables(choices = tidyselect::where(~ is.factor(.) || is.character(.))), - teal.transform::values() - ), # default should be teal.transform::picks(datasets(), teal.transform::variables(primary_keys()) + teal.picks::variables(choices = tidyselect::where(~ is.factor(.) || is.character(.))), + teal.picks::values() + ), # default should be teal.picks::picks(datasets(), teal.picks::variables(primary_keys()) plot_height = c(600, 200, 2000), plot_width = NULL, alpha = c(1, 0, 1), @@ -39,12 +39,12 @@ tm_a_regression.picks <- function(label = "Regression Analysis", checkmate::assert_class(response, "picks") if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`response` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } checkmate::assert_class(outlier, "picks", null.ok = TRUE) if (isTRUE(attr(outlier$variables, "multiple"))) { - warning("`outlier` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`outlier` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(outlier$variables, "multiple") <- FALSE } @@ -146,11 +146,11 @@ ui_a_regression.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$br(), tags$div( tags$strong("Response variable"), - teal.transform::picks_ui(id = ns("response"), picks = response) + teal.picks::picks_ui(id = ns("response"), picks = response) ), tags$div( tags$strong("Regressor variables"), - teal.transform::picks_ui(id = ns("regressor"), picks = regressor) + teal.picks::picks_ui(id = ns("regressor"), picks = regressor) ), radioButtons( ns("plot_type"), @@ -179,7 +179,7 @@ ui_a_regression.picks <- function(id, ), min = 1, max = 10, value = 9, ticks = FALSE, step = .1 ), - teal.transform::picks_ui(id = ns("outlier"), picks = outlier) + teal.picks::picks_ui(id = ns("outlier"), picks = outlier) ), ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), bslib::accordion( @@ -242,7 +242,7 @@ srv_a_regression.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = list(response = response, regressor = regressor, outlier = outlier), data = data ) @@ -281,7 +281,7 @@ srv_a_regression.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") # sets qenv object and populates it with data merge call and fit expression fit_r <- reactive({ diff --git a/R/tm_g_association.R b/R/tm_g_association.R index d80f35b02..51f64f23d 100644 --- a/R/tm_g_association.R +++ b/R/tm_g_association.R @@ -11,9 +11,9 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' @param ref (`picks`) -#' Reference variable specification created using `teal.transform::picks()`. +#' Reference variable specification created using `teal.picks::picks()`. #' @param vars (`picks`) -#' Variables to be associated with the reference variable, specified using `teal.transform::picks()`. +#' Variables to be associated with the reference variable, specified using `teal.picks::picks()`. #' @param show_association (`logical`) optional, whether show association of `vars` #' with reference variable. Defaults to `TRUE`. #' @param distribution_theme,association_theme (`character`) optional, `ggplot2` themes to be used by default. @@ -67,16 +67,16 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = teal.transform::picks( +#' ref = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = "Plant" #' ) #' ), -#' vars = teal.transform::picks( +#' vars = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = "Treatment", #' multiple = TRUE @@ -106,16 +106,16 @@ #' data = data, #' modules = modules( #' tm_g_association( -#' ref = teal.transform::picks( +#' ref = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "RACE" #' ) #' ), -#' vars = teal.transform::picks( +#' vars = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("SEX", "RACE", "COUNTRY", "ARM", "STRATA1", "STRATA2", "ITTFL", "BMRKR2"), #' selected = "BMRKR2", #' multiple = TRUE @@ -130,14 +130,14 @@ #' #' @export tm_g_association <- function(label = "Association", - ref = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + ref = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - teal.transform::values() + teal.picks::values() ), vars, show_association = TRUE, diff --git a/R/tm_g_association_picks.R b/R/tm_g_association_picks.R index 4ba372ca7..3e97263ef 100644 --- a/R/tm_g_association_picks.R +++ b/R/tm_g_association_picks.R @@ -1,19 +1,19 @@ #' @export tm_g_association.picks <- function(label = "Association", - ref = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + ref = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - teal.transform::values() + teal.picks::values() ), - vars = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + vars = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 2L, multiple = TRUE ) @@ -37,7 +37,7 @@ tm_g_association.picks <- function(label = "Association", checkmate::assert_string(label) checkmate::assert_class(ref, "picks") if (isTRUE(attr(ref$variables, "multiple"))) { - warning("`ref` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`ref` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(ref$variables, "multiple") <- FALSE } checkmate::assert_class(vars, "picks") @@ -99,11 +99,11 @@ ui_g_association.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("Reference variable"), - teal.transform::picks_ui(id = ns("ref"), picks = ref) + teal.picks::picks_ui(id = ns("ref"), picks = ref) ), tags$div( tags$strong("Associated variables"), - teal.transform::picks_ui(id = ns("vars"), picks = vars) + teal.picks::picks_ui(id = ns("vars"), picks = vars) ), checkboxInput(ns("association"), "Association with reference variable", value = show_association), checkboxInput(ns("show_dist"), "Scaled frequencies", value = FALSE), @@ -154,7 +154,7 @@ srv_g_association.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(picks = list(ref = ref, vars = vars), data = data) + selectors <- teal.picks::picks_srv(picks = list(ref = ref, vars = vars), data = data) validated_q <- reactive({ obj <- req(data()) @@ -182,7 +182,7 @@ srv_g_association.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");library("tern");library("ggmosaic")') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") output_q <- reactive({ req(merged$data()) diff --git a/R/tm_g_bivariate.R b/R/tm_g_bivariate.R index f14d53f36..a513ad7c2 100644 --- a/R/tm_g_bivariate.R +++ b/R/tm_g_bivariate.R @@ -11,16 +11,16 @@ #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param x (`picks`) Variable specification for the x-axis. Created using [teal.transform::picks()]. +#' @param x (`picks`) Variable specification for the x-axis. Created using [teal.picks::picks()]. #' Can be numeric, factor or character. No empty selections are allowed. -#' @param y (`picks`) Variable specification for the y-axis. Created using [teal.transform::picks()]. +#' @param y (`picks`) Variable specification for the y-axis. Created using [teal.picks::picks()]. #' Can be numeric, factor or character. #' @param use_density (`logical`) optional, indicates whether to plot density (`TRUE`) or frequency (`FALSE`). #' Defaults to frequency (`FALSE`). #' @param row_facet (`picks`) optional, specification of the data variable(s) to use for faceting rows. -#' Created using [teal.transform::picks()]. +#' Created using [teal.picks::picks()]. #' @param col_facet (`picks`) optional, specification of the data variable(s) to use for faceting columns. -#' Created using [teal.transform::picks()]. +#' Created using [teal.picks::picks()]. #' @param facet (`logical`) optional, specifies whether the facet encodings `ui` elements are toggled #' on and shown to the user by default. Defaults to `TRUE` if either `row_facet` or `column_facet` #' are supplied. @@ -28,13 +28,13 @@ #' and `UI` tool offered to the user. #' @param color (`picks`) optional, specification of the data variable(s) selected for the outline color #' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. -#' Created using [teal.transform::picks()]. +#' Created using [teal.picks::picks()]. #' @param fill (`picks`) optional, specification of the data variable(s) selected for the fill color #' inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. -#' Created using [teal.transform::picks()]. +#' Created using [teal.picks::picks()]. #' @param size (`picks`) optional, specification of the data variable(s) selected for the size of #' `geom_point` plots inside the coloring settings. It will be applied when `color_settings` is set to `TRUE`. -#' Created using [teal.transform::picks()]. +#' Created using [teal.picks::picks()]. #' @param free_x_scales (`logical`) optional, whether X scaling shall be changeable. #' Does not allow scaling to be changed by default (`FALSE`). #' @param free_y_scales (`logical`) optional, whether Y scaling shall be changeable. @@ -85,21 +85,21 @@ #' data = data, #' modules = tm_g_bivariate( #' label = "Bivariate Plots", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(selected = "conc") +#' teal.picks::variables(selected = "conc") #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(selected = "uptake") +#' teal.picks::variables(selected = "uptake") #' ), -#' row_facet = teal.transform::picks( +#' row_facet = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(selected = "Type") +#' teal.picks::variables(selected = "Type") #' ), -#' col_facet = teal.transform::picks( +#' col_facet = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(selected = "Treatment") +#' teal.picks::variables(selected = "Treatment") #' ) #' ) #' ) @@ -124,21 +124,21 @@ #' data = data, #' modules = tm_g_bivariate( #' label = "Bivariate Plots", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(selected = "AGE") +#' teal.picks::variables(selected = "AGE") #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(selected = "SEX") +#' teal.picks::variables(selected = "SEX") #' ), -#' row_facet = teal.transform::picks( +#' row_facet = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(selected = "ARM") +#' teal.picks::variables(selected = "ARM") #' ), -#' col_facet = teal.transform::picks( +#' col_facet = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(selected = "COUNTRY") +#' teal.picks::variables(selected = "COUNTRY") #' ) #' ) #' ) @@ -149,14 +149,14 @@ #' @export #' tm_g_bivariate <- function(label = "Bivariate Plots", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - teal.transform::values() + teal.picks::values() ), y, row_facet, diff --git a/R/tm_g_bivariate_picks.R b/R/tm_g_bivariate_picks.R index 103411b93..880e09309 100644 --- a/R/tm_g_bivariate_picks.R +++ b/R/tm_g_bivariate_picks.R @@ -1,38 +1,38 @@ #' @export tm_g_bivariate.picks <- function(label = "Bivariate Plots", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L ), - teal.transform::values() + teal.picks::values() ), - y = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + y = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric | - teal.transform::is_categorical(min.len = 2, max.len = 10), + teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 2L ), - teal.transform::values() + teal.picks::values() ), - row_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + row_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), - col_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + col_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), facet = !is.null(row_facet) || !is.null(col_facet), color = NULL, @@ -162,11 +162,11 @@ ui_g_bivariate.picks <- function(id, encoding = shiny::tagList( tags$div( tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), picks = x) + teal.picks::picks_ui(id = ns("x"), picks = x) ), tags$div( tags$strong("Y variable"), - teal.transform::picks_ui(id = ns("y"), picks = y) + teal.picks::picks_ui(id = ns("y"), picks = y) ), conditionalPanel( condition = @@ -186,7 +186,7 @@ ui_g_bivariate.picks <- function(id, tags$div( tags$div( tags$strong("Row facetting variable"), - teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet), + teal.picks::picks_ui(id = ns("row_facet"), picks = row_facet), checkboxInput(ns("free_x_scales"), "free x scales", value = free_x_scales) ) ) @@ -195,7 +195,7 @@ ui_g_bivariate.picks <- function(id, tags$div( tags$div( tags$strong("Column facetting variable"), - teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet), + teal.picks::picks_ui(id = ns("col_facet"), picks = col_facet), checkboxInput(ns("free_y_scales"), "free y scales", value = free_y_scales) ) ) @@ -209,11 +209,11 @@ ui_g_bivariate.picks <- function(id, conditionalPanel( condition = paste0("input['", ns("coloring"), "']"), tags$div( - teal.transform::picks_ui(id = ns("color"), picks = color), # label = "Outline color by variable" - teal.transform::picks_ui(id = ns("fill"), picks = fill), # label = "Outline color by variable" + teal.picks::picks_ui(id = ns("color"), picks = color), # label = "Outline color by variable" + teal.picks::picks_ui(id = ns("fill"), picks = fill), # label = "Outline color by variable" tags$div( id = ns("size_settings"), - teal.transform::picks_ui(id = ns("size"), picks = size) # label = "Size of points by variable (only if x and y are numeric)" + teal.picks::picks_ui(id = ns("size"), picks = size) # label = "Size of points by variable (only if x and y are numeric)" ) ) ) @@ -280,7 +280,7 @@ srv_g_bivariate.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") ns <- session$ns - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = list( x = x, y = y, @@ -318,7 +318,7 @@ srv_g_bivariate.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") output_q <- reactive(label = "make bivariateplot", { req(merged$data()) diff --git a/R/tm_g_distribution.R b/R/tm_g_distribution.R index de88ffc91..6e1f8137e 100644 --- a/R/tm_g_distribution.R +++ b/R/tm_g_distribution.R @@ -71,10 +71,10 @@ #' data = data, #' modules = list( #' tm_g_distribution( -#' dist_var = teal.transform::picks( +#' dist_var = teal.picks::picks( #' datasets("iris"), -#' teal.transform::variables(is.numeric), -#' teal.transform::values() +#' teal.picks::variables(is.numeric), +#' teal.picks::values() #' ) #' ) #' ) @@ -101,18 +101,18 @@ #' data = data, #' modules = modules( #' tm_g_distribution( -#' dist_var = teal.transform::picks( +#' dist_var = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(c("BMRKR1", "AGE")), +#' teal.picks::variables(c("BMRKR1", "AGE")), #' values(multiple = FALSE) #' ), -#' strata_var = teal.transform::picks( +#' strata_var = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) +#' teal.picks::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ), -#' group_var = teal.transform::picks( +#' group_var = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) +#' teal.picks::variables(c("ARM", "COUNTRY", "SEX"), selected = NULL) #' ) #' ) #' ) @@ -124,10 +124,10 @@ #' @export #' tm_g_distribution <- function(label = "Distribution Module", - dist_var = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(is.numeric), - teal.transform::values() + dist_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(is.numeric), + teal.picks::values() ), strata_var = NULL, group_var = NULL, diff --git a/R/tm_g_distribution_picks.R b/R/tm_g_distribution_picks.R index 242019bef..c665a0c23 100644 --- a/R/tm_g_distribution_picks.R +++ b/R/tm_g_distribution_picks.R @@ -1,25 +1,25 @@ #' @export tm_g_distribution.picks <- function(label = "Distribution Module", - dist_var = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(is.numeric), - teal.transform::values() + dist_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(is.numeric), + teal.picks::values() ), - strata_var = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + strata_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), - group_var = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + group_var = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), freq = FALSE, ggtheme = c("gray", "bw", "linedraw", "light", "dark", "minimal", "classic", "void"), @@ -38,7 +38,7 @@ tm_g_distribution.picks <- function(label = "Distribution Module", checkmate::assert_class(dist_var, "picks") if (isTRUE(attr(dist_var$variables, "multiple"))) { - warning("dist_var accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("dist_var accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(dist_var$variables, "multiple") <- FALSE } checkmate::assert_class(strata_var, "picks", null.ok = TRUE) @@ -132,13 +132,13 @@ ui_g_distribution.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("Variable"), - teal.transform::picks_ui(id = ns("dist_var"), picks = dist_var) + teal.picks::picks_ui(id = ns("dist_var"), picks = dist_var) ), if (!is.null(group_var)) { tagList( tags$div( tags$strong("Group by:"), - teal.transform::picks_ui(id = ns("group_var"), picks = group_var) + teal.picks::picks_ui(id = ns("group_var"), picks = group_var) ), uiOutput(ns("scales_types_ui")) ) @@ -147,7 +147,7 @@ ui_g_distribution.picks <- function(id, tagList( tags$div( tags$strong("Stratify by:"), - teal.transform::picks_ui(id = ns("strata_var"), picks = strata_var) + teal.picks::picks_ui(id = ns("strata_var"), picks = strata_var) ) ) }, @@ -223,7 +223,7 @@ srv_g_distribution.picks <- function(id, ns <- session$ns - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = list(dist_var = dist_var, strata_var = strata_var, group_var = group_var), data = data ) @@ -244,7 +244,7 @@ srv_g_distribution.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr")') }) - merged <- teal.transform::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = qenv, selectors = selectors, output_name = "anl") validate_merged <- reactive({ obj <- merged$data() diff --git a/R/tm_g_response.R b/R/tm_g_response.R index a83c434e3..778a0c243 100644 --- a/R/tm_g_response.R +++ b/R/tm_g_response.R @@ -89,17 +89,17 @@ #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("mtcars"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("vs", "am"), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ) #' ) @@ -126,21 +126,21 @@ #' modules = modules( #' tm_g_response( #' label = "Response Plots", -#' response = teal.transform::picks( +#' response = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("BMRKR2", "COUNTRY"), #' selected = "BMRKR2" #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("SEX", "RACE"), #' selected = "RACE" #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ) #' ) @@ -152,10 +152,10 @@ #' @export #' tm_g_response <- function(label = "Response Plot", - response = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(choices = teal.transform::is_categorical(min.len = 2, max.len = 10)), - teal.transform::values() + response = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(choices = teal.picks::is_categorical(min.len = 2, max.len = 10)), + teal.picks::values() ), x, row_facet = NULL, diff --git a/R/tm_g_response_picks.R b/R/tm_g_response_picks.R index 0166b0784..c94c780e8 100644 --- a/R/tm_g_response_picks.R +++ b/R/tm_g_response_picks.R @@ -1,35 +1,35 @@ #' @export tm_g_response.picks <- function(label = "Response Plot", - response = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10) + response = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10) ), - teal.transform::values() + teal.picks::values() ), - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 2L ), - teal.transform::values() + teal.picks::values() ), - row_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + row_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), - col_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + col_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), coord_flip = FALSE, count_labels = TRUE, @@ -50,13 +50,13 @@ tm_g_response.picks <- function(label = "Response Plot", checkmate::assert_class(response, "picks") if (isTRUE(attr(response$variables, "multiple"))) { - warning("`response` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`response` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(response$variables, "multiple") <- FALSE } checkmate::assert_class(x, "picks") if (isTRUE(attr(x$variables, "multiple"))) { - warning("`x` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`x` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(x$variables, "multiple") <- FALSE } @@ -122,22 +122,22 @@ ui_g_response.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("Response variable"), - teal.transform::picks_ui(id = ns("response"), picks = response) + teal.picks::picks_ui(id = ns("response"), picks = response) ), tags$div( tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), picks = x) + teal.picks::picks_ui(id = ns("x"), picks = x) ), if (!is.null(row_facet)) { tags$div( tags$strong("Row facetting"), - teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) + teal.picks::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { tags$div( tags$strong("Column facetting"), - teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) + teal.picks::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, shinyWidgets::radioGroupButtons( @@ -186,7 +186,7 @@ srv_g_response.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = list( response = response, x = x, @@ -239,7 +239,7 @@ srv_g_response.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") output_q <- reactive({ diff --git a/R/tm_g_scatterplot.R b/R/tm_g_scatterplot.R index a99b0cbb9..1aa1e468d 100644 --- a/R/tm_g_scatterplot.R +++ b/R/tm_g_scatterplot.R @@ -75,47 +75,47 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("conc", "uptake"), #' selected = "conc" #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("conc", "uptake"), #' selected = "uptake" #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' color_by = teal.transform::picks( +#' color_by = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("Plant", "Type", "Treatment", "conc", "uptake"), #' selected = NULL #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' size_by = teal.transform::picks( +#' size_by = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(choices = c("conc", "uptake"), selected = "uptake"), -#' teal.transform::values() +#' teal.picks::variables(choices = c("conc", "uptake"), selected = "uptake"), +#' teal.picks::values() #' ), -#' row_facet = teal.transform::picks( +#' row_facet = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("Plant", "Type", "Treatment"), #' selected = NULL #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' col_facet = teal.transform::picks( +#' col_facet = teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), -#' teal.transform::values() +#' teal.picks::variables(choices = c("Plant", "Type", "Treatment"), selected = NULL), +#' teal.picks::values() #' ) #' ) #' ) @@ -144,35 +144,35 @@ #' modules = modules( #' tm_g_scatterplot( #' label = "Scatterplot Choices", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), -#' teal.transform::values() +#' teal.picks::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "AGE"), +#' teal.picks::values() #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), -#' teal.transform::values() +#' teal.picks::variables(choices = c("AGE", "BMRKR1", "BMRKR2"), selected = "BMRKR1"), +#' teal.picks::values() #' ), -#' color_by = teal.transform::picks( +#' color_by = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), -#' teal.transform::values() +#' teal.picks::variables(c("AGE", "BMRKR1", "BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.picks::values() #' ), -#' size_by = teal.transform::picks( +#' size_by = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), -#' teal.transform::values() +#' teal.picks::variables(choices = c("AGE", "BMRKR1"), selected = "AGE"), +#' teal.picks::values() #' ), -#' row_facet = teal.transform::picks( +#' row_facet = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), -#' teal.transform::values() +#' teal.picks::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.picks::values() #' ), -#' col_facet = teal.transform::picks( +#' col_facet = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), -#' teal.transform::values() +#' teal.picks::variables(choices = c("BMRKR2", "RACE", "REGION1"), selected = NULL), +#' teal.picks::values() #' ) #' ) #' ) @@ -184,10 +184,10 @@ #' @export #' tm_g_scatterplot <- function(label = "Scatterplot", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(is.numeric), - teal.transform::values() + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(is.numeric), + teal.picks::values() ), y, color_by = NULL, diff --git a/R/tm_g_scatterplot_picks.R b/R/tm_g_scatterplot_picks.R index 2f87ec128..d6197ea8d 100644 --- a/R/tm_g_scatterplot_picks.R +++ b/R/tm_g_scatterplot_picks.R @@ -1,46 +1,46 @@ #' @export tm_g_scatterplot.picks <- function(label = "Scatterplot", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(is.numeric), - teal.transform::values() + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(is.numeric), + teal.picks::values() ), - y = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(is.numeric, selected = 2L), - teal.transform::values() + y = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(is.numeric, selected = 2L), + teal.picks::values() ), - color_by = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + color_by = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL, multiple = TRUE ) ), - size_by = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( + size_by = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( choices = is.numeric, selected = NULL, multiple = TRUE ) ), - row_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + row_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), - col_facet = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + col_facet = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = NULL ), - teal.transform::values() + teal.picks::values() ), plot_height = c(600, 200, 2000), plot_width = NULL, @@ -67,13 +67,13 @@ tm_g_scatterplot.picks <- function(label = "Scatterplot", checkmate::assert_class(row_facet, "picks", null.ok = TRUE) if (isTRUE(attr(row_facet$variables, "multiple"))) { - warning("`row_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`row_facet` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(row_facet$variables, "multiple") <- FALSE } checkmate::assert_class(col_facet, "picks", null.ok = TRUE) if (isTRUE(attr(col_facet$variables, "multiple"))) { - warning("`col_facet` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`col_facet` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(col_facet$variables, "multiple") <- FALSE } @@ -162,7 +162,7 @@ ui_g_scatterplot.picks <- function(id, tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("X variable"), - teal.transform::picks_ui(id = ns("x"), picks = x), + teal.picks::picks_ui(id = ns("x"), picks = x), checkboxInput(ns("log_x"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_x"), "'] == true"), @@ -176,7 +176,7 @@ ui_g_scatterplot.picks <- function(id, ), tags$div( tags$strong("Y variable"), - teal.transform::picks_ui(id = ns("y"), picks = y), + teal.picks::picks_ui(id = ns("y"), picks = y), checkboxInput(ns("log_y"), "Use log transformation", value = FALSE), conditionalPanel( condition = paste0("input['", ns("log_y"), "'] == true"), @@ -191,25 +191,25 @@ ui_g_scatterplot.picks <- function(id, if (!is.null(color_by)) { tags$div( tags$strong("Color by:"), - teal.transform::picks_ui(id = ns("color_by"), picks = color_by) + teal.picks::picks_ui(id = ns("color_by"), picks = color_by) ) }, if (!is.null(size_by)) { tags$div( tags$strong("Size by:"), - teal.transform::picks_ui(id = ns("size_by"), picks = size_by) + teal.picks::picks_ui(id = ns("size_by"), picks = size_by) ) }, if (!is.null(row_facet)) { tags$div( tags$strong("Row facetting"), - teal.transform::picks_ui(id = ns("row_facet"), picks = row_facet) + teal.picks::picks_ui(id = ns("row_facet"), picks = row_facet) ) }, if (!is.null(col_facet)) { tags$div( tags$strong("Column facetting"), - teal.transform::picks_ui(id = ns("col_facet"), picks = col_facet) + teal.picks::picks_ui(id = ns("col_facet"), picks = col_facet) ) }, ui_decorate_teal_data(ns("decorator"), decorators = select_decorators(decorators, "plot")), @@ -295,7 +295,7 @@ srv_g_scatterplot.picks <- function(id, teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = list(x = x, y = y, color_by = color_by, size_by = size_by, row_facet = row_facet, col_facet = col_facet), data = data ) @@ -350,7 +350,7 @@ srv_g_scatterplot.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") trend_line_is_applicable <- reactive({ anl <- merged$data()[["anl"]] diff --git a/R/tm_g_scatterplotmatrix.R b/R/tm_g_scatterplotmatrix.R index 421ab2179..8df00daad 100644 --- a/R/tm_g_scatterplotmatrix.R +++ b/R/tm_g_scatterplotmatrix.R @@ -13,7 +13,7 @@ #' #' @param variables (`picks` or `list` of `picks`) #' Specifies plotting variables from an incoming dataset with filtering and selecting. In case of -#' `picks` use `teal.transform::variables(..., ordered = TRUE)` if plot elements should be +#' `picks` use `teal.picks::variables(..., ordered = TRUE)` if plot elements should be #' rendered according to selection order. #' #' @inherit shared_params return @@ -94,19 +94,19 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("countries"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = tidyselect::everything(), #' selected = c("area", "gdp", "debt"), #' multiple = TRUE, #' ordered = TRUE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("sales"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = c("quantity", "costs", "profit"), #' selected = c("quantity", "costs", "profit"), #' multiple = TRUE, @@ -116,10 +116,10 @@ #' ), #' transformators = list( #' teal_transform_filter( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("sales"), -#' teal.transform::variables("country_id"), -#' teal.transform::values() +#' teal.picks::variables("country_id"), +#' teal.picks::values() #' ) #' ) #' ) @@ -149,20 +149,20 @@ #' tm_g_scatterplotmatrix( #' label = "Scatterplot matrix", #' variables = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = tidyselect::everything(), #' selected = c("AGE", "RACE", "SEX"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("ADRS"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = tidyselect::everything(), #' selected = c("AGE", "AVAL", "ADY"), #' multiple = TRUE, @@ -172,7 +172,7 @@ #' ) #' ), #' transformators = list( -#' teal_transform_filter(teal.transform::picks(datasets("ADRS"), teal.transform::variables("PARAMCD"), values(selected = "BESRSPI"))) +#' teal_transform_filter(teal.picks::picks(datasets("ADRS"), teal.picks::variables("PARAMCD"), values(selected = "BESRSPI"))) #' ) #' ) #' ) @@ -184,9 +184,9 @@ #' @export tm_g_scatterplotmatrix <- function(label = "Scatterplot Matrix", variables = list( - teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) + teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(selected = seq(1L, 5L), multiple = TRUE) ) ), plot_height = c(600, 200, 2000), diff --git a/R/tm_g_scatterplotmatrix_picks.R b/R/tm_g_scatterplotmatrix_picks.R index e4112820c..067c7668f 100644 --- a/R/tm_g_scatterplotmatrix_picks.R +++ b/R/tm_g_scatterplotmatrix_picks.R @@ -1,9 +1,9 @@ #' @export tm_g_scatterplotmatrix.picks <- function(label = "Scatterplot Matrix", variables = list( - teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables(selected = seq(1L, 5L), multiple = TRUE) + teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables(selected = seq(1L, 5L), multiple = TRUE) ) ), plot_height = c(600, 200, 2000), @@ -68,7 +68,7 @@ ui_g_scatterplotmatrix.picks <- function(id, tagList( lapply(names(variables), function(id) { tags$div( - teal.transform::picks_ui(id = ns(id), picks = variables[[id]]) + teal.picks::picks_ui(id = ns(id), picks = variables[[id]]) ) }) ), @@ -118,7 +118,7 @@ srv_g_scatterplotmatrix.picks <- function(id, moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv( + selectors <- teal.picks::picks_srv( picks = variables, data = data ) @@ -141,7 +141,7 @@ srv_g_scatterplotmatrix.picks <- function(id, teal.code::eval_code(obj, 'library("ggplot2");library("dplyr");') }) - merged <- teal.transform::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") + merged <- teal.picks::merge_srv("merge", data = validated_q, selectors = selectors, output_name = "anl") # plot output_q <- reactive({ diff --git a/R/tm_outliers.R b/R/tm_outliers.R index e8e4ec560..567334322 100644 --- a/R/tm_outliers.R +++ b/R/tm_outliers.R @@ -66,21 +66,21 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["CO2"]], c("conc", "uptake")), #' selected = "uptake", #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ), #' categorical_var = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("CO2"), -#' teal.transform::variables(), +#' teal.picks::variables(), #' values( #' vars = vars, #' choices = value_choices(data[["CO2"]], vars$selected), @@ -118,21 +118,21 @@ #' modules = modules( #' tm_outliers( #' outlier_var = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["ADSL"]], c("AGE", "BMRKR1")), #' selected = "AGE", #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ), #' categorical_var = list( -#' teal.transform::picks( +#' teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables(), +#' teal.picks::variables(), #' values( #' vars = vars, #' choices = value_choices(data[["ADSL"]], vars$selected), diff --git a/R/tm_t_crosstable.R b/R/tm_t_crosstable.R index 1f20965be..578dca1bb 100644 --- a/R/tm_t_crosstable.R +++ b/R/tm_t_crosstable.R @@ -7,7 +7,7 @@ #' @inheritParams shared_params #' @param x (`picks` or `list` of `picks`) #' Object with all available choices with pre-selected option for variable X - row values. -#' In case of `picks` use `teal.transform::variables(..., ordered = TRUE)` if table elements should be +#' In case of `picks` use `teal.picks::variables(..., ordered = TRUE)` if table elements should be #' rendered according to selection order. #' @param y (`picks` or `list` of multiple `picks`) #' Object with all available choices with pre-selected option for variable Y - column values. @@ -82,26 +82,26 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("mtcars"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = c("cyl", "gear"), #' multiple = TRUE, #' ordered = TRUE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("mtcars"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["mtcars"]], c("cyl", "vs", "am", "gear")), #' selected = "vs", #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ) #' ) @@ -127,9 +127,9 @@ #' modules = modules( #' tm_t_crosstable( #' label = "Cross Table", -#' x = teal.transform::picks( +#' x = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- !vapply(data, inherits, logical(1), c("Date", "POSIXct", "POSIXlt")) #' return(names(data)[idx]) @@ -139,11 +139,11 @@ #' ordered = TRUE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ), -#' y = teal.transform::picks( +#' y = teal.picks::picks( #' datasets("ADSL"), -#' teal.transform::variables( +#' teal.picks::variables( #' choices = variable_choices(data[["ADSL"]], subset = function(data) { #' idx <- vapply(data, is.factor, logical(1)) #' return(names(data)[idx]) @@ -152,7 +152,7 @@ #' multiple = FALSE, #' fixed = FALSE #' ), -#' teal.transform::values() +#' teal.picks::values() #' ) #' ) #' ) @@ -164,10 +164,10 @@ #' @export #' tm_t_crosstable <- function(label = "Cross Table", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple = TRUE, ordered = TRUE ) ), diff --git a/R/tm_t_crosstable_picks.R b/R/tm_t_crosstable_picks.R index 91bd86516..354264fe8 100644 --- a/R/tm_t_crosstable_picks.R +++ b/R/tm_t_crosstable_picks.R @@ -1,19 +1,19 @@ #' @export tm_t_crosstable.picks <- function(label = "Cross Table", - x = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + x = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 1L, multiple = TRUE, ordered = TRUE ) ), - y = teal.transform::picks( - teal.transform::datasets(), - teal.transform::variables( - choices = teal.transform::is_categorical(min.len = 2, max.len = 10), + y = teal.picks::picks( + teal.picks::datasets(), + teal.picks::variables( + choices = teal.picks::is_categorical(min.len = 2, max.len = 10), selected = 2L, ordered = TRUE ), - teal.transform::values() + teal.picks::values() ), show_percentage = TRUE, show_total = TRUE, @@ -31,7 +31,7 @@ tm_t_crosstable.picks <- function(label = "Cross Table", checkmate::assert_class(y, "picks") if (isTRUE(attr(y$variables, "multiple"))) { - warning("`y` accepts only a single variable selection. Forcing `teal.transform::variables(multiple) to FALSE`") + warning("`y` accepts only a single variable selection. Forcing `teal.picks::variables(multiple) to FALSE`") attr(y$variables, "multiple") <- FALSE } @@ -80,11 +80,11 @@ ui_t_crosstable.picks <- function(id, x, y, show_percentage, show_total, remove_ tags$label("Encodings", class = "text-primary"), tags$div( tags$strong("Row values"), - teal.transform::picks_ui(id = ns("x"), picks = x) + teal.picks::picks_ui(id = ns("x"), picks = x) ), tags$div( tags$strong("Column values"), - teal.transform::picks_ui(id = ns("y"), picks = y) + teal.picks::picks_ui(id = ns("y"), picks = y) ), shinyWidgets::pickerInput( ns("join_fun"), @@ -116,7 +116,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b moduleServer(id, function(input, output, session) { teal.logger::log_shiny_input_changes(input, namespace = "teal.modules.general") - selectors <- teal.transform::picks_srv(picks = list(x = x, y = y), data = data) + selectors <- teal.picks::picks_srv(picks = list(x = x, y = y), data = data) validated_q <- reactive({ validate_input( @@ -154,7 +154,7 @@ srv_t_crosstable.picks <- function(id, data, label, x, y, remove_zero_columns, b } ) - merged <- teal.transform::merge_srv( + merged <- teal.picks::merge_srv( "merge", data = validated_q, selectors = selectors, From 81aea6f5f8cfe0ddb56182bbf52aa9c92277110c Mon Sep 17 00:00:00 2001 From: m7pr Date: Thu, 5 Mar 2026 11:59:26 +0100 Subject: [PATCH 158/158] keep teal.transform at main branch in Remotes --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 42a9584e6..e71a19040 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -85,7 +85,7 @@ VignetteBuilder: Remotes: insightsengineering/teal@redesign_extraction@main, insightsengineering/teal.picks@redesign_extraction@main, - insightsengineering/teal.transform@redesign_extraction@main + insightsengineering/teal.transform@main Config/Needs/verdepcheck: haleyjeppson/ggmosaic, tidyverse/ggplot2, rstudio/shiny, insightsengineering/teal, insightsengineering/teal.transform, mllg/checkmate, tidyverse/dplyr,