From 12f095c3a08c3dc17204bf3c38b191089cb74a74 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Tue, 5 Nov 2024 08:26:05 +0100 Subject: [PATCH 001/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] [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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] [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/135] [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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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/135] 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 8c251ed132ef41a6ae387106abd665ea222f94d0 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 17:37:25 +0530 Subject: [PATCH 119/135] 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 636a0cd9ed18a6b8af72bf07d7c785ed36625239 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 12 Sep 2025 18:13:35 +0530 Subject: [PATCH 120/135] 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 121/135] 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 122/135] 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 123/135] 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 124/135] 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 125/135] 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 126/135] 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 127/135] 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 d04c1165f5bad9089349ee59b469e01e9254f8e6 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 16 Sep 2025 15:17:30 +0530 Subject: [PATCH 128/135] 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 22abc613c197b0c1c2bfe12e1593017a2cc7124f Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 18 Sep 2025 12:28:00 +0530 Subject: [PATCH 129/135] feat: split spiderplot + write docs --- R/tm_p_bargraph.R | 21 +++++---- R/tm_p_lineplot.R | 7 ++- R/tm_p_scatterplot.R | 9 ++-- R/tm_p_spaghetti.R | 7 ++- R/tm_p_spiderplot.R | 96 ++++++++++++++++++++--------------------- R/tm_p_swimlane.R | 42 ++++++++++-------- R/tm_p_waterfall.R | 37 +++++++++------- man/tm_p_bargraph.Rd | 11 +++-- man/tm_p_lineplot.Rd | 9 +++- man/tm_p_scatterplot.Rd | 11 +++-- man/tm_p_spaghetti.Rd | 9 +++- man/tm_p_spiderplot.Rd | 51 +++++++++++----------- man/tm_p_swimlane.Rd | 43 ++++++++++-------- man/tm_p_waterfall.Rd | 38 +++++++++------- 14 files changed, 223 insertions(+), 168 deletions(-) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 65f8734d6..040b7b453 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -6,14 +6,17 @@ #' 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. +#' @inheritParams teal::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. +#' If `NULL`, default tooltip is created showing y, color, and count variables. +#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. +#' +#' @inherit shared_params return #' #' @examples #' data <- teal_data() |> @@ -122,7 +125,7 @@ srv_p_bargraph <- function(id, 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)), @@ -132,7 +135,7 @@ srv_p_bargraph <- function(id, } 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) { @@ -141,23 +144,23 @@ srv_p_bargraph <- function(id, } 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 + 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)), diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index f6fcb8c68..113c82849 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -6,19 +6,22 @@ #' 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. +#' @inheritParams teal::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 colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. #' @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. #' +#' @inherit shared_params return +#' #' @examples #' data <- teal_data() |> #' within({ diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 3fa69b52b..a1bff8135 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -5,18 +5,21 @@ #' 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. +#' @inheritParams teal::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 point_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. #' @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. +#' If `NULL`, default tooltip is created showing subject, x, y, and color variables. #' @param transformators (`list`) Named list of transformator functions. #' @param show_widgets (`logical(1)`) Whether to show module widgets. #' +#' @inherit shared_params return +#' #' @examples #' data <- teal_data() |> #' within({ diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index 63360a0ce..3d509269f 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -6,18 +6,21 @@ #' 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. +#' @inheritParams teal::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 point_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. #' @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. #' +#' @inherit shared_params return +#' #' @examples #' data <- teal_data() |> #' within({ diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 56a3cb460..56e221329 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -1,30 +1,33 @@ -#' `teal` module: Spider Plot +#' Spider Plot Module #' -#' Module visualizes value development in time grouped by subjects. +#' This module creates an interactive spider plot visualization that shows value development +#' over time grouped by subjects. The plot displays individual trajectories as connected +#' lines and points, with support for color coding and symbol differentiation. Optional +#' filtering by event variables allows dynamic data subsetting. The plot includes customizable +#' tooltips and point sizing based on data values. #' #' @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. -#' @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 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 plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @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 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 filter_event_var (`character(1)`) 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 filtered 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` -#' will be used to determine the size of the points. If `NULL`, a fixed size based on the `point_size` is used. +#' will be used to determine the size of the points. If `NULL`, a fixed 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. +#' If `NULL`, default tooltip is created showing time, value, subject, and color variables. +#' @param point_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. +#' @param point_symbols (`named character` or `NULL`) Valid plotly symbol names named by levels of `color_var` column. +#' If `NULL`, default symbols will be used. +#' +#' @inherit shared_params return #' #' @examples #' data <- teal_data() |> @@ -64,7 +67,6 @@ #' modules = modules( #' tm_p_spiderplot( #' plot_dataname = "spiderplot_ds", -#' table_datanames = "subjects", #' time_var = "time_var", #' value_var = "value_var", #' subject_var = "subject_var", @@ -97,9 +99,7 @@ tm_p_spiderplot <- function(label = "Spiderplot", tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list()) { + plot_height = c(600, 400, 1200)) { if (is.character(time_var)) { time_var <- choices_selected(choices = time_var, selected = time_var) } @@ -131,11 +131,9 @@ tm_p_spiderplot <- function(label = "Spiderplot", 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) + datanames = plot_dataname ) } @@ -164,8 +162,7 @@ ui_p_spiderplot <- function(id, height) { trigger_tooltips_deps(), plotly::plotlyOutput(ns("plot"), height = "100%") ) - ), - ui_t_reactables(ns("subtables")) + ) ) ) } @@ -182,8 +179,6 @@ srv_p_spiderplot <- function(id, point_symbols, size_var = NULL, plot_height = 600, - table_datanames = character(0), - reactable_args = list(), tooltip_vars = NULL, filter_panel_api) { moduleServer(id, function(input, output, session) { @@ -272,7 +267,7 @@ srv_p_spiderplot <- function(id, } p <- plot_data %>% - dplyr::ungroup() %>% + dplyr::ungroup() %>% dplyr::mutate( x = dplyr::lag(!!as.name(time_var), default = 0), y = dplyr:::lag(!!as.name(value_var), default = 0), @@ -392,20 +387,25 @@ srv_p_spiderplot <- function(id, plotly::event_data("plotly_selected", source = session$ns("spiderplot")) ) - 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 - ) + 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(subject_var_string) %in% selected_plot_data[[subject_var_string]]) + }, + df = str2lang(plot_dataname), + subject_var_string = subject_var$selected, + plotly_selected_customdata = plotly_selected()$customdata + ) + attr(q, "has_brushing") <- TRUE + q + } + }) }) } diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 1d1c1fed0..1d79962da 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,29 +1,33 @@ -#' `teal` module: Swimlane plot +#' Swimlane Plot Module #' -#' Module visualizes subjects' events in time. +#' This module creates an interactive swimlane plot visualization that displays subjects' events +#' over time. Each subject is represented by a horizontal lane, with events plotted as points +#' along the timeline. The plot supports color coding and symbol differentiation for different +#' event types, customizable sorting of subjects, and interactive tooltips. This visualization +#' is particularly useful for showing temporal sequences of events across multiple 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 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 plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @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 (subject lanes). +#' @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. +#' @param sort_var (`character(1)`) Name of the column in `plot_dataname` whose values determine +#' the order of 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. +#' If `NULL`, default tooltip is created showing subject, time, color, and group variables. #' @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 point_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. +#' @param point_symbols (`named character` or `NULL`) Valid plotly symbol names named by levels of `color_var` column. +#' If `NULL`, default symbols will be used. +#' +#' @inherit shared_params return #' #' @examples #' data <- teal_data() |> diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index b5a37bf7e..da9ac0e65 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -1,23 +1,30 @@ -#' `teal` module: Waterfall plot +#' Waterfall Plot Module #' -#' Module visualizes subjects sorted decreasingly by y-values. +#' This module creates an interactive waterfall plot visualization that displays subjects +#' sorted by their values in a descending waterfall pattern. Each subject is represented +#' by a vertical bar, with the height corresponding to the value variable. The plot supports +#' color coding by categorical variables, optional horizontal reference lines, and customizable +#' tooltips. This visualization is particularly useful for showing ranked responses or changes +#' across subjects. #' #' @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 plot_dataname (`character(1)`) Name of the dataset to be used for plotting. +#' @param subject_var (`character(1)`) Name of the factor or character column in `plot_dataname` +#' to be used as x-axis (subject identifiers). +#' @param value_var (`character(1)`) Name of the numeric column in `plot_dataname` +#' to be used as y-axis (values determining bar heights). +#' @param color_var (`character(1)` or `NULL`) Name of the factor or character column in `plot_dataname` +#' to be used to differentiate bar colors. If `NULL`, all bars will have the same color. #' @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. +#' If `NULL`, default tooltip is created showing subject, value, and color variables. +#' @param bar_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. +#' If `NULL`, default colors will be used. +#' @param value_arbitrary_hlines (`numeric` or `NULL`) Values in the same scale as `value_var` to add +#' horizontal reference lines on the plot. +#' @param plot_title (`character` or `NULL`) Title of the plot. If `NULL`, no title is displayed. +#' +#' @inherit shared_params return #' #' @examples #' data <- teal_data() |> diff --git a/man/tm_p_bargraph.Rd b/man/tm_p_bargraph.Rd index 921e24e8e..63ce99637 100644 --- a/man/tm_p_bargraph.Rd +++ b/man/tm_p_bargraph.Rd @@ -15,7 +15,8 @@ tm_p_bargraph( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\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 to be used for plotting.} @@ -26,9 +27,13 @@ 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.} +If \code{NULL}, default tooltip is created showing y, color, and count variables.} -\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of color_var column.} +\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be used.} +} +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. } \description{ This module creates an interactive horizontal stacked bar chart visualization that diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd index 70f2f63aa..ab30f35d5 100644 --- a/man/tm_p_lineplot.Rd +++ b/man/tm_p_lineplot.Rd @@ -19,7 +19,8 @@ tm_p_lineplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\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 to be used for plotting.} @@ -31,7 +32,8 @@ tm_p_lineplot( \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{colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be 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 showing group, x, y, and color variables.} @@ -42,6 +44,9 @@ If \code{NULL}, default tooltip is created showing group, x, y, and color variab \item{activate_on_brushing}{(\code{logical(1)}) Whether to activate the plot only when brushing occurs in another plot.} } +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} \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 diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd index 79e402e92..5e8d5aef7 100644 --- a/man/tm_p_scatterplot.Rd +++ b/man/tm_p_scatterplot.Rd @@ -18,7 +18,8 @@ tm_p_scatterplot( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\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 to be used for plotting.} @@ -30,15 +31,19 @@ tm_p_scatterplot( \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{point_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be 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 showing x, y, and color variables.} +If \code{NULL}, default tooltip is created showing subject, 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.} } +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} \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 diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd index 52a877fda..d556bfa79 100644 --- a/man/tm_p_spaghetti.Rd +++ b/man/tm_p_spaghetti.Rd @@ -18,7 +18,8 @@ tm_p_spaghetti( ) } \arguments{ -\item{label}{(\code{character(1)}) Label shown in the navigation item for the module.} +\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 to be used for plotting.} @@ -30,7 +31,8 @@ tm_p_spaghetti( \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{point_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be 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 showing group, x, y, and color variables.} @@ -39,6 +41,9 @@ If \code{NULL}, default tooltip is created showing group, x, y, and color variab \item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} } +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} \description{ This module creates an interactive spaghetti plot visualization that shows individual trajectories for each group over time. Each trajectory is represented by connected diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index a68e3b8a0..66b8b2fc5 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tm_p_spiderplot.R \name{tm_p_spiderplot} \alias{tm_p_spiderplot} -\title{\code{teal} module: Spider Plot} +\title{Spider Plot Module} \usage{ tm_p_spiderplot( label = "Spiderplot", @@ -16,53 +16,53 @@ tm_p_spiderplot( tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = c(600, 400, 1200), - table_datanames = character(0), - reactable_args = list() + 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)} or \code{choices_selected}) name of the dataset which visualization is builded on.} +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} -\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)}) Name of the 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{value_var}{(\code{character(1)}) Name of the 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)}) Name of the factor or 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)}) Name of the factor or 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{filter_event_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +to be used to filter the data. The plot will be updated with just the filtered 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.} +will be used to determine the size of the points. If \code{NULL}, a fixed 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.} +If \code{NULL}, default tooltip is created showing time, value, subject, and color variables.} -\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_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be used.} -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var}column.} +\item{point_symbols}{(\verb{named character} or \code{NULL}) Valid plotly symbol names named by levels of \code{color_var} column. +If \code{NULL}, default symbols will be used.} \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.} +} +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. } \description{ -Module visualizes value development in time grouped by subjects. +This module creates an interactive spider plot visualization that shows value development +over time grouped by subjects. The plot displays individual trajectories as connected +lines and points, with support for color coding and symbol differentiation. Optional +filtering by event variables allows dynamic data subsetting. The plot includes customizable +tooltips and point sizing based on data values. } \examples{ data <- teal_data() |> @@ -102,7 +102,6 @@ app <- init( modules = modules( tm_p_spiderplot( plot_dataname = "spiderplot_ds", - table_datanames = "subjects", time_var = "time_var", value_var = "value_var", subject_var = "subject_var", diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 85f7598fc..12debfc2f 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tm_p_swimlane.R \name{tm_p_swimlane} \alias{tm_p_swimlane} -\title{\code{teal} module: Swimlane plot} +\title{Swimlane Plot Module} \usage{ tm_p_swimlane( label = "Swimlane", @@ -24,41 +24,46 @@ tm_p_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)} or \code{choices_selected}) name of the dataset which visualization is builded on.} +\item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} -\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)}) Name of the 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)}) Name of the factor or character column in \code{plot_dataname} +to be used as y-axis (subject lanes).} -\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)}) Name of the factor or 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{group_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +to categorize type of event. Legend is sorted according to this variable.} -\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{sort_var}{(\code{character(1)}) Name of the column in \code{plot_dataname} whose values determine +the order of 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.} +If \code{NULL}, default tooltip is created showing subject, time, color, and group variables.} \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_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be used.} -\item{point_symbols}{(\verb{named character}) valid plotly symbol name named by levels of \code{color_var} column.} +\item{point_symbols}{(\verb{named character} or \code{NULL}) Valid plotly symbol names named by levels of \code{color_var} column. +If \code{NULL}, default symbols will be used.} \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.} } +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} \description{ -Module visualizes subjects' events in time. +This module creates an interactive swimlane plot visualization that displays subjects' events +over time. Each subject is represented by a horizontal lane, with events plotted as points +along the timeline. The plot supports color coding and symbol differentiation for different +event types, customizable sorting of subjects, and interactive tooltips. This visualization +is particularly useful for showing temporal sequences of events across multiple subjects. } \examples{ data <- teal_data() |> diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index eabdeea88..ed77d30e2 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tm_p_waterfall.R \name{tm_p_waterfall} \alias{tm_p_waterfall} -\title{\code{teal} module: Waterfall plot} +\title{Waterfall Plot Module} \usage{ tm_p_waterfall( label = "Waterfall", @@ -22,33 +22,41 @@ tm_p_waterfall( \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)}) Name of the dataset to be used for plotting.} -\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)}) Name of the factor or character column in \code{plot_dataname} +to be used as x-axis (subject identifiers).} -\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)}) Name of the numeric column in \code{plot_dataname} +to be used as y-axis (values determining bar heights).} -\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{color_var}{(\code{character(1)} or \code{NULL}) Name of the factor or character column in \code{plot_dataname} +to be used to differentiate bar colors. If \code{NULL}, all bars will have the same color.} \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.} +If \code{NULL}, default tooltip is created showing subject, value, and color variables.} -\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{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. +If \code{NULL}, default colors will be used.} -\item{value_arbitrary_hlines}{(\code{numeric}) values in the same scale as \code{value_var} to horizontal -lines on the plot.} +\item{value_arbitrary_hlines}{(\code{numeric} or \code{NULL}) Values in the same scale as \code{value_var} to add +horizontal reference lines on the plot.} -\item{plot_title}{(\code{character}) Title of the plot.} +\item{plot_title}{(\code{character} or \code{NULL}) Title of the plot. If \code{NULL}, no title is displayed.} \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.} } +\value{ +Object of class \code{teal_module} to be used in \code{teal} applications. +} \description{ -Module visualizes subjects sorted decreasingly by y-values. +This module creates an interactive waterfall plot visualization that displays subjects +sorted by their values in a descending waterfall pattern. Each subject is represented +by a vertical bar, with the height corresponding to the value variable. The plot supports +color coding by categorical variables, optional horizontal reference lines, and customizable +tooltips. This visualization is particularly useful for showing ranked responses or changes +across subjects. } \examples{ data <- teal_data() |> From 738cb161012c2532ef201b1eb5655f9a9a5417e3 Mon Sep 17 00:00:00 2001 From: vedhav Date: Thu, 25 Sep 2025 12:17:09 +0530 Subject: [PATCH 130/135] bump version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 792f020fb..bf8846960 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: teal.modules.general Title: General Modules for 'teal' Applications -Version: 0.5.0.9001 +Version: 0.5.1.9001 Date: 2025-09-09 Authors@R: c( person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), From 0e15468dd7e044f9979a617868b38a3f74bb39d2 Mon Sep 17 00:00:00 2001 From: vedhav Date: Fri, 26 Sep 2025 18:35:10 +0530 Subject: [PATCH 131/135] feat: make the modules work with the new composit modules --- DESCRIPTION | 2 +- R/tm_p_bargraph.R | 244 +++++++++++++++------------ R/tm_p_lineplot.R | 360 ++++++++++++++++++++++----------------- R/tm_p_scatterplot.R | 260 +++++++++++++++------------- R/tm_p_spaghetti.R | 279 +++++++++++++++++------------- R/tm_p_spiderplot.R | 351 +++++++++++++++++++++----------------- R/tm_p_swimlane.R | 374 +++++++++++++++++++++++------------------ R/tm_p_waterfall.R | 277 ++++++++++++++++++------------ man/bargraphplotly.Rd | 39 +++++ man/lineplotly.Rd | 45 +++++ man/scatterplotly.Rd | 58 +++++++ man/spaghettiplotly.Rd | 58 +++++++ man/spiderplotly.Rd | 86 ++++++++++ man/swimlaneplotly.Rd | 74 ++++++++ man/tm_p_spaghetti.Rd | 2 +- man/tm_p_spiderplot.Rd | 3 +- man/tm_p_swimlane.Rd | 5 +- man/tm_p_waterfall.Rd | 6 +- man/waterfallplotly.Rd | 70 ++++++++ 19 files changed, 1657 insertions(+), 936 deletions(-) create mode 100644 man/bargraphplotly.Rd create mode 100644 man/lineplotly.Rd create mode 100644 man/scatterplotly.Rd create mode 100644 man/spaghettiplotly.Rd create mode 100644 man/spiderplotly.Rd create mode 100644 man/swimlaneplotly.Rd create mode 100644 man/waterfallplotly.Rd diff --git a/DESCRIPTION b/DESCRIPTION index bf8846960..792f020fb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Type: Package Package: teal.modules.general Title: General Modules for 'teal' Applications -Version: 0.5.1.9001 +Version: 0.5.0.9001 Date: 2025-09-09 Authors@R: c( person("Dawid", "Kaledkowski", , "dawid.kaledkowski@roche.com", role = c("aut", "cre")), diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 040b7b453..67ffea922 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -109,111 +109,16 @@ srv_p_bargraph <- function(id, 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") + code, + code = bargraphplotly( + df = plot_dataname, + y_var = y_var, + color_var = color_var, + count_var = count_var, + tooltip_vars = tooltip_vars, + bar_colors = bar_colors, + source = session$ns("bargraph") + ) ) }) @@ -254,3 +159,132 @@ srv_p_bargraph <- function(id, }) }) } + +#' Create Bar Graph with Plotly +#' +#' This function generates plotly code for creating interactive horizontal stacked bar charts +#' that display counts of distinct values grouped by categories. +#' +#' @param df (`character(1)`) Name of the data frame containing the plotting data +#' @param y_var (`character(1)`) Name of the y-axis variable +#' @param color_var (`character(1)`) Name of the color variable +#' @param count_var (`character(1)`) Name of the count variable +#' @param tooltip_vars (`character` or `NULL`) Variables to include in tooltip +#' @param bar_colors (`named character` or `NULL`) Color mapping for groups +#' @param source (`character(1)`) Plotly source identifier for events +#' +#' @return A substitute expression that creates a plotly object with horizontal stacked bars +#' @keywords internal +bargraphplotly <- function(df, + y_var, + color_var, + count_var, + tooltip_vars = NULL, + bar_colors = NULL, + source = "bargraph") { + substitute( + { + df_sym[[color_var_str]] <- as.character(df_sym[[color_var_str]]) + + plot_data <- df_sym %>% + dplyr::group_by(!!as.name(y_var_str), !!as.name(color_var_str)) %>% + dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var_str)), .groups = "drop") %>% + dplyr::ungroup() %>% + dplyr::mutate(customdata = dplyr::row_number()) %>% + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars_sym)) { + y_var_label <- attr(df_sym[[y_var_str]], "label") + if (!length(y_var_label)) y_var_label <- y_var_str + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + + paste( + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + paste("Count:", count), + sep = "
" + ) + } else { + cur_data <- dplyr::cur_data() + + actual_cols <- character(0) + for (col in tooltip_vars_sym) { + if (col == "y_var") { + actual_cols <- c(actual_cols, y_var_str) + } else if (col == "color_var") { + actual_cols <- c(actual_cols, color_var_str) + } else if (col == "count_var") { + actual_cols <- c(actual_cols, "count") + } else { + actual_cols <- c(actual_cols, col) + } + } + + cols <- intersect(actual_cols, names(cur_data)) + + if (!length(cols)) { + y_var_label <- attr(df_sym[[y_var_str]], "label") + if (!length(y_var_label)) y_var_label <- y_var_str + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + + paste( + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + paste("Count:", count), + sep = "
" + ) + } else { + 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_str)) %>% + dplyr::summarize(total = sum(count), .groups = "drop") %>% + dplyr::arrange(total) %>% + dplyr::pull(!!as.name(y_var_str)) + + plot_data[[y_var_str]] <- factor(plot_data[[y_var_str]], levels = event_type_order) + + p <- plotly::plot_ly( + data = plot_data, + y = ~y_var_sym, + x = ~count, + color = ~color_var_sym, + colors = bar_colors_sym, + type = "bar", + orientation = "h", + hovertext = ~tooltip, + hoverinfo = "text", + customdata = ~customdata, + source = source_sym + ) %>% + plotly::layout( + barmode = "stack", + xaxis = list(title = "Count"), + yaxis = list(title = "Category"), + legend = list(title = list(text = "Group")) + ) %>% + plotly::layout(dragmode = "select") + }, + list( + df_sym = str2lang(df), + y_var_sym = str2lang(y_var), + color_var_sym = str2lang(color_var), + count_var_sym = str2lang(count_var), + y_var_str = y_var, + color_var_str = color_var, + count_var_str = count_var, + tooltip_vars_sym = tooltip_vars, + bar_colors_sym = bar_colors, + source_sym = source + ) + ) +} diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index 113c82849..a2c32b0b8 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -119,177 +119,221 @@ srv_p_lineplot <- function(id, if (activate_on_brushing) { req(attr(data(), "has_brushing")) } - data() %>% + data() |> within( - { - validate(need(nrow(df) > 0, "No data after applying filters.")) + code, + code = lineplotly( + df = 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, + source = session$ns("lineplot") + ) + ) + }) - # 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 + output$plot <- plotly::renderPlotly({ + plotly_q()$p %>% + plotly::event_register("plotly_selected") + }) + }) +} - y_var_label <- attr(df[[y_var]], "label") - if (!length(y_var_label)) y_var_label <- y_var +#' Create Line Plot with Plotly +#' +#' This function generates plotly code for creating interactive line plots +#' that connect data points within groups to show trends over time. +#' +#' @param df (`character(1)`) Name of the data frame containing the plotting data +#' @param x_var (`character(1)`) Name of the x-axis variable +#' @param y_var (`character(1)`) Name of the y-axis variable +#' @param color_var (`character(1)`) Name of the color variable +#' @param group_var (`character(1)`) Name of the grouping variable +#' @param colors (`named character` or `NULL`) Color mapping for groups +#' @param tooltip_vars (`character` or `NULL`) Variables to include in tooltip +#' @param reference_lines (`list` or `NULL`) Reference lines specification +#' @param source (`character(1)`) Plotly source identifier for events +#' +#' @return A substitute expression that creates a plotly object with line segments and markers +#' @keywords internal +lineplotly <- function(df, + x_var, + y_var, + color_var, + group_var, + colors = NULL, + tooltip_vars = NULL, + reference_lines = NULL, + source = "lineplot") { + substitute( + { + validate(need(nrow(df_sym) > 0, "No data after applying filters.")) - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var + group_var_label <- attr(df_sym[[group_var_str]], "label") + if (!length(group_var_label)) group_var_label <- group_var_str - # 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 = "
")) - } - } - } - ) + x_var_label <- attr(df_sym[[x_var_str]], "label") + if (!length(x_var_label)) x_var_label <- x_var_str - 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) - } + y_var_label <- attr(df_sym[[y_var_str]], "label") + if (!length(y_var_label)) y_var_label <- y_var_str - 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)) + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str - 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" + df_sym <- df_sym |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars_sym)) { + paste( + paste(group_var_label, ":", !!as.name(group_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" ) - - 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 + } else { + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + paste( + paste(group_var_label, ":", !!as.name(group_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" ) + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == group_var_str) { + lb <- group_var_label + } else if (cn == x_var_str) { + lb <- x_var_label + } else if (cn == y_var_str) { + lb <- y_var_label + } else if (cn == color_var_str) { + 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 = "
")) + } } - }, - 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 + } ) - }) + 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) + } - output$plot <- plotly::renderPlotly({ - plotly_q()$p %>% - plotly::event_register("plotly_selected") - }) - }) + segments_df <- df_sym %>% + dplyr::arrange(!!as.name(group_var_str), !!as.name(x_var_str)) %>% + dplyr::group_by(!!as.name(group_var_str)) %>% + dplyr::mutate( + xend = dplyr::lead(!!as.name(x_var_str)), + yend = dplyr::lead(!!as.name(y_var_str)), + color_var_seg = dplyr::lead(!!as.name(color_var_str)) + ) %>% + dplyr::filter(!is.na(xend)) + + p <- plotly::plot_ly( + data = segments_df, + source = source_sym, + height = 600L + ) %>% + plotly::add_segments( + x = ~x_var_sym, + y = ~y_var_sym, + xend = ~xend, + yend = ~yend, + color = ~color_var_seg, + colors = colors_sym, + showlegend = FALSE + ) %>% + plotly::add_markers( + data = df_sym, + x = ~x_var_sym, + y = ~y_var_sym, + color = ~color_var_sym, + colors = colors_sym, + text = ~tooltip, + hoverinfo = "text" + ) + + if (!is.null(reference_lines_sym)) { + ref_lines <- add_reference_lines(df_sym, reference_lines_sym) + p <- p %>% + plotly::layout( + shapes = ref_lines$shapes, + annotations = ref_lines$annotations + ) + } + }, + list( + df_sym = str2lang(df), + x_var_sym = str2lang(x_var), + y_var_sym = str2lang(y_var), + color_var_sym = str2lang(color_var), + group_var_sym = str2lang(group_var), + x_var_str = x_var, + y_var_str = y_var, + color_var_str = color_var, + group_var_str = group_var, + colors_sym = colors, + tooltip_vars_sym = tooltip_vars, + reference_lines_sym = reference_lines, + source_sym = source + ) + ) } diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index a1bff8135..5c5fa207e 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -128,134 +128,154 @@ srv_p_scatterplot <- function(id, plotly_q <- reactive({ req(color_inputs()) - within( - data(), - 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 + data() |> + within( + code, + code = scatterplotly( + df = plot_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 + ) + ) + }) - 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 + output$plot <- plotly::renderPlotly( + plotly_q()$p |> + setup_trigger_tooltips(session$ns) + ) + }) +} - color_var_label <- attr(df[[color_var]], "label") - if (!length(color_var_label)) color_var_label <- color_var +#' Generate Scatter Plotly Code +#' +#' Creates code expression that generates a scatter plot with tooltips using plotly. +#' This function includes all the data manipulation and plot creation logic +#' from tm_p_scatterplot module, including label extraction, tooltip generation, +#' and event registration. +#' +#' @param df (`language`) Symbol representing the data frame to plot +#' @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 subject_var (`character(1)`) Name of the subject variable +#' @param colors (`character`) Named vector of colors for color_var levels +#' @param source (`character(1)`) Source identifier for plotly events +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing subject, x, y, and color variables. +#' +#' @return A code expression that when evaluated creates a plotly plot object +#' +#' @examples +#' # Generate code for a scatter plot +#' code <- scatterplotly( +#' df = quote(iris_data), +#' x_var = "Sepal.Length", +#' y_var = "Petal.Length", +#' color_var = "Species", +#' subject_var = "row_id", +#' colors = c("setosa" = "red", "versicolor" = "blue", "virginica" = "green"), +#' source = "scatterplot", +#' tooltip_vars = c("Sepal.Width", "Petal.Width") +#' ) +#' +scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, source, tooltip_vars = NULL) { + substitute( + { + subject_var_label <- attr(df_sym[[subject_var_str]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var_str - 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 = "
")) - } - } - } - ) + x_var_label <- attr(df_sym[[x_var_str]], "label") + if (!length(x_var_label)) x_var_label <- x_var_str - p <- 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") + y_var_label <- attr(df_sym[[y_var_str]], "label") + if (!length(y_var_label)) y_var_label <- y_var_str - p - }, - df = str2lang(plot_dataname) - ) - }) + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + plot_data <- df_sym |> + dplyr::mutate(!!as.name(color_var_str) := factor(!!as.name(color_var_str), levels = names(colors_sym))) |> + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars_sym)) { + paste( + paste(subject_var_label, ":", !!as.name(subject_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" + ) + } else { + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + paste( + paste(subject_var_label, ":", !!as.name(subject_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" + ) + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var_str) { + lb <- subject_var_label + } else if (cn == x_var_str) { + lb <- x_var_label + } else if (cn == y_var_str) { + lb <- y_var_label + } else if (cn == color_var_str) { + 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 = "
")) + } + } + } + ) - output$plot <- plotly::renderPlotly( - plotly_q()$p |> - setup_trigger_tooltips(session$ns) |> - set_plot_data(session$ns("plot_data")) |> + p <- plotly::plot_ly( + data = plot_data, + source = source_sym, + colors = colors_sym, + customdata = ~customdata + ) |> + plotly::add_markers( + x = ~x_var_sym, + y = ~y_var_sym, + color = ~color_var_sym, + text = ~tooltip, + hoverinfo = "text" + ) |> + plotly::layout(dragmode = "select") |> plotly::event_register("plotly_selected") + }, + list( + df_sym = str2lang(df), + x_var_sym = str2lang(x_var), + y_var_sym = str2lang(y_var), + color_var_sym = str2lang(color_var), + subject_var_sym = str2lang(subject_var), + x_var_str = x_var, + y_var_str = y_var, + color_var_str = color_var, + subject_var_str = subject_var, + colors_sym = colors, + source_sym = source, + tooltip_vars_sym = tooltip_vars ) - - - 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(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 index 3d509269f..c822f9a99 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -60,7 +60,7 @@ #' } #' #' @export -tm_p_spaghetti <- function(label = "Scatter Plot", +tm_p_spaghetti <- function(label = "Spaghetti Plot", plot_dataname, group_var, x_var, @@ -131,121 +131,20 @@ srv_p_spaghetti <- function(id, 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 = 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, - 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) - ) + data() |> + within( + code, + code = spaghettiplotly( + df = plot_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 + ) + ) }) @@ -281,3 +180,151 @@ srv_p_spaghetti <- function(id, }) }) } + +#' Generate Spaghetti Plotly Code +#' +#' Creates code expression that generates a spaghetti plot with tooltips using plotly. +#' This function includes all the data manipulation and plot creation logic +#' from tm_p_spaghetti module, including label extraction, tooltip generation, +#' line segments creation, and event registration. +#' +#' @param df (`character(1)`) Name of the data frame to plot +#' @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 colors (`character`) Named vector of colors for color_var levels +#' @param source (`character(1)`) Source identifier for plotly events +#' @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. +#' +#' @return A code expression that when evaluated creates a plotly plot object +#' +#' @examples +#' # Generate code for a spaghetti plot +#' code <- spaghettiplotly( +#' df = "longitudinal_data", +#' group_var = "subject_id", +#' x_var = "time_point", +#' y_var = "response", +#' color_var = "treatment", +#' colors = c("Active" = "red", "Placebo" = "blue"), +#' source = "spaghetti", +#' tooltip_vars = c("subject_id", "treatment") +#' ) +#' +spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, source, tooltip_vars = NULL) { + substitute( + { + group_var_label <- attr(df_sym[[group_var_str]], "label") + if (!length(group_var_label)) group_var_label <- group_var_str + + x_var_label <- attr(df_sym[[x_var_str]], "label") + if (!length(x_var_label)) x_var_label <- x_var_str + + y_var_label <- attr(df_sym[[y_var_str]], "label") + if (!length(y_var_label)) y_var_label <- y_var_str + + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + + plot_data <- df_sym |> + dplyr::select(!!as.name(group_var_str), !!as.name(x_var_str), !!as.name(y_var_str), !!as.name(color_var_str)) |> + dplyr::mutate(!!as.name(color_var_str) := factor(!!as.name(color_var_str), levels = names(colors_sym))) %>% + dplyr::mutate(customdata = dplyr::row_number()) |> + dplyr::mutate( + tooltip = { + if (is.null(tooltip_vars_sym)) { + paste( + paste(group_var_label, ":", !!as.name(group_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" + ) + } else { + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + paste( + paste(group_var_label, ":", !!as.name(group_var_str)), + paste(x_var_label, ":", !!as.name(x_var_str)), + paste(y_var_label, ":", !!as.name(y_var_str)), + paste(color_var_label, ":", !!as.name(color_var_str)), + sep = "
" + ) + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == group_var_str) { + lb <- group_var_label + } else if (cn == x_var_str) { + lb <- x_var_label + } else if (cn == y_var_str) { + lb <- y_var_label + } else if (cn == color_var_str) { + 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_str), !!as.name(x_var_str)) %>% + dplyr::group_by(!!as.name(group_var_str)) %>% + dplyr::mutate( + x = !!as.name(x_var_str), + y = !!as.name(y_var_str), + xend = dplyr::lead(!!as.name(x_var_str)), + yend = dplyr::lead(!!as.name(y_var_str)), + color_var_seg = dplyr::lead(!!as.name(color_var_str)) + ) %>% + dplyr::filter(!is.na(xend)) + + p <- plotly::plot_ly( + data = segments_df, + customdata = ~customdata, + source = source_sym + ) %>% + plotly::add_segments( + x = ~x, y = ~y, + xend = ~xend, yend = ~yend, + color = ~color_var_seg, + colors = colors_sym, + showlegend = TRUE + ) %>% + plotly::add_markers( + data = plot_data, + x = ~x_var_sym, + y = ~y_var_sym, + color = ~color_var_sym, + colors = colors_sym, + text = ~tooltip, + hoverinfo = "text" + ) |> + plotly::layout(dragmode = "select") + }, + list( + df_sym = str2lang(df), + group_var_sym = str2lang(group_var), + x_var_sym = str2lang(x_var), + y_var_sym = str2lang(y_var), + color_var_sym = str2lang(color_var), + group_var_str = group_var, + x_var_str = x_var, + y_var_str = y_var, + color_var_str = color_var, + colors_sym = colors, + source_sym = source, + tooltip_vars_sym = tooltip_vars + ) + ) +} diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 56e221329..e5f4fdff0 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -26,6 +26,7 @@ #' If `NULL`, default colors will be used. #' @param point_symbols (`named character` or `NULL`) Valid plotly symbol names named by levels of `color_var` column. #' If `NULL`, default symbols will be used. +#' @param plot_height (`numeric(3)`) Vector of length 3 with c(default, min, max) plot height values. #' #' @inherit shared_params return #' @@ -226,130 +227,27 @@ srv_p_spiderplot <- function(id, 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, - colors = color_inputs(), - 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, - source = session$ns("spiderplot"), - 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") - 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 - 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()) - - if (is.null(size_var)) { - size <- point_size - } else { - size <- stats::as.formula(sprintf("~%s", size_var)) - } - - 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), - time_var_label, !!as.name(time_var), - value_var_label, !!as.name(value_var) * 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 = title, - dragmode = "select" - ) %>% - plotly::config(displaylogo = FALSE) %>% - plotly::layout(title = title) - } - ) + data() |> + within( + code, + code = spiderplotly( + df = plot_dataname, + 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, + colors = color_inputs(), + 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, + source = session$ns("spiderplot") + ) + ) }) output$plot <- output$plot <- plotly::renderPlotly(plotly::event_register( @@ -372,40 +270,183 @@ srv_p_spiderplot <- function(id, 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) - ) - }) +#' Generate Spider Plotly Code +#' +#' Creates code expression that generates a spider plot with tooltips using plotly. +#' This function includes all the data manipulation and plot creation logic +#' from tm_p_spiderplot module, including filtering, label extraction, tooltip generation, +#' line segments creation, and event registration. +#' +#' @param df (`character(1)`) Name of the data frame to plot +#' @param time_var (`character(1)`) Name of the numeric column to be used as x-axis +#' @param value_var (`character(1)`) Name of the numeric column to be used as y-axis +#' @param subject_var (`character(1)`) Name of the factor or character column to be used as grouping variable +#' @param filter_event_var (`character(1)`) Name of the factor or character column to be used to filter the data +#' @param selected_event (`character(1)`) Selected event value for filtering +#' @param color_var (`character(1)`) Name of the factor or character column to be used to differentiate colors and symbols +#' @param colors (`character`) Named vector of colors for color_var levels +#' @param symbols (`character`) Named vector of plotly symbols for color_var levels +#' @param size_var (`character(1)` or `NULL`) If provided, this numeric column will determine point size +#' @param height (`numeric(1)`) Plot height in pixels +#' @param point_size (`numeric(1)`) Fixed point size when size_var is NULL +#' @param title (`character(1)`) Plot title +#' @param source (`character(1)`) Source identifier for plotly events +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing time, value, subject, and color variables. +#' +#' @return A code expression that when evaluated creates a plotly plot object +#' +#' @examples +#' # Generate code for a spider plot +#' code <- spiderplotly( +#' df = "spider_data", +#' time_var = "time_point", +#' value_var = "response", +#' subject_var = "subject_id", +#' filter_event_var = "event_type", +#' selected_event = "response", +#' color_var = "treatment", +#' colors = c("Active" = "red", "Placebo" = "blue"), +#' symbols = c("Active" = "circle", "Placebo" = "square"), +#' size_var = NULL, +#' height = 600, +#' point_size = 10, +#' title = "Spider Plot", +#' source = "spiderplot", +#' tooltip_vars = c("subject_id", "treatment") +#' ) +#' +spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, selected_event, + color_var, colors, symbols, size_var = NULL, height = 600, point_size = 10, + title = "Spider Plot", source, tooltip_vars = NULL) { + substitute( + { + plot_data <- df_sym %>% + dplyr::filter(!!as.name(filter_event_var_str) == selected_event_sym) %>% + dplyr::arrange(!!as.name(subject_var_str), !!as.name(time_var_str)) %>% + dplyr::group_by(!!as.name(subject_var_str)) - plotly_selected <- reactive( - plotly::event_data("plotly_selected", source = session$ns("spiderplot")) - ) + subject_var_label <- attr(plot_data[[subject_var_str]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var_str + time_var_label <- attr(plot_data[[time_var_str]], "label") + if (!length(time_var_label)) time_var_label <- time_var_str + value_var_label <- attr(plot_data[[value_var_str]], "label") + if (!length(value_var_label)) value_var_label <- value_var_str + color_var_label <- attr(plot_data[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + + plot_data <- plot_data |> + dplyr::mutate(customdata = dplyr::row_number()) - reactive({ - if (is.null(plotly_selected())) { - plotly_q() + if (is.null(size_var_sym)) { + size <- point_size_sym } 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$selected, - plotly_selected_customdata = plotly_selected()$customdata - ) - attr(q, "has_brushing") <- TRUE - q + size <- ~size_var_lang } - }) - }) + + p <- plot_data %>% + dplyr::ungroup() %>% + dplyr::mutate( + x = dplyr::lag(!!as.name(time_var_str), default = 0), + y = dplyr::lag(!!as.name(value_var_str), default = 0), + tooltip = { + if (is.null(tooltip_vars_sym)) { + sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var_str), + time_var_label, !!as.name(time_var_str), + value_var_label, !!as.name(value_var_str) * 100 + ) + } else { + cur_data <- dplyr::cur_data() + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + sprintf( + "%s: %s
%s: %s
%s: %s%%
", + subject_var_label, !!as.name(subject_var_str), + time_var_label, !!as.name(time_var_str), + value_var_label, !!as.name(value_var_str) * 100 + ) + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var_str) { + lb <- subject_var_label + } else if (cn == time_var_str) { + lb <- time_var_label + } else if (cn == value_var_str) { + lb <- value_var_label + } else if (cn == color_var_str) { + 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_sym, + height = height_sym, + color = ~color_var_sym, + colors = colors_sym, + symbols = symbols_sym + ) %>% + plotly::add_segments( + x = ~x, + y = ~y, + xend = ~time_var_sym, + yend = ~value_var_sym, + customdata = NULL + ) %>% + plotly::add_markers( + x = ~time_var_sym, + y = ~value_var_sym, + symbol = ~color_var_sym, + size = size, + text = ~tooltip, + hoverinfo = "text", + customdata = ~customdata + ) %>% + plotly::layout( + xaxis = list(title = time_var_label), + yaxis = list(title = value_var_label), + title = title_sym, + dragmode = "select" + ) %>% + plotly::config(displaylogo = FALSE) %>% + plotly::layout(title = title_sym) + }, + list( + df_sym = str2lang(df), + time_var_sym = str2lang(time_var), + value_var_sym = str2lang(value_var), + subject_var_sym = str2lang(subject_var), + color_var_sym = str2lang(color_var), + size_var_lang = if (!is.null(size_var)) str2lang(size_var) else NULL, + time_var_str = time_var, + value_var_str = value_var, + subject_var_str = subject_var, + filter_event_var_str = filter_event_var, + color_var_str = color_var, + selected_event_sym = selected_event, + colors_sym = colors, + symbols_sym = symbols, + size_var_sym = size_var, + height_sym = height, + point_size_sym = point_size, + title_sym = title, + source_sym = source, + tooltip_vars_sym = tooltip_vars + ) + ) } diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 1d79962da..861e6e8eb 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -26,6 +26,8 @@ #' If `NULL`, default colors will be used. #' @param point_symbols (`named character` or `NULL`) Valid plotly symbol names named by levels of `color_var` column. #' If `NULL`, default symbols will be used. +#' @param plot_height (`numeric(3)`) Vector of length 3 with c(default, min, max) plot height values. +#' @param show_widgets (`logical(1)`) Whether to show module widgets. #' #' @inherit shared_params return #' @@ -197,151 +199,24 @@ srv_p_swimlane <- function(id, 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) - } - ) + data() |> + within( + code, + code = swimlaneplotly( + df = 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") + ) + ) }) output$plot <- plotly::renderPlotly({ @@ -350,25 +225,196 @@ srv_p_swimlane <- function(id, setup_trigger_tooltips(session$ns) |> plotly::event_register("plotly_selected") }) + }) +} - plotly_selected <- reactive({ - plotly::event_data("plotly_selected", source = session$ns("swimlane")) - }) +#' Generate Swimlane Plotly Code +#' +#' Creates code expression that generates a swimlane plot with tooltips using plotly. +#' This function includes all the data manipulation and plot creation logic +#' from tm_p_swimlane module, including subject sorting, label extraction, tooltip generation, +#' marker and segment creation, and event registration. +#' +#' @param df (`character(1)`) Name of the data frame to plot +#' @param time_var (`character(1)`) Name of the numeric column to be used as x-axis +#' @param subject_var (`character(1)`) Name of the factor or character column to be used as y-axis (subject lanes) +#' @param color_var (`character(1)`) Name of the factor or character column to name and color subject events in time +#' @param group_var (`character(1)`) Name of the factor or character column to categorize type of event +#' @param sort_var (`character(1)`) Name of the column whose values determine the order of subjects displayed on the y-axis +#' @param point_size (`numeric(1)` or `named numeric`) Default point size or named vector of sizes by color_var levels +#' @param colors (`character`) Named vector of colors for color_var levels +#' @param symbols (`character`) Named vector of plotly symbols for color_var levels +#' @param height (`numeric(1)`) Plot height in pixels +#' @param source (`character(1)`) Source identifier for plotly events +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing subject, time, and group variables. +#' +#' @return A code expression that when evaluated creates a plotly plot object +#' +#' @examples +#' # Generate code for a swimlane plot +#' code <- swimlaneplotly( +#' df = "swimlane_data", +#' time_var = "time_point", +#' subject_var = "subject_id", +#' color_var = "event_type", +#' group_var = "event_category", +#' sort_var = "time_point", +#' point_size = 10, +#' colors = c("Event1" = "red", "Event2" = "blue"), +#' symbols = c("Event1" = "circle", "Event2" = "square"), +#' height = 700, +#' source = "swimlane", +#' tooltip_vars = c("subject_id", "event_type") +#' ) +#' +swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort_var, + point_size = 10, colors, symbols, height = 700, source, tooltip_vars = NULL) { + substitute( + { + subject_var_label <- attr(df_sym[[subject_var_str]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var_str + time_var_label <- attr(df_sym[[time_var_str]], "label") + if (!length(time_var_label)) time_var_label <- time_var_str - 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 - ) - }) - }) + plot_data <- df_sym |> + dplyr::mutate(customdata = dplyr::row_number()) + + subject_levels <- plot_data %>% + dplyr::group_by(!!as.name(subject_var_str)) %>% + dplyr::summarize(v = max(!!as.name(sort_var_str))) %>% + dplyr::ungroup() %>% + dplyr::arrange(v) %>% + dplyr::pull(!!as.name(subject_var_str)) + plot_data[[subject_var_str]] <- factor(plot_data[[subject_var_str]], levels = subject_levels) + + min_size <- min(point_size_sym, na.rm = TRUE) + + if (length(point_size_sym) > 1) { + plot_data <- plot_data %>% + dplyr::mutate( + size_var = ifelse( + as.character(!!as.name(color_var_str)) %in% names(point_size_sym), + point_size_sym[as.character(!!as.name(color_var_str))], + min_size + ) + ) + } else { + plot_data <- plot_data %>% + dplyr::mutate(size_var = point_size_sym) + } + + p <- plot_data %>% + dplyr::mutate( + !!as.name(color_var_str) := { + original_label <- attr(.data[[color_var_str]], "label") + new_factor <- factor(.data[[color_var_str]], levels = names(colors_sym)) + attr(new_factor, "label") <- original_label + new_factor + } + ) %>% + dplyr::group_by(!!as.name(subject_var_str), !!as.name(time_var_str)) %>% + dplyr::mutate( + tooltip = { + default_tip <- paste( + unique( + c( + paste(subject_var_label, !!as.name(subject_var_str)), + paste(time_var_label, !!as.name(time_var_str)), + sprintf( + "%s: %s", + tools::toTitleCase(gsub("[^0-9A-Za-z]+", " ", !!as.name(group_var_str))), + !!as.name(color_var_str) + ) + ) + ), + collapse = "
" + ) + if (is.null(tooltip_vars_sym)) { + default_tip + } else { + cur_data <- dplyr::cur_data() + grouping_vars <- list() + grouping_vars[[subject_var_str]] <- dplyr::cur_group()[[subject_var_str]] + grouping_vars[[time_var_str]] <- dplyr::cur_group()[[time_var_str]] + cur_data <- c(cur_data, grouping_vars) + + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + default_tip + } else { + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var_str) { + lb <- subject_var_label + } else if (cn == time_var_str) { + 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_sym, + colors = colors_sym, + symbols = symbols_sym, + height = height_sym, + customdata = ~customdata + ) %>% + plotly::add_markers( + x = ~time_var_sym, + y = ~subject_var_sym, + color = ~color_var_sym, + symbol = ~color_var_sym, + size = ~size_var, + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::add_segments( + x = ~0, + xend = ~study_day, + y = ~subject_var_sym, + yend = ~subject_var_sym, + data = plot_data |> + dplyr::group_by(!!as.name(subject_var_str), !!as.name(group_var_str)) |> + dplyr::summarise(study_day = max(!!as.name(time_var_str))), + 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) + }, + list( + df_sym = str2lang(df), + time_var_sym = str2lang(time_var), + subject_var_sym = str2lang(subject_var), + color_var_sym = str2lang(color_var), + group_var_sym = str2lang(group_var), + sort_var_sym = str2lang(sort_var), + time_var_str = time_var, + subject_var_str = subject_var, + color_var_str = color_var, + group_var_str = group_var, + sort_var_str = sort_var, + point_size_sym = point_size, + colors_sym = colors, + symbols_sym = symbols, + height_sym = height, + source_sym = source, + tooltip_vars_sym = tooltip_vars + ) + ) } diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index da9ac0e65..e16932732 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -14,6 +14,8 @@ #' to be used as x-axis (subject identifiers). #' @param value_var (`character(1)`) Name of the numeric column in `plot_dataname` #' to be used as y-axis (values determining bar heights). +#' @param sort_var (`character(1)` or `NULL`) Name of the column used for sorting subjects. +#' If `NULL`, defaults to `value_var`. #' @param color_var (`character(1)` or `NULL`) Name of the factor or character column in `plot_dataname` #' to be used to differentiate bar colors. If `NULL`, all bars will have the same color. #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. @@ -23,6 +25,7 @@ #' @param value_arbitrary_hlines (`numeric` or `NULL`) Values in the same scale as `value_var` to add #' horizontal reference lines on the plot. #' @param plot_title (`character` or `NULL`) Title of the plot. If `NULL`, no title is displayed. +#' @param plot_height (`numeric(3)`) Vector of length 3 with c(default, min, max) plot height values. #' #' @inherit shared_params return #' @@ -174,121 +177,175 @@ srv_p_waterfall <- function(id, 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 + data() |> + within( + code, + code = waterfallplotly( + df = 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 = "Waterfall plot", + tooltip_vars = tooltip_vars, + source = session$ns("waterfall") + ) + ) + }) + output$plot <- plotly::renderPlotly(plotly::event_register(plotly_q()$p, "plotly_selected")) + }) +} - plot_data <- dplyr::mutate( - if (identical(sort_var, value_var) || is.null(sort_var)) { - dplyr::arrange(dataname, desc(!!as.name(value_var))) +#' Generate Waterfall Plotly Code +#' +#' Creates code expression that generates a waterfall plot with tooltips using plotly. +#' This function includes all the data manipulation and plot creation logic +#' from tm_p_waterfall module, including sorting, label extraction, tooltip generation, +#' bar chart creation, and horizontal reference lines. +#' +#' @param df (`character(1)`) Name of the data frame to plot +#' @param subject_var (`character(1)`) Name of the factor or character column to be used as x-axis (subject identifiers) +#' @param value_var (`character(1)`) Name of the numeric column to be used as y-axis (values determining bar heights) +#' @param sort_var (`character(1)` or `NULL`) Name of the column whose values determine sorting order. If `NULL` or same as `value_var`, sorts by value_var descending +#' @param color_var (`character(1)` or `NULL`) Name of the factor or character column to differentiate bar colors. If `NULL`, all bars have same color +#' @param colors (`character`) Named vector of colors for color_var levels +#' @param value_arbitrary_hlines (`numeric` or `NULL`) Values for horizontal reference lines +#' @param height (`numeric(1)`) Plot height in pixels +#' @param title (`character(1)`) Plot title +#' @param source (`character(1)`) Source identifier for plotly events +#' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. +#' If `NULL`, default tooltip is created showing subject, value, and color variables. +#' +#' @return A code expression that when evaluated creates a plotly plot object +#' +#' @examples +#' # Generate code for a waterfall plot +#' code <- waterfallplotly( +#' df = "waterfall_data", +#' subject_var = "subject_id", +#' value_var = "response_value", +#' sort_var = "response_value", +#' color_var = "response_category", +#' colors = c("CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red"), +#' value_arbitrary_hlines = c(20, -30), +#' height = 600, +#' title = "Response Waterfall Plot", +#' source = "waterfall", +#' tooltip_vars = c("subject_id", "response_category") +#' ) +#' +waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_var = NULL, + colors, value_arbitrary_hlines = NULL, height = 600, + title = "Waterfall plot", source, tooltip_vars = NULL) { + substitute( + { + subject_var_label <- attr(df_sym[[subject_var_str]], "label") + if (!length(subject_var_label)) subject_var_label <- subject_var_str + value_var_label <- attr(df_sym[[value_var_str]], "label") + if (!length(value_var_label)) value_var_label <- value_var_str + color_var_label <- attr(df_sym[[color_var_str]], "label") + if (!length(color_var_label)) color_var_label <- color_var_str + + plot_data <- dplyr::mutate( + if (identical(sort_var_str, value_var_str) || is.null(sort_var_str)) { + dplyr::arrange(df_sym, desc(!!as.name(value_var_str))) + } else { + dplyr::arrange(df_sym, !!as.name(sort_var_str), desc(!!as.name(value_var_str))) + }, + !!as.name(subject_var_str) := factor(!!as.name(subject_var_str), levels = unique(!!as.name(subject_var_str))), + tooltip = { + default_tip <- sprintf( + "%s: %s
%s: %s%%
%s: %s", + subject_var_label, !!as.name(subject_var_str), + value_var_label, !!as.name(value_var_str), + color_var_label, !!as.name(color_var_str) + ) + if (is.null(tooltip_vars_sym)) { + default_tip + } else { + cur_data <- dplyr::pick(dplyr::everything()) + cols <- intersect(tooltip_vars_sym, names(cur_data)) + if (!length(cols)) { + default_tip } 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 + sub <- cur_data[cols] + labels <- vapply(cols, function(cn) { + if (cn == subject_var_str) { + lb <- subject_var_label + } else if (cn == value_var_str) { + lb <- value_var_label + } else if (cn == color_var_str) { + lb <- color_var_label } 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 = "
")) + 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")) + } + } + ) %>% + dplyr::filter(!duplicated(!!as.name(subject_var_str))) %>% + dplyr::mutate(customdata = dplyr::row_number()) - 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 - ) - }) - }) + p <- plotly::plot_ly( + data = plot_data, + source = source_sym, + customdata = ~customdata, + height = height_sym + ) %>% + plotly::add_bars( + x = ~subject_var_sym, + y = ~value_var_sym, + color = ~color_var_sym, + colors = colors_sym, + text = ~tooltip, + hoverinfo = "text" + ) %>% + plotly::layout( + shapes = lapply(value_arbitrary_hlines_sym, 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_sym) + }, + list( + df_sym = str2lang(df), + subject_var_sym = str2lang(subject_var), + value_var_sym = str2lang(value_var), + sort_var_sym = if (!is.null(sort_var)) str2lang(sort_var) else NULL, + color_var_sym = if (!is.null(color_var)) str2lang(color_var) else NULL, + subject_var_str = subject_var, + value_var_str = value_var, + sort_var_str = sort_var, + color_var_str = color_var, + colors_sym = colors, + value_arbitrary_hlines_sym = value_arbitrary_hlines, + height_sym = height, + title_sym = title, + source_sym = source, + tooltip_vars_sym = tooltip_vars + ) + ) } diff --git a/man/bargraphplotly.Rd b/man/bargraphplotly.Rd new file mode 100644 index 000000000..90ab071b0 --- /dev/null +++ b/man/bargraphplotly.Rd @@ -0,0 +1,39 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_bargraph.R +\name{bargraphplotly} +\alias{bargraphplotly} +\title{Create Bar Graph with Plotly} +\usage{ +bargraphplotly( + df, + y_var, + color_var, + count_var, + tooltip_vars = NULL, + bar_colors = NULL, + source = "bargraph" +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame containing the plotting data} + +\item{y_var}{(\code{character(1)}) Name of the y-axis variable} + +\item{color_var}{(\code{character(1)}) Name of the color variable} + +\item{count_var}{(\code{character(1)}) Name of the count variable} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) Variables to include in tooltip} + +\item{bar_colors}{(\verb{named character} or \code{NULL}) Color mapping for groups} + +\item{source}{(\code{character(1)}) Plotly source identifier for events} +} +\value{ +A substitute expression that creates a plotly object with horizontal stacked bars +} +\description{ +This function generates plotly code for creating interactive horizontal stacked bar charts +that display counts of distinct values grouped by categories. +} +\keyword{internal} diff --git a/man/lineplotly.Rd b/man/lineplotly.Rd new file mode 100644 index 000000000..7879a3bc6 --- /dev/null +++ b/man/lineplotly.Rd @@ -0,0 +1,45 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_lineplot.R +\name{lineplotly} +\alias{lineplotly} +\title{Create Line Plot with Plotly} +\usage{ +lineplotly( + df, + x_var, + y_var, + color_var, + group_var, + colors = NULL, + tooltip_vars = NULL, + reference_lines = NULL, + source = "lineplot" +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame containing the plotting data} + +\item{x_var}{(\code{character(1)}) Name of the x-axis variable} + +\item{y_var}{(\code{character(1)}) Name of the y-axis variable} + +\item{color_var}{(\code{character(1)}) Name of the color variable} + +\item{group_var}{(\code{character(1)}) Name of the grouping variable} + +\item{colors}{(\verb{named character} or \code{NULL}) Color mapping for groups} + +\item{tooltip_vars}{(\code{character} or \code{NULL}) Variables to include in tooltip} + +\item{reference_lines}{(\code{list} or \code{NULL}) Reference lines specification} + +\item{source}{(\code{character(1)}) Plotly source identifier for events} +} +\value{ +A substitute expression that creates a plotly object with line segments and markers +} +\description{ +This function generates plotly code for creating interactive line plots +that connect data points within groups to show trends over time. +} +\keyword{internal} diff --git a/man/scatterplotly.Rd b/man/scatterplotly.Rd new file mode 100644 index 000000000..0ce783b03 --- /dev/null +++ b/man/scatterplotly.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_scatterplot.R +\name{scatterplotly} +\alias{scatterplotly} +\title{Generate Scatter Plotly Code} +\usage{ +scatterplotly( + df, + x_var, + y_var, + color_var, + subject_var, + colors, + source, + tooltip_vars = NULL +) +} +\arguments{ +\item{df}{(\code{language}) Symbol representing the data frame to plot} + +\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{subject_var}{(\code{character(1)}) Name of the subject variable} + +\item{colors}{(\code{character}) Named vector of colors for color_var levels} + +\item{source}{(\code{character(1)}) Source identifier for plotly events} + +\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 subject, x, y, and color variables.} +} +\value{ +A code expression that when evaluated creates a plotly plot object +} +\description{ +Creates code expression that generates a scatter plot with tooltips using plotly. +This function includes all the data manipulation and plot creation logic +from tm_p_scatterplot module, including label extraction, tooltip generation, +and event registration. +} +\examples{ +# Generate code for a scatter plot +code <- scatterplotly( + df = quote(iris_data), + x_var = "Sepal.Length", + y_var = "Petal.Length", + color_var = "Species", + subject_var = "row_id", + colors = c("setosa" = "red", "versicolor" = "blue", "virginica" = "green"), + source = "scatterplot", + tooltip_vars = c("Sepal.Width", "Petal.Width") +) + +} diff --git a/man/spaghettiplotly.Rd b/man/spaghettiplotly.Rd new file mode 100644 index 000000000..cd5dee53e --- /dev/null +++ b/man/spaghettiplotly.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_spaghetti.R +\name{spaghettiplotly} +\alias{spaghettiplotly} +\title{Generate Spaghetti Plotly Code} +\usage{ +spaghettiplotly( + df, + group_var, + x_var, + y_var, + color_var, + colors, + source, + tooltip_vars = NULL +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame to plot} + +\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{colors}{(\code{character}) Named vector of colors for color_var levels} + +\item{source}{(\code{character(1)}) Source identifier for plotly events} + +\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.} +} +\value{ +A code expression that when evaluated creates a plotly plot object +} +\description{ +Creates code expression that generates a spaghetti plot with tooltips using plotly. +This function includes all the data manipulation and plot creation logic +from tm_p_spaghetti module, including label extraction, tooltip generation, +line segments creation, and event registration. +} +\examples{ +# Generate code for a spaghetti plot +code <- spaghettiplotly( + df = "longitudinal_data", + group_var = "subject_id", + x_var = "time_point", + y_var = "response", + color_var = "treatment", + colors = c("Active" = "red", "Placebo" = "blue"), + source = "spaghetti", + tooltip_vars = c("subject_id", "treatment") +) + +} diff --git a/man/spiderplotly.Rd b/man/spiderplotly.Rd new file mode 100644 index 000000000..f362ed2ab --- /dev/null +++ b/man/spiderplotly.Rd @@ -0,0 +1,86 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_spiderplot.R +\name{spiderplotly} +\alias{spiderplotly} +\title{Generate Spider Plotly Code} +\usage{ +spiderplotly( + df, + time_var, + value_var, + subject_var, + filter_event_var, + selected_event, + color_var, + colors, + symbols, + size_var = NULL, + height = 600, + point_size = 10, + title = "Spider Plot", + source, + tooltip_vars = NULL +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame to plot} + +\item{time_var}{(\code{character(1)}) Name of the numeric column to be used as x-axis} + +\item{value_var}{(\code{character(1)}) Name of the numeric column to be used as y-axis} + +\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as grouping variable} + +\item{filter_event_var}{(\code{character(1)}) Name of the factor or character column to be used to filter the data} + +\item{selected_event}{(\code{character(1)}) Selected event value for filtering} + +\item{color_var}{(\code{character(1)}) Name of the factor or character column to be used to differentiate colors and symbols} + +\item{colors}{(\code{character}) Named vector of colors for color_var levels} + +\item{symbols}{(\code{character}) Named vector of plotly symbols for color_var levels} + +\item{size_var}{(\code{character(1)} or \code{NULL}) If provided, this numeric column will determine point size} + +\item{height}{(\code{numeric(1)}) Plot height in pixels} + +\item{point_size}{(\code{numeric(1)}) Fixed point size when size_var is NULL} + +\item{title}{(\code{character(1)}) Plot title} + +\item{source}{(\code{character(1)}) Source identifier for plotly events} + +\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 time, value, subject, and color variables.} +} +\value{ +A code expression that when evaluated creates a plotly plot object +} +\description{ +Creates code expression that generates a spider plot with tooltips using plotly. +This function includes all the data manipulation and plot creation logic +from tm_p_spiderplot module, including filtering, label extraction, tooltip generation, +line segments creation, and event registration. +} +\examples{ +# Generate code for a spider plot +code <- spiderplotly( + df = "spider_data", + time_var = "time_point", + value_var = "response", + subject_var = "subject_id", + filter_event_var = "event_type", + selected_event = "response", + color_var = "treatment", + colors = c("Active" = "red", "Placebo" = "blue"), + symbols = c("Active" = "circle", "Placebo" = "square"), + size_var = NULL, + height = 600, + point_size = 10, + title = "Spider Plot", + source = "spiderplot", + tooltip_vars = c("subject_id", "treatment") +) + +} diff --git a/man/swimlaneplotly.Rd b/man/swimlaneplotly.Rd new file mode 100644 index 000000000..31ce7b24a --- /dev/null +++ b/man/swimlaneplotly.Rd @@ -0,0 +1,74 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_swimlane.R +\name{swimlaneplotly} +\alias{swimlaneplotly} +\title{Generate Swimlane Plotly Code} +\usage{ +swimlaneplotly( + df, + time_var, + subject_var, + color_var, + group_var, + sort_var, + point_size = 10, + colors, + symbols, + height = 700, + source, + tooltip_vars = NULL +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame to plot} + +\item{time_var}{(\code{character(1)}) Name of the numeric column to be used as x-axis} + +\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as y-axis (subject lanes)} + +\item{color_var}{(\code{character(1)}) Name of the factor or character column to name and color subject events in time} + +\item{group_var}{(\code{character(1)}) Name of the factor or character column to categorize type of event} + +\item{sort_var}{(\code{character(1)}) Name of the column whose values determine the order of subjects displayed on the y-axis} + +\item{point_size}{(\code{numeric(1)} or \verb{named numeric}) Default point size or named vector of sizes by color_var levels} + +\item{colors}{(\code{character}) Named vector of colors for color_var levels} + +\item{symbols}{(\code{character}) Named vector of plotly symbols for color_var levels} + +\item{height}{(\code{numeric(1)}) Plot height in pixels} + +\item{source}{(\code{character(1)}) Source identifier for plotly events} + +\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 subject, time, and group variables.} +} +\value{ +A code expression that when evaluated creates a plotly plot object +} +\description{ +Creates code expression that generates a swimlane plot with tooltips using plotly. +This function includes all the data manipulation and plot creation logic +from tm_p_swimlane module, including subject sorting, label extraction, tooltip generation, +marker and segment creation, and event registration. +} +\examples{ +# Generate code for a swimlane plot +code <- swimlaneplotly( + df = "swimlane_data", + time_var = "time_point", + subject_var = "subject_id", + color_var = "event_type", + group_var = "event_category", + sort_var = "time_point", + point_size = 10, + colors = c("Event1" = "red", "Event2" = "blue"), + symbols = c("Event1" = "circle", "Event2" = "square"), + height = 700, + source = "swimlane", + tooltip_vars = c("subject_id", "event_type") +) + +} diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd index d556bfa79..02db33e1a 100644 --- a/man/tm_p_spaghetti.Rd +++ b/man/tm_p_spaghetti.Rd @@ -5,7 +5,7 @@ \title{Spaghetti Plot Module} \usage{ tm_p_spaghetti( - label = "Scatter Plot", + label = "Spaghetti Plot", plot_dataname, group_var, x_var, diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 66b8b2fc5..1c7a1b125 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -51,8 +51,7 @@ If \code{NULL}, default colors will be used.} \item{point_symbols}{(\verb{named character} or \code{NULL}) Valid plotly symbol names named by levels of \code{color_var} column. If \code{NULL}, default symbols will be used.} -\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_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 12debfc2f..77d71977b 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -52,8 +52,9 @@ If \code{NULL}, default colors will be used.} \item{point_symbols}{(\verb{named character} or \code{NULL}) Valid plotly symbol names named by levels of \code{color_var} column. If \code{NULL}, default symbols will be used.} -\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_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} + +\item{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index ed77d30e2..9878a147b 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -30,6 +30,9 @@ to be used as x-axis (subject identifiers).} \item{value_var}{(\code{character(1)}) Name of the numeric column in \code{plot_dataname} to be used as y-axis (values determining bar heights).} +\item{sort_var}{(\code{character(1)} or \code{NULL}) Name of the column used for sorting subjects. +If \code{NULL}, defaults to \code{value_var}.} + \item{color_var}{(\code{character(1)} or \code{NULL}) Name of the factor or character column in \code{plot_dataname} to be used to differentiate bar colors. If \code{NULL}, all bars will have the same color.} @@ -44,8 +47,7 @@ horizontal reference lines on the plot.} \item{plot_title}{(\code{character} or \code{NULL}) Title of the plot. If \code{NULL}, no title is displayed.} -\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_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. diff --git a/man/waterfallplotly.Rd b/man/waterfallplotly.Rd new file mode 100644 index 000000000..3cfb06163 --- /dev/null +++ b/man/waterfallplotly.Rd @@ -0,0 +1,70 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/tm_p_waterfall.R +\name{waterfallplotly} +\alias{waterfallplotly} +\title{Generate Waterfall Plotly Code} +\usage{ +waterfallplotly( + df, + subject_var, + value_var, + sort_var = NULL, + color_var = NULL, + colors, + value_arbitrary_hlines = NULL, + height = 600, + title = "Waterfall plot", + source, + tooltip_vars = NULL +) +} +\arguments{ +\item{df}{(\code{character(1)}) Name of the data frame to plot} + +\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as x-axis (subject identifiers)} + +\item{value_var}{(\code{character(1)}) Name of the numeric column to be used as y-axis (values determining bar heights)} + +\item{sort_var}{(\code{character(1)} or \code{NULL}) Name of the column whose values determine sorting order. If \code{NULL} or same as \code{value_var}, sorts by value_var descending} + +\item{color_var}{(\code{character(1)} or \code{NULL}) Name of the factor or character column to differentiate bar colors. If \code{NULL}, all bars have same color} + +\item{colors}{(\code{character}) Named vector of colors for color_var levels} + +\item{value_arbitrary_hlines}{(\code{numeric} or \code{NULL}) Values for horizontal reference lines} + +\item{height}{(\code{numeric(1)}) Plot height in pixels} + +\item{title}{(\code{character(1)}) Plot title} + +\item{source}{(\code{character(1)}) Source identifier for plotly events} + +\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 subject, value, and color variables.} +} +\value{ +A code expression that when evaluated creates a plotly plot object +} +\description{ +Creates code expression that generates a waterfall plot with tooltips using plotly. +This function includes all the data manipulation and plot creation logic +from tm_p_waterfall module, including sorting, label extraction, tooltip generation, +bar chart creation, and horizontal reference lines. +} +\examples{ +# Generate code for a waterfall plot +code <- waterfallplotly( + df = "waterfall_data", + subject_var = "subject_id", + value_var = "response_value", + sort_var = "response_value", + color_var = "response_category", + colors = c("CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red"), + value_arbitrary_hlines = c(20, -30), + height = 600, + title = "Response Waterfall Plot", + source = "waterfall", + tooltip_vars = c("subject_id", "response_category") +) + +} From b560705ee7a103b27b103fa123b1aef8d371db05 Mon Sep 17 00:00:00 2001 From: vedhav Date: Sat, 27 Sep 2025 00:39:20 +0530 Subject: [PATCH 132/135] feat: standardize modules - add `transformators`, improve docs + examples, param name change, remove `as.name` --- R/module_colur_picker.R | 4 +- R/tm_p_bargraph.R | 112 +++++++++-------- R/tm_p_lineplot.R | 88 ++++++++------ R/tm_p_scatterplot.R | 109 ++++++++++------- R/tm_p_spaghetti.R | 107 ++++++++-------- R/tm_p_spiderplot.R | 262 ++++++++++++++++++++++------------------ R/tm_p_swimlane.R | 170 ++++++++++++++++---------- R/tm_p_waterfall.R | 158 +++++++++++++++--------- man/scatterplotly.Rd | 8 +- man/spiderplotly.Rd | 22 ++-- man/swimlaneplotly.Rd | 6 +- man/tm_p_bargraph.Rd | 64 ++++++++-- man/tm_p_lineplot.Rd | 40 ++++-- man/tm_p_scatterplot.Rd | 49 ++++++-- man/tm_p_spaghetti.Rd | 35 +++++- man/tm_p_spiderplot.Rd | 109 ++++++++++------- man/tm_p_swimlane.Rd | 112 +++++++++++------ man/tm_p_waterfall.Rd | 88 ++++++++++---- man/waterfallplotly.Rd | 6 +- 19 files changed, 965 insertions(+), 584 deletions(-) diff --git a/R/module_colur_picker.R b/R/module_colur_picker.R index 06fbe2b94..55cea55b1 100644 --- a/R/module_colur_picker.R +++ b/R/module_colur_picker.R @@ -12,8 +12,10 @@ colour_picker_srv <- function(id, x, default_colors) { moduleServer(id, function(input, output, session) { default_colors_adjusted <- reactive({ req(x()) + levels_filtered <- unique(x()) + levels_filtered <- levels_filtered[!is.na(levels_filtered)] .color_palette_discrete( - levels = unique(x()), + levels = levels_filtered, color = default_colors ) }) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 67ffea922..3931c3189 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -22,36 +22,70 @@ #' 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) +#' adverse_event = sample( +#' c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash", "Insomnia"), +#' 150, +#' replace = TRUE, +#' prob = c(0.25, 0.2, 0.18, 0.15, 0.12, 0.1) #' ), -#' severity = sample(c("Mild", "Moderate", "Severe"), 100, +#' severity = sample( +#' c("Mild", "Moderate", "Severe"), +#' 150, #' 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) +#' subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), +#' treatment = sample(c("Active", "Placebo"), 150, replace = TRUE), +#' age_group = sample(c("Young", "Middle", "Old"), 150, replace = TRUE), +#' center = sample(c("Site A", "Site B", "Site C", "Site D"), 150, replace = TRUE), +#' system_organ_class = sample( +#' c("Nervous System", "Gastrointestinal", "General", "Skin"), +#' 150, +#' 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" +#' attr(df$age_group, "label") <- "Age Group" +#' attr(df$center, "label") <- "Study Center" +#' attr(df$system_organ_class, "label") <- "System Organ Class" #' }) #' #' app <- init( #' data = data, #' modules = modules( #' tm_p_bargraph( -#' label = "AE by Treatment", +#' label = "Basic Bar Graph", #' plot_dataname = "df", #' y_var = "adverse_event", #' color_var = "treatment", +#' count_var = "subject_id" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_bargraph( +#' label = "Advanced Bar Graph with All Features", +#' plot_dataname = "df", +#' y_var = "adverse_event", +#' color_var = "severity", #' count_var = "subject_id", -#' bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), -#' tooltip_vars = c("adverse_event", "treatment") +#' bar_colors = c( +#' "Mild" = "#90EE90", +#' "Moderate" = "#FFD700", +#' "Severe" = "#FF6347" +#' ), +#' tooltip_vars = c("adverse_event", "severity", "treatment", "age_group", "center", "system_organ_class") #' ) #' ) #' ) @@ -66,8 +100,9 @@ tm_p_bargraph <- function(label = "Bar Plot", y_var, color_var, count_var, + bar_colors = NULL, tooltip_vars = NULL, - bar_colors = NULL) { + transformators = list()) { module( label = label, ui = ui_p_bargraph, @@ -80,7 +115,8 @@ tm_p_bargraph <- function(label = "Bar Plot", count_var = count_var, tooltip_vars = tooltip_vars, bar_colors = bar_colors - ) + ), + transformators = transformators ) } @@ -129,34 +165,6 @@ srv_p_bargraph <- function(id, 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 - } - }) }) } @@ -187,8 +195,8 @@ bargraphplotly <- function(df, df_sym[[color_var_str]] <- as.character(df_sym[[color_var_str]]) plot_data <- df_sym %>% - dplyr::group_by(!!as.name(y_var_str), !!as.name(color_var_str)) %>% - dplyr::summarize(count = dplyr::n_distinct(!!as.name(count_var_str)), .groups = "drop") %>% + dplyr::group_by(y_var_sym, color_var_sym) %>% + dplyr::summarize(count = dplyr::n_distinct(count_var_sym), .groups = "drop") %>% dplyr::ungroup() %>% dplyr::mutate(customdata = dplyr::row_number()) %>% dplyr::mutate( @@ -200,8 +208,8 @@ bargraphplotly <- function(df, if (!length(color_var_label)) color_var_label <- color_var_str paste( - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), paste("Count:", count), sep = "
" ) @@ -230,8 +238,8 @@ bargraphplotly <- function(df, if (!length(color_var_label)) color_var_label <- color_var_str paste( - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), paste("Count:", count), sep = "
" ) @@ -246,10 +254,10 @@ bargraphplotly <- function(df, ) event_type_order <- plot_data %>% - dplyr::group_by(!!as.name(y_var_str)) %>% + dplyr::group_by(y_var_sym) %>% dplyr::summarize(total = sum(count), .groups = "drop") %>% dplyr::arrange(total) %>% - dplyr::pull(!!as.name(y_var_str)) + dplyr::pull(y_var_sym) plot_data[[y_var_str]] <- factor(plot_data[[y_var_str]], levels = event_type_order) @@ -258,13 +266,13 @@ bargraphplotly <- function(df, y = ~y_var_sym, x = ~count, color = ~color_var_sym, - colors = bar_colors_sym, + colors = bar_colors, type = "bar", orientation = "h", hovertext = ~tooltip, hoverinfo = "text", customdata = ~customdata, - source = source_sym + source = source ) %>% plotly::layout( barmode = "stack", @@ -283,8 +291,8 @@ bargraphplotly <- function(df, color_var_str = color_var, count_var_str = count_var, tooltip_vars_sym = tooltip_vars, - bar_colors_sym = bar_colors, - source_sym = source + bar_colors = bar_colors, + source = source ) ) } diff --git a/R/tm_p_lineplot.R b/R/tm_p_lineplot.R index a2c32b0b8..a21ad8760 100644 --- a/R/tm_p_lineplot.R +++ b/R/tm_p_lineplot.R @@ -16,9 +16,7 @@ #' If `NULL`, default colors will be used. #' @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. #' #' @inherit shared_params return #' @@ -30,7 +28,8 @@ #' 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) +#' baseline = rep(rnorm(8, 18, 2), each = 5), +#' center = rep(c("Site A", "Site B", "Site A", "Site B"), each = 10) #' ) #' #' # Add labels @@ -39,20 +38,43 @@ #' attr(df$measurement, "label") <- "Measurement Value" #' attr(df$treatment, "label") <- "Treatment Group" #' attr(df$baseline, "label") <- "Baseline Value" +#' attr(df$center, "label") <- "Study Center" #' }) #' -#' # Basic line plot example #' app <- init( #' data = data, #' modules = modules( #' tm_p_lineplot( -#' label = "Line Plot", +#' label = "Basic 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) +#' } +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_lineplot( +#' label = "Advanced Line Plot with All Features", #' plot_dataname = "df", #' x_var = "time_week", #' y_var = "measurement", #' color_var = "treatment", #' group_var = "subject_id", -#' tooltip_vars = c("subject_id", "time_week") +#' colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), +#' tooltip_vars = c("subject_id", "time_week", "measurement", "treatment", "center", "baseline"), +#' reference_lines = list( +#' baseline = list(label = "Baseline Mean", line_mode = "dash"), +#' measurement = list(label = "Measurement Value", line_mode = "solid") +#' ) #' ) #' ) #' ) @@ -71,8 +93,7 @@ tm_p_lineplot <- function(label = "Line Plot", colors = NULL, tooltip_vars = NULL, transformators = list(), - reference_lines = NULL, - activate_on_brushing = FALSE) { + reference_lines = NULL) { module( label = label, ui = ui_p_lineplot, @@ -86,8 +107,7 @@ tm_p_lineplot <- function(label = "Line Plot", colors = colors, group_var = group_var, tooltip_vars = tooltip_vars, - reference_lines = reference_lines, - activate_on_brushing = activate_on_brushing + reference_lines = reference_lines ), transformators = transformators ) @@ -112,13 +132,9 @@ 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")) - } data() |> within( code, @@ -192,10 +208,10 @@ lineplotly <- function(df, tooltip = { if (is.null(tooltip_vars_sym)) { paste( - paste(group_var_label, ":", !!as.name(group_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(group_var_label, ":", group_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { @@ -203,10 +219,10 @@ lineplotly <- function(df, cols <- intersect(tooltip_vars_sym, names(cur_data)) if (!length(cols)) { paste( - paste(group_var_label, ":", !!as.name(group_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(group_var_label, ":", group_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { @@ -278,18 +294,18 @@ lineplotly <- function(df, } segments_df <- df_sym %>% - dplyr::arrange(!!as.name(group_var_str), !!as.name(x_var_str)) %>% - dplyr::group_by(!!as.name(group_var_str)) %>% + dplyr::arrange(group_var_sym, x_var_sym) %>% + dplyr::group_by(group_var_sym) %>% dplyr::mutate( - xend = dplyr::lead(!!as.name(x_var_str)), - yend = dplyr::lead(!!as.name(y_var_str)), - color_var_seg = dplyr::lead(!!as.name(color_var_str)) + xend = dplyr::lead(x_var_sym), + yend = dplyr::lead(y_var_sym), + color_var_seg = dplyr::lead(color_var_sym) ) %>% dplyr::filter(!is.na(xend)) p <- plotly::plot_ly( data = segments_df, - source = source_sym, + source = source, height = 600L ) %>% plotly::add_segments( @@ -298,7 +314,7 @@ lineplotly <- function(df, xend = ~xend, yend = ~yend, color = ~color_var_seg, - colors = colors_sym, + colors = colors, showlegend = FALSE ) %>% plotly::add_markers( @@ -306,13 +322,13 @@ lineplotly <- function(df, x = ~x_var_sym, y = ~y_var_sym, color = ~color_var_sym, - colors = colors_sym, + colors = colors, text = ~tooltip, hoverinfo = "text" ) - if (!is.null(reference_lines_sym)) { - ref_lines <- add_reference_lines(df_sym, reference_lines_sym) + if (!is.null(reference_lines)) { + ref_lines <- add_reference_lines(df_sym, reference_lines) p <- p %>% plotly::layout( shapes = ref_lines$shapes, @@ -330,10 +346,10 @@ lineplotly <- function(df, y_var_str = y_var, color_var_str = color_var, group_var_str = group_var, - colors_sym = colors, + colors = colors, tooltip_vars_sym = tooltip_vars, - reference_lines_sym = reference_lines, - source_sym = source + reference_lines = reference_lines, + source = source ) ) } diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 5c5fa207e..661644484 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -3,20 +3,18 @@ #' 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`. +#' default variables (id, x, y, color) or custom columns specified via `tooltip_vars`. #' #' @inheritParams teal::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 id_var (`character(1)`) Name of the identifier variable for observations (used in tooltips). #' @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` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. #' If `NULL`, default colors will be used. #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing subject, x, y, and color variables. -#' @param transformators (`list`) Named list of transformator functions. -#' @param show_widgets (`logical(1)`) Whether to show module widgets. +#' If `NULL`, default tooltip is created showing id, x, y, and color variables. #' #' @inherit shared_params return #' @@ -28,26 +26,51 @@ #' 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) +#' gender = sample(c("M", "F"), 50, replace = TRUE), +#' baseline_score = rnorm(50, 12, 2), +#' center = sample(c("Site A", "Site B", "Site C"), 50, replace = TRUE) #' ) #' #' # Add labels for better tooltips +#' attr(df$subject_id, "label") <- "Subject ID" #' attr(df$age, "label") <- "Age (years)" #' attr(df$response, "label") <- "Response Score" #' attr(df$treatment, "label") <- "Treatment Group" +#' attr(df$gender, "label") <- "Gender" +#' attr(df$baseline_score, "label") <- "Baseline Score" +#' attr(df$center, "label") <- "Study Center" #' }) #' #' app <- init( #' data = data, #' modules = modules( #' tm_p_scatterplot( -#' label = "Scatter Plot with Custom Tooltip", +#' label = "Basic Scatter Plot", #' plot_dataname = "df", -#' subject_var = "subject_id", +#' id_var = "subject_id", +#' x_var = "age", +#' y_var = "response", +#' color_var = "treatment" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_scatterplot( +#' label = "Advanced Scatter Plot with All Features", +#' plot_dataname = "df", +#' id_var = "subject_id", #' x_var = "age", #' y_var = "response", #' color_var = "treatment", -#' tooltip_vars = c("age", "gender") +#' point_colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), +#' tooltip_vars = c("subject_id", "age", "response", "treatment", "gender", "baseline_score", "center") #' ) #' ) #' ) @@ -59,14 +82,13 @@ #' @export tm_p_scatterplot <- function(label = "Scatter Plot", plot_dataname, - subject_var, + id_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE) { + transformators = list()) { module( label = label, ui = ui_p_scatterplot, @@ -74,13 +96,12 @@ tm_p_scatterplot <- function(label = "Scatter Plot", ui_args = list(), server_args = list( plot_dataname = plot_dataname, - subject_var = subject_var, + id_var = id_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 + tooltip_vars = tooltip_vars ), transformators = transformators ) @@ -89,7 +110,6 @@ tm_p_scatterplot <- function(label = "Scatter Plot", 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( @@ -106,13 +126,12 @@ ui_p_scatterplot <- function(id) { srv_p_scatterplot <- function(id, data, plot_dataname, - subject_var, + id_var, x_var, y_var, color_var, point_colors, - tooltip_vars = NULL, - show_widgets) { + tooltip_vars = NULL) { moduleServer(id, function(input, output, session) { color_inputs <- colour_picker_srv( "colors", @@ -122,10 +141,6 @@ srv_p_scatterplot <- function(id, default_colors = point_colors ) - if (!show_widgets) { - shinyjs::hide("colors_span") - } - plotly_q <- reactive({ req(color_inputs()) data() |> @@ -136,7 +151,7 @@ srv_p_scatterplot <- function(id, x_var = x_var, y_var = y_var, color_var = color_var, - subject_var = subject_var, + id_var = id_var, colors = color_inputs(), source = session$ns("scatterplot"), tooltip_vars = tooltip_vars @@ -163,11 +178,11 @@ srv_p_scatterplot <- function(id, #' @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 subject_var (`character(1)`) Name of the subject variable +#' @param id_var (`character(1)`) Name of the identifier variable #' @param colors (`character`) Named vector of colors for color_var levels #' @param source (`character(1)`) Source identifier for plotly events #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing subject, x, y, and color variables. +#' If `NULL`, default tooltip is created showing id, x, y, and color variables. #' #' @return A code expression that when evaluated creates a plotly plot object #' @@ -178,17 +193,17 @@ srv_p_scatterplot <- function(id, #' x_var = "Sepal.Length", #' y_var = "Petal.Length", #' color_var = "Species", -#' subject_var = "row_id", +#' id_var = "row_id", #' colors = c("setosa" = "red", "versicolor" = "blue", "virginica" = "green"), #' source = "scatterplot", #' tooltip_vars = c("Sepal.Width", "Petal.Width") #' ) #' -scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, source, tooltip_vars = NULL) { +scatterplotly <- function(df, x_var, y_var, color_var, id_var, colors, source, tooltip_vars = NULL) { substitute( { - subject_var_label <- attr(df_sym[[subject_var_str]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var_str + id_var_label <- attr(df_sym[[id_var_str]], "label") + if (!length(id_var_label)) id_var_label <- id_var_str x_var_label <- attr(df_sym[[x_var_str]], "label") if (!length(x_var_label)) x_var_label <- x_var_str @@ -200,16 +215,16 @@ scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, sour if (!length(color_var_label)) color_var_label <- color_var_str plot_data <- df_sym |> - dplyr::mutate(!!as.name(color_var_str) := factor(!!as.name(color_var_str), levels = names(colors_sym))) |> + dplyr::mutate(color_var_sym := factor(color_var_sym, levels = names(colors))) |> dplyr::mutate(customdata = dplyr::row_number()) |> dplyr::mutate( tooltip = { if (is.null(tooltip_vars_sym)) { paste( - paste(subject_var_label, ":", !!as.name(subject_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(id_var_label, ":", id_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { @@ -217,17 +232,17 @@ scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, sour cols <- intersect(tooltip_vars_sym, names(cur_data)) if (!length(cols)) { paste( - paste(subject_var_label, ":", !!as.name(subject_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(id_var_label, ":", id_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { sub <- cur_data[cols] labels <- vapply(cols, function(cn) { - if (cn == subject_var_str) { - lb <- subject_var_label + if (cn == id_var_str) { + lb <- id_var_label } else if (cn == x_var_str) { lb <- x_var_label } else if (cn == y_var_str) { @@ -249,8 +264,8 @@ scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, sour p <- plotly::plot_ly( data = plot_data, - source = source_sym, - colors = colors_sym, + source = source, + colors = colors, customdata = ~customdata ) |> plotly::add_markers( @@ -268,13 +283,13 @@ scatterplotly <- function(df, x_var, y_var, color_var, subject_var, colors, sour x_var_sym = str2lang(x_var), y_var_sym = str2lang(y_var), color_var_sym = str2lang(color_var), - subject_var_sym = str2lang(subject_var), + id_var_sym = str2lang(id_var), x_var_str = x_var, y_var_str = y_var, color_var_str = color_var, - subject_var_str = subject_var, - colors_sym = colors, - source_sym = source, + id_var_str = id_var, + colors = colors, + source = source, tooltip_vars_sym = tooltip_vars ) ) diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index c822f9a99..6a221ffdd 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -16,7 +16,6 @@ #' If `NULL`, default colors will be used. #' @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. #' #' @inherit shared_params return @@ -29,7 +28,9 @@ #' 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) +#' age_group = rep(c("Young", "Old"), 20), +#' baseline = rep(rnorm(10, 12, 2), each = 4), +#' center = rep(c("Site A", "Site B", "Site A", "Site B", "Site A"), each = 8) #' ) #' #' # Add labels @@ -37,20 +38,42 @@ #' attr(df$time_point, "label") <- "Time Point (days)" #' attr(df$response, "label") <- "Response Score" #' attr(df$treatment, "label") <- "Treatment Group" +#' attr(df$age_group, "label") <- "Age Group" +#' attr(df$baseline, "label") <- "Baseline Score" +#' attr(df$center, "label") <- "Study Center" #' }) #' -#' # Default tooltip example #' app <- init( #' data = data, #' modules = modules( #' tm_p_spaghetti( -#' label = "Spaghetti Plot", +#' label = "Basic 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) +#' } +#' +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_spaghetti( +#' label = "Advanced Spaghetti Plot with All Features", #' plot_dataname = "df", #' group_var = "subject_id", #' x_var = "time_point", #' y_var = "response", #' color_var = "treatment", -#' tooltip_vars = c("subject_id", "treatment") +#' point_colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), +#' tooltip_vars = c("subject_id", "time_point", "response", "treatment", "age_group", "baseline", "center"), +#' show_widgets = TRUE #' ) #' ) #' ) @@ -154,30 +177,6 @@ srv_p_spaghetti <- function(id, 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 { - 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 - } - }) }) } @@ -229,17 +228,23 @@ spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, sour if (!length(color_var_label)) color_var_label <- color_var_str plot_data <- df_sym |> - dplyr::select(!!as.name(group_var_str), !!as.name(x_var_str), !!as.name(y_var_str), !!as.name(color_var_str)) |> - dplyr::mutate(!!as.name(color_var_str) := factor(!!as.name(color_var_str), levels = names(colors_sym))) %>% + dplyr::select( + group_var_sym, + x_var_sym, + y_var_sym, + color_var_sym, + if (!is.null(tooltip_vars_sym)) dplyr::any_of(tooltip_vars_sym) else NULL + ) |> + dplyr::mutate(color_var_sym := factor(color_var_sym, levels = names(colors))) %>% dplyr::mutate(customdata = dplyr::row_number()) |> dplyr::mutate( tooltip = { if (is.null(tooltip_vars_sym)) { paste( - paste(group_var_label, ":", !!as.name(group_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(group_var_label, ":", group_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { @@ -247,10 +252,10 @@ spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, sour cols <- intersect(tooltip_vars_sym, names(cur_data)) if (!length(cols)) { paste( - paste(group_var_label, ":", !!as.name(group_var_str)), - paste(x_var_label, ":", !!as.name(x_var_str)), - paste(y_var_label, ":", !!as.name(y_var_str)), - paste(color_var_label, ":", !!as.name(color_var_str)), + paste(group_var_label, ":", group_var_sym), + paste(x_var_label, ":", x_var_sym), + paste(y_var_label, ":", y_var_sym), + paste(color_var_label, ":", color_var_sym), sep = "
" ) } else { @@ -278,27 +283,27 @@ spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, sour ) segments_df <- plot_data %>% - dplyr::arrange(!!as.name(group_var_str), !!as.name(x_var_str)) %>% - dplyr::group_by(!!as.name(group_var_str)) %>% + dplyr::arrange(group_var_sym, x_var_sym) %>% + dplyr::group_by(group_var_sym) %>% dplyr::mutate( - x = !!as.name(x_var_str), - y = !!as.name(y_var_str), - xend = dplyr::lead(!!as.name(x_var_str)), - yend = dplyr::lead(!!as.name(y_var_str)), - color_var_seg = dplyr::lead(!!as.name(color_var_str)) + x = x_var_sym, + y = y_var_sym, + xend = dplyr::lead(x_var_sym), + yend = dplyr::lead(y_var_sym), + color_var_seg = dplyr::lead(color_var_sym) ) %>% dplyr::filter(!is.na(xend)) p <- plotly::plot_ly( data = segments_df, customdata = ~customdata, - source = source_sym + source = source ) %>% plotly::add_segments( x = ~x, y = ~y, xend = ~xend, yend = ~yend, color = ~color_var_seg, - colors = colors_sym, + colors = colors, showlegend = TRUE ) %>% plotly::add_markers( @@ -306,7 +311,7 @@ spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, sour x = ~x_var_sym, y = ~y_var_sym, color = ~color_var_sym, - colors = colors_sym, + colors = colors, text = ~tooltip, hoverinfo = "text" ) |> @@ -322,8 +327,8 @@ spaghettiplotly <- function(df, group_var, x_var, y_var, color_var, colors, sour x_var_str = x_var, y_var_str = y_var, color_var_str = color_var, - colors_sym = colors, - source_sym = source, + colors = colors, + source = source, tooltip_vars_sym = tooltip_vars ) ) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index e5f4fdff0..712f92f4a 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -3,7 +3,7 @@ #' This module creates an interactive spider plot visualization that shows value development #' over time grouped by subjects. The plot displays individual trajectories as connected #' lines and points, with support for color coding and symbol differentiation. Optional -#' filtering by event variables allows dynamic data subsetting. The plot includes customizable +#' filtering by categorical variables allows dynamic data subsetting. The plot includes customizable #' tooltips and point sizing based on data values. #' #' @inheritParams teal::module @@ -11,17 +11,17 @@ #' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. #' @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 subject_var (`character(1)`) Name of the factor or character column in `plot_dataname` +#' @param id_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 filter_event_var (`character(1)`) Name of the factor or character column in `plot_dataname` +#' @param filter_var (`character(1)`) 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 filtered data when the user -#' selects an event from the dropdown menu. +#' selects a value from the dropdown menu. #' @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 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 showing time, value, subject, and color variables. +#' If `NULL`, default tooltip is created showing time, value, id, and color variables. #' @param point_colors (`named character` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. #' If `NULL`, default colors will be used. #' @param point_symbols (`named character` or `NULL`) Valid plotly symbol names named by levels of `color_var` column. @@ -33,53 +33,76 @@ #' @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) +#' df <- data.frame( +#' subject_id = rep(paste0("S", 1:8), each = 6), +#' time_week = rep(c(0, 4, 8, 12, 16, 20), 8), +#' percent_change = c( +#' rnorm(24, -10, 15), # First 4 subjects with some improvement +#' rnorm(24, 5, 10) # Last 4 subjects with less improvement +#' ), +#' response_category = rep(c("Complete Response", "Partial Response", "Stable Disease", "Progressive Disease"), 12), +#' treatment = rep(c("Active", "Placebo"), each = 24), +#' age_group = rep(c("Young", "Old", "Young", "Old"), 12), +#' baseline_tumor_size = rep(rnorm(8, 50, 10), each = 6), +#' center = rep(c("Site A", "Site B", "Site C", "Site D"), 12) #' ) #' -#' 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) -#' ) +#' # Add labels +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$time_week, "label") <- "Time (weeks)" +#' attr(df$percent_change, "label") <- "Percent Change from Baseline" +#' attr(df$response_category, "label") <- "Response Category" +#' attr(df$treatment, "label") <- "Treatment Group" +#' attr(df$age_group, "label") <- "Age Group" +#' attr(df$baseline_tumor_size, "label") <- "Baseline Tumor Size (mm)" +#' attr(df$center, "label") <- "Study Center" +#' }) #' -#' 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) +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_p_spiderplot( +#' label = "Basic Spider Plot", +#' plot_dataname = "df", +#' time_var = "time_week", +#' value_var = "percent_change", +#' id_var = "subject_id", +#' color_var = "response_category", +#' filter_var = "treatment" #' ) -#' }) -#' join_keys(data) <- join_keys( -#' join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) +#' ) #' ) #' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' app <- init( #' data = data, #' modules = modules( #' tm_p_spiderplot( -#' plot_dataname = "spiderplot_ds", -#' time_var = "time_var", -#' value_var = "value_var", -#' subject_var = "subject_var", -#' filter_event_var = "filter_event_var", -#' color_var = "color_var", +#' label = "Advanced Spider Plot with All Features", +#' plot_dataname = "df", +#' time_var = "time_week", +#' value_var = "percent_change", +#' id_var = "subject_id", +#' color_var = "response_category", +#' filter_var = "treatment", +#' size_var = "baseline_tumor_size", +#' tooltip_vars = c("subject_id", "time_week", "percent_change", "response_category", "treatment", "age_group", "center"), #' point_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' "Complete Response" = "#00FF00", +#' "Partial Response" = "#FFFF00", +#' "Stable Disease" = "#FFA500", +#' "Progressive Disease" = "#FF0000" #' ), #' point_symbols = c( -#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" +#' "Complete Response" = "circle", +#' "Partial Response" = "square", +#' "Stable Disease" = "triangle-up", +#' "Progressive Disease" = "diamond" #' ), -#' tooltip_vars = c("subject_var") +#' plot_height = c(700, 400, 1000) #' ) #' ) #' ) @@ -93,28 +116,29 @@ tm_p_spiderplot <- function(label = "Spiderplot", plot_dataname, time_var, value_var, - subject_var, + id_var, color_var, - filter_event_var, + filter_var, size_var = NULL, tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = c(600, 400, 1200)) { + plot_height = c(600, 400, 1200), + transformators = 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(id_var)) { + id_var <- choices_selected(choices = id_var, selected = id_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) + if (is.character(filter_var)) { + filter_var <- choices_selected(choices = filter_var, selected = filter_var) } module( @@ -126,15 +150,16 @@ tm_p_spiderplot <- function(label = "Spiderplot", plot_dataname = plot_dataname, time_var = time_var, value_var = value_var, - subject_var = subject_var, - filter_event_var = filter_event_var, + id_var = id_var, + filter_var = filter_var, color_var = color_var, size_var = size_var, point_colors = point_colors, point_symbols = point_symbols, tooltip_vars = tooltip_vars ), - datanames = plot_dataname + datanames = plot_dataname, + transformators = transformators ) } @@ -149,10 +174,10 @@ ui_p_spiderplot <- function(id, height) { 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("id_var"), label = "ID 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), + selectInput(ns("filter_var"), label = "Filter by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("filter_var_level"), label = "Select value:", choices = NULL, selected = NULL, multiple = FALSE), colour_picker_ui(ns("colors")), sliderInput(ns("plot_height"), "Plot Height (px)", height[2], height[3], height[1]) ), @@ -173,8 +198,8 @@ srv_p_spiderplot <- function(id, plot_dataname, time_var, value_var, - subject_var, - filter_event_var, + id_var, + filter_var, color_var, point_colors, point_symbols, @@ -185,26 +210,26 @@ srv_p_spiderplot <- function(id, 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 = "id_var", data = reactive(data()[[dataname]]), cs = id_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) + .update_cs_input(inputId = "filter_var", data = reactive(data()[[dataname]]), cs = filter_var) - filter_event_var_levels <- reactive({ - req(data(), input$filter_event_var) + filter_var_levels <- reactive({ + req(data(), input$filter_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]]) + unique(data()[[plot_dataname]][[input$filter_var]]) }) - observeEvent(filter_event_var_levels(), { - label <- attr(data()[[plot_dataname]][[input$filter_event_var]], "label") + observeEvent(filter_var_levels(), { + label <- attr(data()[[plot_dataname]][[input$filter_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] + inputId = "filter_var_level", + label = sprintf("Select %s:", if (length(label)) label else "value:"), + choices = filter_var_levels(), + selected = filter_var_levels()[1] ) - if (length(filter_event_var_levels()) < 2) shinyjs::hide("filter_event_var_level") + if (length(filter_var_levels()) < 2) shinyjs::hide("filter_var_level") }) color_inputs <- colour_picker_srv( @@ -218,8 +243,8 @@ srv_p_spiderplot <- function(id, 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() + input$filter_var_level, input$time_var, input$value_var, + input$id_var, input$filter_var, input$color_var, color_inputs() ) adjusted_symbols <- .shape_palette_discrete( @@ -234,16 +259,16 @@ srv_p_spiderplot <- function(id, df = plot_dataname, 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, + id_var = input$id_var, + filter_var = input$filter_var, + selected_value = input$filter_var_level, color_var = input$color_var, colors = color_inputs(), symbols = adjusted_symbols, size_var = size_var, height = input$plot_height, point_size = 10, - title = sprintf("%s over time", input$filter_event_var_level), + title = sprintf("%s over time", input$filter_var_level), tooltip_vars = tooltip_vars, source = session$ns("spiderplot") ) @@ -260,13 +285,13 @@ srv_p_spiderplot <- function(id, )) observeEvent(data(), { - if (class(subject_var) == "choices_selected") { - subject_col <- subject_var$selected + if (class(id_var) == "choices_selected") { + subject_col <- id_var$selected } else { - subject_col <- subject_var + subject_col <- id_var } updateSelectInput( - inputId = "subjects", + inputId = "id_var", choices = data()[[plot_dataname]][[subject_col]] ) }) @@ -284,8 +309,8 @@ srv_p_spiderplot <- function(id, #' @param time_var (`character(1)`) Name of the numeric column to be used as x-axis #' @param value_var (`character(1)`) Name of the numeric column to be used as y-axis #' @param subject_var (`character(1)`) Name of the factor or character column to be used as grouping variable -#' @param filter_event_var (`character(1)`) Name of the factor or character column to be used to filter the data -#' @param selected_event (`character(1)`) Selected event value for filtering +#' @param filter_var (`character(1)`) Name of the factor or character column to be used to filter the data +#' @param selected_value (`character(1)`) Selected value for filtering #' @param color_var (`character(1)`) Name of the factor or character column to be used to differentiate colors and symbols #' @param colors (`character`) Named vector of colors for color_var levels #' @param symbols (`character`) Named vector of plotly symbols for color_var levels @@ -295,7 +320,7 @@ srv_p_spiderplot <- function(id, #' @param title (`character(1)`) Plot title #' @param source (`character(1)`) Source identifier for plotly events #' @param tooltip_vars (`character` or `NULL`) A vector of column names to be displayed in the tooltip. -#' If `NULL`, default tooltip is created showing time, value, subject, and color variables. +#' If `NULL`, default tooltip is created showing time, value, id, and color variables. #' #' @return A code expression that when evaluated creates a plotly plot object #' @@ -305,9 +330,9 @@ srv_p_spiderplot <- function(id, #' df = "spider_data", #' time_var = "time_point", #' value_var = "response", -#' subject_var = "subject_id", -#' filter_event_var = "event_type", -#' selected_event = "response", +#' id_var = "subject_id", +#' filter_var = "event_type", +#' selected_value = "response", #' color_var = "treatment", #' colors = c("Active" = "red", "Placebo" = "blue"), #' symbols = c("Active" = "circle", "Placebo" = "square"), @@ -319,18 +344,18 @@ srv_p_spiderplot <- function(id, #' tooltip_vars = c("subject_id", "treatment") #' ) #' -spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, selected_event, +spiderplotly <- function(df, time_var, value_var, id_var, filter_var, selected_value, color_var, colors, symbols, size_var = NULL, height = 600, point_size = 10, title = "Spider Plot", source, tooltip_vars = NULL) { substitute( { plot_data <- df_sym %>% - dplyr::filter(!!as.name(filter_event_var_str) == selected_event_sym) %>% - dplyr::arrange(!!as.name(subject_var_str), !!as.name(time_var_str)) %>% - dplyr::group_by(!!as.name(subject_var_str)) + dplyr::filter(filter_var_sym == selected_value) %>% + dplyr::arrange(id_var_sym, time_var_sym) %>% + dplyr::group_by(id_var_sym) - subject_var_label <- attr(plot_data[[subject_var_str]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var_str + id_var_label <- attr(plot_data[[id_var_str]], "label") + if (!length(id_var_label)) id_var_label <- id_var_str time_var_label <- attr(plot_data[[time_var_str]], "label") if (!length(time_var_label)) time_var_label <- time_var_str value_var_label <- attr(plot_data[[value_var_str]], "label") @@ -341,24 +366,24 @@ spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, plot_data <- plot_data |> dplyr::mutate(customdata = dplyr::row_number()) - if (is.null(size_var_sym)) { - size <- point_size_sym + if (is.null(size_var)) { + size <- point_size } else { - size <- ~size_var_lang + size <- ~size_var_sym } p <- plot_data %>% dplyr::ungroup() %>% dplyr::mutate( - x = dplyr::lag(!!as.name(time_var_str), default = 0), - y = dplyr::lag(!!as.name(value_var_str), default = 0), + x = dplyr::lag(time_var_sym, default = 0), + y = dplyr::lag(value_var_sym, default = 0), tooltip = { if (is.null(tooltip_vars_sym)) { sprintf( "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var_str), - time_var_label, !!as.name(time_var_str), - value_var_label, !!as.name(value_var_str) * 100 + id_var_label, id_var_sym, + time_var_label, time_var_sym, + value_var_label, value_var_sym * 100 ) } else { cur_data <- dplyr::cur_data() @@ -366,15 +391,15 @@ spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, if (!length(cols)) { sprintf( "%s: %s
%s: %s
%s: %s%%
", - subject_var_label, !!as.name(subject_var_str), - time_var_label, !!as.name(time_var_str), - value_var_label, !!as.name(value_var_str) * 100 + id_var_label, id_var_sym, + time_var_label, time_var_sym, + value_var_label, value_var_sym * 100 ) } else { sub <- cur_data[cols] labels <- vapply(cols, function(cn) { - if (cn == subject_var_str) { - lb <- subject_var_label + if (cn == id_var_str) { + lb <- id_var_label } else if (cn == time_var_str) { lb <- time_var_label } else if (cn == value_var_str) { @@ -395,11 +420,11 @@ spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, ) %>% dplyr::ungroup() %>% plotly::plot_ly( - source = source_sym, - height = height_sym, + source = source, + height = height, color = ~color_var_sym, - colors = colors_sym, - symbols = symbols_sym + colors = colors, + symbols = symbols ) %>% plotly::add_segments( x = ~x, @@ -420,32 +445,33 @@ spiderplotly <- function(df, time_var, value_var, subject_var, filter_event_var, plotly::layout( xaxis = list(title = time_var_label), yaxis = list(title = value_var_label), - title = title_sym, + title = title, dragmode = "select" ) %>% plotly::config(displaylogo = FALSE) %>% - plotly::layout(title = title_sym) + plotly::layout(title = title) }, list( df_sym = str2lang(df), time_var_sym = str2lang(time_var), value_var_sym = str2lang(value_var), - subject_var_sym = str2lang(subject_var), + id_var_sym = str2lang(id_var), + filter_var_sym = str2lang(filter_var), color_var_sym = str2lang(color_var), - size_var_lang = if (!is.null(size_var)) str2lang(size_var) else NULL, + size_var_sym = if (!is.null(size_var)) str2lang(size_var) else NULL, time_var_str = time_var, value_var_str = value_var, - subject_var_str = subject_var, - filter_event_var_str = filter_event_var, + id_var_str = id_var, + filter_var_str = filter_var, color_var_str = color_var, - selected_event_sym = selected_event, - colors_sym = colors, - symbols_sym = symbols, - size_var_sym = size_var, - height_sym = height, - point_size_sym = point_size, - title_sym = title, - source_sym = source, + selected_value = selected_value, + colors = colors, + symbols = symbols, + size_var = size_var, + height = height, + point_size = point_size, + title = title, + source = source, tooltip_vars_sym = tooltip_vars ) ) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 861e6e8eb..6eb85e54b 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -1,25 +1,25 @@ #' Swimlane Plot Module #' -#' This module creates an interactive swimlane plot visualization that displays subjects' events -#' over time. Each subject is represented by a horizontal lane, with events plotted as points +#' This module creates an interactive swimlane plot visualization that displays data points +#' over time. Each identifier is represented by a horizontal lane, with data points plotted as points #' along the timeline. The plot supports color coding and symbol differentiation for different -#' event types, customizable sorting of subjects, and interactive tooltips. This visualization -#' is particularly useful for showing temporal sequences of events across multiple subjects. +#' categories, customizable sorting of lanes, and interactive tooltips. This visualization +#' is particularly useful for showing temporal sequences of data points across multiple identifiers. #' #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. #' @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 (subject lanes). +#' @param id_var (`character(1)`) Name of the factor or character column in `plot_dataname` +#' to be used as y-axis (identifier lanes). #' @param color_var (`character(1)`) Name of the factor or character column in `plot_dataname` -#' to name and color subject events in time. +#' to name and color data points 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. +#' to categorize type of data point. Legend is sorted according to this variable. #' @param sort_var (`character(1)`) Name of the column in `plot_dataname` whose values determine -#' the order of subjects displayed on the y-axis. +#' the order of identifiers 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 showing subject, time, color, and group variables. +#' If `NULL`, default tooltip is created showing id, time, color, and group variables. #' @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` or `NULL`) Valid color names or hex-colors named by levels of `color_var` column. @@ -34,40 +34,80 @@ #' @examples #' data <- teal_data() |> #' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") +#' df <- data.frame( +#' subject_id = rep(paste0("S", 1:12), each = 3), +#' study_day = c( +#' rep(c(15, 45, 90), 4), # First 4 subjects with events at days 15, 45, 90 +#' rep(c(30, 60, 120), 4), # Next 4 subjects with events at days 30, 60, 120 +#' rep(c(10, 75, 150), 4) # Last 4 subjects with events at days 10, 75, 150 +#' ), +#' event_type = rep(c("Screening", "Treatment Start", "Assessment"), 12), +#' response_status = sample(c("Complete Response", "Partial Response", "Stable Disease", "Progressive Disease"), 36, replace = TRUE), +#' treatment_arm = rep(c("Experimental", "Control"), each = 18), +#' age_group = rep(c("Young", "Middle", "Old"), 12), +#' center = rep(c("Site A", "Site B", "Site C", "Site D"), 9) #' ) #' -#' 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) -#' ) +#' # Add labels +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$study_day, "label") <- "Study Day" +#' attr(df$event_type, "label") <- "Event Type" +#' attr(df$response_status, "label") <- "Response Status" +#' attr(df$treatment_arm, "label") <- "Treatment Arm" +#' attr(df$age_group, "label") <- "Age Group" +#' attr(df$center, "label") <- "Study Center" #' }) -#' 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( +#' label = "Basic Swimlane Plot", +#' plot_dataname = "df", +#' time_var = "study_day", +#' id_var = "subject_id", +#' color_var = "response_status", +#' group_var = "event_type" +#' ) +#' ) #' ) #' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' 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"), +#' label = "Advanced Swimlane Plot with All Features", +#' plot_dataname = "df", +#' time_var = "study_day", +#' id_var = "subject_id", +#' color_var = "response_status", +#' group_var = "event_type", +#' sort_var = "study_day", +#' tooltip_vars = c("subject_id", "study_day", "event_type", "response_status", "treatment_arm", "age_group", "center"), +#' point_size = c( +#' "Complete Response" = 15, +#' "Partial Response" = 12, +#' "Stable Disease" = 10, +#' "Progressive Disease" = 8 +#' ), #' point_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" +#' "Complete Response" = "#00FF00", +#' "Partial Response" = "#FFFF00", +#' "Stable Disease" = "#FFA500", +#' "Progressive Disease" = "#FF0000" #' ), #' point_symbols = c( -#' CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" -#' ) +#' "Complete Response" = "circle", +#' "Partial Response" = "square", +#' "Stable Disease" = "triangle-up", +#' "Progressive Disease" = "diamond" +#' ), +#' plot_height = c(800, 500, 1200), +#' show_widgets = TRUE #' ) #' ) #' ) @@ -80,7 +120,7 @@ tm_p_swimlane <- function(label = "Swimlane", plot_dataname, time_var, - subject_var, + id_var, color_var, group_var, sort_var = time_var, @@ -89,14 +129,15 @@ tm_p_swimlane <- function(label = "Swimlane", point_colors = character(0), point_symbols = character(0), plot_height = c(700, 400, 1200), - show_widgets = TRUE) { + show_widgets = TRUE, + transformators = 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(id_var)) { + id_var <- choices_selected(choices = id_var, selected = id_var) } if (is.character(color_var)) { color_var <- choices_selected(choices = color_var, selected = color_var) @@ -116,7 +157,7 @@ tm_p_swimlane <- function(label = "Swimlane", server_args = list( plot_dataname = plot_dataname, time_var = time_var, - subject_var = subject_var, + id_var = id_var, color_var = color_var, group_var = group_var, sort_var = sort_var, @@ -125,7 +166,8 @@ tm_p_swimlane <- function(label = "Swimlane", point_symbols = point_symbols, tooltip_vars = tooltip_vars, show_widgets = show_widgets - ) + ), + transformators = transformators ) } @@ -137,7 +179,7 @@ ui_p_swimlane <- function(id, height) { tags$div( id = ns("top_widgets"), style = "display: flex;", - selectInput(ns("subject_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("id_var"), label = "ID variable:", 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), @@ -162,7 +204,7 @@ srv_p_swimlane <- function(id, data, plot_dataname, time_var, - subject_var, + id_var, color_var, group_var, sort_var, @@ -174,7 +216,7 @@ srv_p_swimlane <- function(id, 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 = "id_var", data = reactive(data()[[dataname]]), cs = id_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) @@ -194,7 +236,7 @@ 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()) + req(data(), input$time_var, input$id_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 @@ -205,7 +247,7 @@ srv_p_swimlane <- function(id, code = swimlaneplotly( df = plot_dataname, time_var = input$time_var, - subject_var = input$subject_var, + id_var = input$id_var, color_var = input$color_var, group_var = input$group_var, sort_var = input$sort_var, @@ -237,7 +279,7 @@ srv_p_swimlane <- function(id, #' #' @param df (`character(1)`) Name of the data frame to plot #' @param time_var (`character(1)`) Name of the numeric column to be used as x-axis -#' @param subject_var (`character(1)`) Name of the factor or character column to be used as y-axis (subject lanes) +#' @param id_var (`character(1)`) Name of the factor or character column to be used as y-axis (subject lanes) #' @param color_var (`character(1)`) Name of the factor or character column to name and color subject events in time #' @param group_var (`character(1)`) Name of the factor or character column to categorize type of event #' @param sort_var (`character(1)`) Name of the column whose values determine the order of subjects displayed on the y-axis @@ -256,7 +298,7 @@ srv_p_swimlane <- function(id, #' code <- swimlaneplotly( #' df = "swimlane_data", #' time_var = "time_point", -#' subject_var = "subject_id", +#' id_var = "subject_id", #' color_var = "event_type", #' group_var = "event_category", #' sort_var = "time_point", @@ -268,25 +310,25 @@ srv_p_swimlane <- function(id, #' tooltip_vars = c("subject_id", "event_type") #' ) #' -swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort_var, +swimlaneplotly <- function(df, time_var, id_var, color_var, group_var, sort_var, point_size = 10, colors, symbols, height = 700, source, tooltip_vars = NULL) { substitute( { - subject_var_label <- attr(df_sym[[subject_var_str]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var_str + id_var_label <- attr(df_sym[[id_var_str]], "label") + if (!length(id_var_label)) id_var_label <- id_var_str time_var_label <- attr(df_sym[[time_var_str]], "label") if (!length(time_var_label)) time_var_label <- time_var_str plot_data <- df_sym |> dplyr::mutate(customdata = dplyr::row_number()) - subject_levels <- plot_data %>% - dplyr::group_by(!!as.name(subject_var_str)) %>% + id_levels <- plot_data %>% + dplyr::group_by(!!as.name(id_var_str)) %>% dplyr::summarize(v = max(!!as.name(sort_var_str))) %>% dplyr::ungroup() %>% dplyr::arrange(v) %>% - dplyr::pull(!!as.name(subject_var_str)) - plot_data[[subject_var_str]] <- factor(plot_data[[subject_var_str]], levels = subject_levels) + dplyr::pull(!!as.name(id_var_str)) + plot_data[[id_var_str]] <- factor(plot_data[[id_var_str]], levels = id_levels) min_size <- min(point_size_sym, na.rm = TRUE) @@ -313,13 +355,13 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort new_factor } ) %>% - dplyr::group_by(!!as.name(subject_var_str), !!as.name(time_var_str)) %>% + dplyr::group_by(!!as.name(id_var_str), !!as.name(time_var_str)) %>% dplyr::mutate( tooltip = { default_tip <- paste( unique( c( - paste(subject_var_label, !!as.name(subject_var_str)), + paste(id_var_label, !!as.name(id_var_str)), paste(time_var_label, !!as.name(time_var_str)), sprintf( "%s: %s", @@ -335,7 +377,7 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort } else { cur_data <- dplyr::cur_data() grouping_vars <- list() - grouping_vars[[subject_var_str]] <- dplyr::cur_group()[[subject_var_str]] + grouping_vars[[id_var_str]] <- dplyr::cur_group()[[id_var_str]] grouping_vars[[time_var_str]] <- dplyr::cur_group()[[time_var_str]] cur_data <- c(cur_data, grouping_vars) @@ -345,8 +387,8 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort } else { sub <- cur_data[cols] labels <- vapply(cols, function(cn) { - if (cn == subject_var_str) { - lb <- subject_var_label + if (cn == id_var_str) { + lb <- id_var_label } else if (cn == time_var_str) { lb <- time_var_label } else { @@ -371,7 +413,7 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort ) %>% plotly::add_markers( x = ~time_var_sym, - y = ~subject_var_sym, + y = ~id_var_sym, color = ~color_var_sym, symbol = ~color_var_sym, size = ~size_var, @@ -381,10 +423,10 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort plotly::add_segments( x = ~0, xend = ~study_day, - y = ~subject_var_sym, - yend = ~subject_var_sym, + y = ~id_var_sym, + yend = ~id_var_sym, data = plot_data |> - dplyr::group_by(!!as.name(subject_var_str), !!as.name(group_var_str)) |> + dplyr::group_by(!!as.name(id_var_str), !!as.name(group_var_str)) |> dplyr::summarise(study_day = max(!!as.name(time_var_str))), line = list(width = 2, color = "grey"), showlegend = FALSE, @@ -392,7 +434,7 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort ) %>% plotly::layout( xaxis = list(title = time_var_label), - yaxis = list(title = subject_var_label) + yaxis = list(title = id_var_label) ) %>% plotly::layout(dragmode = "select") %>% plotly::config(displaylogo = FALSE) @@ -400,12 +442,12 @@ swimlaneplotly <- function(df, time_var, subject_var, color_var, group_var, sort list( df_sym = str2lang(df), time_var_sym = str2lang(time_var), - subject_var_sym = str2lang(subject_var), + id_var_sym = str2lang(id_var), color_var_sym = str2lang(color_var), group_var_sym = str2lang(group_var), sort_var_sym = str2lang(sort_var), time_var_str = time_var, - subject_var_str = subject_var, + id_var_str = id_var, color_var_str = color_var, group_var_str = group_var, sort_var_str = sort_var, diff --git a/R/tm_p_waterfall.R b/R/tm_p_waterfall.R index e16932732..2cab7738f 100644 --- a/R/tm_p_waterfall.R +++ b/R/tm_p_waterfall.R @@ -10,8 +10,8 @@ #' @inheritParams teal::module #' @inheritParams shared_params #' @param plot_dataname (`character(1)`) Name of the dataset to be used for plotting. -#' @param subject_var (`character(1)`) Name of the factor or character column in `plot_dataname` -#' to be used as x-axis (subject identifiers). +#' @param x_var (`character(1)`) Name of the factor or character column in `plot_dataname` +#' to be used as x-axis (typically subject identifiers). #' @param value_var (`character(1)`) Name of the numeric column in `plot_dataname` #' to be used as y-axis (values determining bar heights). #' @param sort_var (`character(1)` or `NULL`) Name of the column used for sorting subjects. @@ -32,36 +32,72 @@ #' @examples #' data <- teal_data() |> #' within({ -#' subjects <- data.frame( -#' subject_var = c("A", "B", "C"), -#' AGE = sample(30:100, 3), -#' ARM = c("Combination", "Combination", "Placebo") +#' df <- data.frame( +#' subject_id = paste0("S", 1:20), +#' percent_change = c( +#' rnorm(5, -40, 10), # 5 subjects with good response (~-40%) +#' rnorm(8, -15, 15), # 8 subjects with moderate response (~-15%) +#' rnorm(4, 10, 8), # 4 subjects with progression (~10%) +#' rnorm(3, 35, 12) # 3 subjects with significant progression (~35%) +#' ), +#' best_response = c( +#' rep("Complete Response", 3), +#' rep("Partial Response", 7), +#' rep("Stable Disease", 6), +#' rep("Progressive Disease", 4) +#' ), +#' treatment_arm = rep(c("Experimental", "Control"), each = 10), +#' age_group = sample(c("Young", "Middle", "Old"), 20, replace = TRUE), +#' baseline_size = abs(rnorm(20, 50, 15)), +#' center = sample(c("Site A", "Site B", "Site C"), 20, 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) -#' ) +#' attr(df$subject_id, "label") <- "Subject ID" +#' attr(df$percent_change, "label") <- "Percent Change from Baseline" +#' attr(df$best_response, "label") <- "Best Overall Response" +#' attr(df$treatment_arm, "label") <- "Treatment Arm" +#' attr(df$age_group, "label") <- "Age Group" +#' attr(df$baseline_size, "label") <- "Baseline Tumor Size (mm)" +#' attr(df$center, "label") <- "Study Center" #' }) -#' 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( +#' label = "Basic Waterfall Plot", +#' plot_dataname = "df", +#' x_var = "subject_id", +#' value_var = "percent_change", +#' color_var = "best_response" +#' ) +#' ) #' ) #' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' 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), +#' label = "Advanced Waterfall Plot with All Features", +#' plot_dataname = "df", +#' x_var = "subject_id", +#' value_var = "percent_change", +#' sort_var = "percent_change", +#' color_var = "best_response", +#' tooltip_vars = c("subject_id", "percent_change", "best_response", "treatment_arm", "age_group", "baseline_size", "center"), #' bar_colors = c( -#' CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" -#' ) +#' "Complete Response" = "#00FF00", +#' "Partial Response" = "#FFFF00", +#' "Stable Disease" = "#FFA500", +#' "Progressive Disease" = "#FF0000" +#' ), +#' value_arbitrary_hlines = c(-30, 20), +#' plot_title = "Tumor Response Waterfall Plot", +#' plot_height = c(700, 400, 1000) #' ) #' ) #' ) @@ -73,7 +109,7 @@ #' @export tm_p_waterfall <- function(label = "Waterfall", plot_dataname, - subject_var, + x_var, value_var, sort_var = NULL, color_var = NULL, @@ -81,9 +117,10 @@ 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)) { - if (is.character(subject_var)) { - subject_var <- choices_selected(choices = subject_var, selected = subject_var) + plot_height = c(600, 400, 1200), + transformators = list()) { + if (is.character(x_var)) { + x_var <- choices_selected(choices = x_var, selected = x_var) } if (is.character(value_var)) { value_var <- choices_selected(choices = value_var, selected = value_var) @@ -103,7 +140,7 @@ tm_p_waterfall <- function(label = "Waterfall", ui_args = list(height = plot_height), server_args = list( plot_dataname = plot_dataname, - subject_var = subject_var, + x_var = x_var, value_var = value_var, sort_var = sort_var, color_var = color_var, @@ -111,7 +148,8 @@ tm_p_waterfall <- function(label = "Waterfall", value_arbitrary_hlines = value_arbitrary_hlines, plot_title = plot_title, tooltip_vars = tooltip_vars - ) + ), + transformators = transformators ) } @@ -122,7 +160,7 @@ ui_p_waterfall <- function(id, height) { div( style = "display: flex;", selectInput( - ns("subject_var"), + ns("x_var"), label = "Subject variable (x-axis):", choices = NULL, selected = NULL, multiple = FALSE ), @@ -149,7 +187,7 @@ ui_p_waterfall <- function(id, height) { srv_p_waterfall <- function(id, data, plot_dataname, - subject_var, + x_var, value_var, sort_var, color_var, @@ -160,33 +198,43 @@ srv_p_waterfall <- function(id, 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) + .update_cs_input(inputId = "x_var", data = reactive(data()[[plot_dataname]]), cs = x_var) + .update_cs_input(inputId = "value_var", data = reactive(data()[[plot_dataname]]), cs = value_var) + if (!is.null(sort_var)) { + .update_cs_input(inputId = "sort_var", data = reactive(data()[[plot_dataname]]), cs = sort_var) + } + if (!is.null(color_var)) { + .update_cs_input(inputId = "color_var", data = reactive(data()[[plot_dataname]]), cs = color_var) + } color_inputs <- colour_picker_srv( "colors", x = reactive({ - req(data(), input$color_var) - data()[[plot_dataname]][[input$color_var]] + if (!is.null(color_var) && !is.null(input$color_var)) { + req(data()) + data()[[plot_dataname]][[input$color_var]] + } else { + NULL + } }), default_colors = bar_colors ) plotly_q <- reactive({ - req(data(), input$subject_var, input$value_var, input$sort_var, input$color_var, color_inputs()) + req(data(), input$x_var, input$value_var) + if (!is.null(sort_var)) req(input$sort_var) + if (!is.null(color_var)) req(input$color_var, color_inputs()) data() |> within( code, code = waterfallplotly( df = plot_dataname, - subject_var = input$subject_var, + x_var = input$x_var, value_var = input$value_var, - sort_var = input$sort_var, - color_var = input$color_var, - colors = color_inputs(), + sort_var = if (!is.null(sort_var)) input$sort_var else NULL, + color_var = if (!is.null(color_var)) input$color_var else NULL, + colors = if (!is.null(color_var)) color_inputs() else character(0), value_arbitrary_hlines = value_arbitrary_hlines, height = input$plot_height, title = "Waterfall plot", @@ -208,7 +256,7 @@ srv_p_waterfall <- function(id, #' bar chart creation, and horizontal reference lines. #' #' @param df (`character(1)`) Name of the data frame to plot -#' @param subject_var (`character(1)`) Name of the factor or character column to be used as x-axis (subject identifiers) +#' @param x_var (`character(1)`) Name of the factor or character column to be used as x-axis (typically subject identifiers) #' @param value_var (`character(1)`) Name of the numeric column to be used as y-axis (values determining bar heights) #' @param sort_var (`character(1)` or `NULL`) Name of the column whose values determine sorting order. If `NULL` or same as `value_var`, sorts by value_var descending #' @param color_var (`character(1)` or `NULL`) Name of the factor or character column to differentiate bar colors. If `NULL`, all bars have same color @@ -226,7 +274,7 @@ srv_p_waterfall <- function(id, #' # Generate code for a waterfall plot #' code <- waterfallplotly( #' df = "waterfall_data", -#' subject_var = "subject_id", +#' x_var = "subject_id", #' value_var = "response_value", #' sort_var = "response_value", #' color_var = "response_category", @@ -238,13 +286,13 @@ srv_p_waterfall <- function(id, #' tooltip_vars = c("subject_id", "response_category") #' ) #' -waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_var = NULL, +waterfallplotly <- function(df, x_var, value_var, sort_var = NULL, color_var = NULL, colors, value_arbitrary_hlines = NULL, height = 600, title = "Waterfall plot", source, tooltip_vars = NULL) { substitute( { - subject_var_label <- attr(df_sym[[subject_var_str]], "label") - if (!length(subject_var_label)) subject_var_label <- subject_var_str + x_var_label <- attr(df_sym[[x_var_str]], "label") + if (!length(x_var_label)) x_var_label <- x_var_str value_var_label <- attr(df_sym[[value_var_str]], "label") if (!length(value_var_label)) value_var_label <- value_var_str color_var_label <- attr(df_sym[[color_var_str]], "label") @@ -256,11 +304,11 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v } else { dplyr::arrange(df_sym, !!as.name(sort_var_str), desc(!!as.name(value_var_str))) }, - !!as.name(subject_var_str) := factor(!!as.name(subject_var_str), levels = unique(!!as.name(subject_var_str))), + !!as.name(x_var_str) := factor(!!as.name(x_var_str), levels = unique(!!as.name(x_var_str))), tooltip = { default_tip <- sprintf( "%s: %s
%s: %s%%
%s: %s", - subject_var_label, !!as.name(subject_var_str), + x_var_label, !!as.name(x_var_str), value_var_label, !!as.name(value_var_str), color_var_label, !!as.name(color_var_str) ) @@ -274,8 +322,8 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v } else { sub <- cur_data[cols] labels <- vapply(cols, function(cn) { - if (cn == subject_var_str) { - lb <- subject_var_label + if (cn == x_var_str) { + lb <- x_var_label } else if (cn == value_var_str) { lb <- value_var_label } else if (cn == color_var_str) { @@ -292,7 +340,7 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v } } ) %>% - dplyr::filter(!duplicated(!!as.name(subject_var_str))) %>% + dplyr::filter(!duplicated(!!as.name(x_var_str))) %>% dplyr::mutate(customdata = dplyr::row_number()) p <- plotly::plot_ly( @@ -302,7 +350,7 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v height = height_sym ) %>% plotly::add_bars( - x = ~subject_var_sym, + x = ~x_var_sym, y = ~value_var_sym, color = ~color_var_sym, colors = colors_sym, @@ -321,7 +369,7 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v line = list(color = "black", dash = "dot") ) }), - xaxis = list(title = subject_var_label, tickangle = -45), + xaxis = list(title = x_var_label, tickangle = -45), yaxis = list(title = value_var_label), legend = list(title = list(text = "Color by:")), barmode = "relative" @@ -332,11 +380,11 @@ waterfallplotly <- function(df, subject_var, value_var, sort_var = NULL, color_v }, list( df_sym = str2lang(df), - subject_var_sym = str2lang(subject_var), + x_var_sym = str2lang(x_var), value_var_sym = str2lang(value_var), sort_var_sym = if (!is.null(sort_var)) str2lang(sort_var) else NULL, color_var_sym = if (!is.null(color_var)) str2lang(color_var) else NULL, - subject_var_str = subject_var, + x_var_str = x_var, value_var_str = value_var, sort_var_str = sort_var, color_var_str = color_var, diff --git a/man/scatterplotly.Rd b/man/scatterplotly.Rd index 0ce783b03..7164075ab 100644 --- a/man/scatterplotly.Rd +++ b/man/scatterplotly.Rd @@ -9,7 +9,7 @@ scatterplotly( x_var, y_var, color_var, - subject_var, + id_var, colors, source, tooltip_vars = NULL @@ -24,14 +24,14 @@ scatterplotly( \item{color_var}{(\code{character(1)}) Name of the variable to be used for coloring points} -\item{subject_var}{(\code{character(1)}) Name of the subject variable} +\item{id_var}{(\code{character(1)}) Name of the identifier variable} \item{colors}{(\code{character}) Named vector of colors for color_var levels} \item{source}{(\code{character(1)}) Source identifier for plotly events} \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 subject, x, y, and color variables.} +If \code{NULL}, default tooltip is created showing id, x, y, and color variables.} } \value{ A code expression that when evaluated creates a plotly plot object @@ -49,7 +49,7 @@ code <- scatterplotly( x_var = "Sepal.Length", y_var = "Petal.Length", color_var = "Species", - subject_var = "row_id", + id_var = "row_id", colors = c("setosa" = "red", "versicolor" = "blue", "virginica" = "green"), source = "scatterplot", tooltip_vars = c("Sepal.Width", "Petal.Width") diff --git a/man/spiderplotly.Rd b/man/spiderplotly.Rd index f362ed2ab..0fda79b7b 100644 --- a/man/spiderplotly.Rd +++ b/man/spiderplotly.Rd @@ -8,9 +8,9 @@ spiderplotly( df, time_var, value_var, - subject_var, - filter_event_var, - selected_event, + id_var, + filter_var, + selected_value, color_var, colors, symbols, @@ -29,11 +29,9 @@ spiderplotly( \item{value_var}{(\code{character(1)}) Name of the numeric column to be used as y-axis} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as grouping variable} - -\item{filter_event_var}{(\code{character(1)}) Name of the factor or character column to be used to filter the data} +\item{filter_var}{(\code{character(1)}) Name of the factor or character column to be used to filter the data} -\item{selected_event}{(\code{character(1)}) Selected event value for filtering} +\item{selected_value}{(\code{character(1)}) Selected value for filtering} \item{color_var}{(\code{character(1)}) Name of the factor or character column to be used to differentiate colors and symbols} @@ -52,7 +50,9 @@ spiderplotly( \item{source}{(\code{character(1)}) Source identifier for plotly events} \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 time, value, subject, and color variables.} +If \code{NULL}, default tooltip is created showing time, value, id, and color variables.} + +\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as grouping variable} } \value{ A code expression that when evaluated creates a plotly plot object @@ -69,9 +69,9 @@ code <- spiderplotly( df = "spider_data", time_var = "time_point", value_var = "response", - subject_var = "subject_id", - filter_event_var = "event_type", - selected_event = "response", + id_var = "subject_id", + filter_var = "event_type", + selected_value = "response", color_var = "treatment", colors = c("Active" = "red", "Placebo" = "blue"), symbols = c("Active" = "circle", "Placebo" = "square"), diff --git a/man/swimlaneplotly.Rd b/man/swimlaneplotly.Rd index 31ce7b24a..c2aa3ab13 100644 --- a/man/swimlaneplotly.Rd +++ b/man/swimlaneplotly.Rd @@ -7,7 +7,7 @@ swimlaneplotly( df, time_var, - subject_var, + id_var, color_var, group_var, sort_var, @@ -24,7 +24,7 @@ swimlaneplotly( \item{time_var}{(\code{character(1)}) Name of the numeric column to be used as x-axis} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as y-axis (subject lanes)} +\item{id_var}{(\code{character(1)}) Name of the factor or character column to be used as y-axis (subject lanes)} \item{color_var}{(\code{character(1)}) Name of the factor or character column to name and color subject events in time} @@ -59,7 +59,7 @@ marker and segment creation, and event registration. code <- swimlaneplotly( df = "swimlane_data", time_var = "time_point", - subject_var = "subject_id", + id_var = "subject_id", color_var = "event_type", group_var = "event_category", sort_var = "time_point", diff --git a/man/tm_p_bargraph.Rd b/man/tm_p_bargraph.Rd index 63ce99637..4a097d984 100644 --- a/man/tm_p_bargraph.Rd +++ b/man/tm_p_bargraph.Rd @@ -10,8 +10,9 @@ tm_p_bargraph( y_var, color_var, count_var, + bar_colors = NULL, tooltip_vars = NULL, - bar_colors = NULL + transformators = list() ) } \arguments{ @@ -26,11 +27,14 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \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 \code{color_var} column. +If \code{NULL}, default colors will be 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 showing y, color, and count variables.} -\item{bar_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. -If \code{NULL}, default colors will be used.} +\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. @@ -46,36 +50,70 @@ aggregates data by counting distinct values within each group combination. 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) + adverse_event = sample( + c("Headache", "Nausea", "Fatigue", "Dizziness", "Rash", "Insomnia"), + 150, + replace = TRUE, + prob = c(0.25, 0.2, 0.18, 0.15, 0.12, 0.1) ), - severity = sample(c("Mild", "Moderate", "Severe"), 100, + severity = sample( + c("Mild", "Moderate", "Severe"), + 150, 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) + subject_id = sample(paste0("S", 1:40), 150, replace = TRUE), + treatment = sample(c("Active", "Placebo"), 150, replace = TRUE), + age_group = sample(c("Young", "Middle", "Old"), 150, replace = TRUE), + center = sample(c("Site A", "Site B", "Site C", "Site D"), 150, replace = TRUE), + system_organ_class = sample( + c("Nervous System", "Gastrointestinal", "General", "Skin"), + 150, + 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" + attr(df$age_group, "label") <- "Age Group" + attr(df$center, "label") <- "Study Center" + attr(df$system_organ_class, "label") <- "System Organ Class" }) app <- init( data = data, modules = modules( tm_p_bargraph( - label = "AE by Treatment", + label = "Basic Bar Graph", plot_dataname = "df", y_var = "adverse_event", color_var = "treatment", + count_var = "subject_id" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +app <- init( + data = data, + modules = modules( + tm_p_bargraph( + label = "Advanced Bar Graph with All Features", + plot_dataname = "df", + y_var = "adverse_event", + color_var = "severity", count_var = "subject_id", - bar_colors = c("Active" = "#FF6B6B", "Placebo" = "#4ECDC4"), - tooltip_vars = c("adverse_event", "treatment") + bar_colors = c( + "Mild" = "#90EE90", + "Moderate" = "#FFD700", + "Severe" = "#FF6347" + ), + tooltip_vars = c("adverse_event", "severity", "treatment", "age_group", "center", "system_organ_class") ) ) ) diff --git a/man/tm_p_lineplot.Rd b/man/tm_p_lineplot.Rd index ab30f35d5..cb358c434 100644 --- a/man/tm_p_lineplot.Rd +++ b/man/tm_p_lineplot.Rd @@ -14,8 +14,7 @@ tm_p_lineplot( colors = NULL, tooltip_vars = NULL, transformators = list(), - reference_lines = NULL, - activate_on_brushing = FALSE + reference_lines = NULL ) } \arguments{ @@ -38,11 +37,10 @@ If \code{NULL}, default colors will be 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 showing group, x, y, and color variables.} -\item{transformators}{(\code{list}) Named list of transformator functions.} +\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{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.} } \value{ Object of class \code{teal_module} to be used in \code{teal} applications. @@ -62,7 +60,8 @@ data <- teal_data() |> 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) + baseline = rep(rnorm(8, 18, 2), each = 5), + center = rep(c("Site A", "Site B", "Site A", "Site B"), each = 10) ) # Add labels @@ -71,20 +70,43 @@ data <- teal_data() |> attr(df$measurement, "label") <- "Measurement Value" attr(df$treatment, "label") <- "Treatment Group" attr(df$baseline, "label") <- "Baseline Value" + attr(df$center, "label") <- "Study Center" }) -# Basic line plot example app <- init( data = data, modules = modules( tm_p_lineplot( - label = "Line Plot", + label = "Basic 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) +} + +app <- init( + data = data, + modules = modules( + tm_p_lineplot( + label = "Advanced Line Plot with All Features", plot_dataname = "df", x_var = "time_week", y_var = "measurement", color_var = "treatment", group_var = "subject_id", - tooltip_vars = c("subject_id", "time_week") + colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), + tooltip_vars = c("subject_id", "time_week", "measurement", "treatment", "center", "baseline"), + reference_lines = list( + baseline = list(label = "Baseline Mean", line_mode = "dash"), + measurement = list(label = "Measurement Value", line_mode = "solid") + ) ) ) ) diff --git a/man/tm_p_scatterplot.Rd b/man/tm_p_scatterplot.Rd index 5e8d5aef7..a4a47d25e 100644 --- a/man/tm_p_scatterplot.Rd +++ b/man/tm_p_scatterplot.Rd @@ -7,14 +7,13 @@ tm_p_scatterplot( label = "Scatter Plot", plot_dataname, - subject_var, + id_var, x_var, y_var, color_var, point_colors = character(0), tooltip_vars = NULL, - transformators = list(), - show_widgets = TRUE + transformators = list() ) } \arguments{ @@ -23,7 +22,7 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \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{id_var}{(\code{character(1)}) Name of the identifier variable for observations (used in tooltips).} \item{x_var}{(\code{character(1)}) Name of the variable to be used for x-axis.} @@ -35,11 +34,10 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} If \code{NULL}, default colors will be 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 showing subject, x, y, and color variables.} +If \code{NULL}, default tooltip is created showing id, 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.} +\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. @@ -48,7 +46,7 @@ Object of class \code{teal_module} to be used in \code{teal} applications. 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}. +default variables (id, x, y, color) or custom columns specified via \code{tooltip_vars}. } \examples{ data <- teal_data() |> @@ -58,26 +56,51 @@ data <- teal_data() |> 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) + gender = sample(c("M", "F"), 50, replace = TRUE), + baseline_score = rnorm(50, 12, 2), + center = sample(c("Site A", "Site B", "Site C"), 50, replace = TRUE) ) # Add labels for better tooltips + attr(df$subject_id, "label") <- "Subject ID" attr(df$age, "label") <- "Age (years)" attr(df$response, "label") <- "Response Score" attr(df$treatment, "label") <- "Treatment Group" + attr(df$gender, "label") <- "Gender" + attr(df$baseline_score, "label") <- "Baseline Score" + attr(df$center, "label") <- "Study Center" }) app <- init( data = data, modules = modules( tm_p_scatterplot( - label = "Scatter Plot with Custom Tooltip", + label = "Basic Scatter Plot", + plot_dataname = "df", + id_var = "subject_id", + x_var = "age", + y_var = "response", + color_var = "treatment" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +app <- init( + data = data, + modules = modules( + tm_p_scatterplot( + label = "Advanced Scatter Plot with All Features", plot_dataname = "df", - subject_var = "subject_id", + id_var = "subject_id", x_var = "age", y_var = "response", color_var = "treatment", - tooltip_vars = c("age", "gender") + point_colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), + tooltip_vars = c("subject_id", "age", "response", "treatment", "gender", "baseline_score", "center") ) ) ) diff --git a/man/tm_p_spaghetti.Rd b/man/tm_p_spaghetti.Rd index 02db33e1a..eb7f648e2 100644 --- a/man/tm_p_spaghetti.Rd +++ b/man/tm_p_spaghetti.Rd @@ -37,7 +37,8 @@ If \code{NULL}, default colors will be 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 showing group, x, y, and color variables.} -\item{transformators}{(\code{list}) Named list of transformator functions.} +\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{show_widgets}{(\code{logical(1)}) Whether to show module widgets.} } @@ -59,7 +60,9 @@ data <- teal_data() |> 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) + age_group = rep(c("Young", "Old"), 20), + baseline = rep(rnorm(10, 12, 2), each = 4), + center = rep(c("Site A", "Site B", "Site A", "Site B", "Site A"), each = 8) ) # Add labels @@ -67,20 +70,42 @@ data <- teal_data() |> attr(df$time_point, "label") <- "Time Point (days)" attr(df$response, "label") <- "Response Score" attr(df$treatment, "label") <- "Treatment Group" + attr(df$age_group, "label") <- "Age Group" + attr(df$baseline, "label") <- "Baseline Score" + attr(df$center, "label") <- "Study Center" }) -# Default tooltip example app <- init( data = data, modules = modules( tm_p_spaghetti( - label = "Spaghetti Plot", + label = "Basic 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) +} + +app <- init( + data = data, + modules = modules( + tm_p_spaghetti( + label = "Advanced Spaghetti Plot with All Features", plot_dataname = "df", group_var = "subject_id", x_var = "time_point", y_var = "response", color_var = "treatment", - tooltip_vars = c("subject_id", "treatment") + point_colors = c("Active" = "#1f77b4", "Placebo" = "#ff7f0e"), + tooltip_vars = c("subject_id", "time_point", "response", "treatment", "age_group", "baseline", "center"), + show_widgets = TRUE ) ) ) diff --git a/man/tm_p_spiderplot.Rd b/man/tm_p_spiderplot.Rd index 1c7a1b125..7944b5c9a 100644 --- a/man/tm_p_spiderplot.Rd +++ b/man/tm_p_spiderplot.Rd @@ -9,14 +9,15 @@ tm_p_spiderplot( plot_dataname, time_var, value_var, - subject_var, + id_var, color_var, - filter_event_var, + filter_var, size_var = NULL, tooltip_vars = NULL, point_colors = character(0), point_symbols = character(0), - plot_height = c(600, 400, 1200) + plot_height = c(600, 400, 1200), + transformators = list() ) } \arguments{ @@ -29,21 +30,21 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{value_var}{(\code{character(1)}) Name of the numeric column in \code{plot_dataname} to be used as y-axis.} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +\item{id_var}{(\code{character(1)}) Name of the factor or 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 factor or character column in \code{plot_dataname} to be used to differentiate colors and symbols.} -\item{filter_event_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +\item{filter_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} to be used to filter the data. The plot will be updated with just the filtered data when the user -selects an event from the dropdown menu.} +selects a value 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 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 showing time, value, subject, and color variables.} +If \code{NULL}, default tooltip is created showing time, value, id, and color variables.} \item{point_colors}{(\verb{named character} or \code{NULL}) Valid color names or hex-colors named by levels of \code{color_var} column. If \code{NULL}, default colors will be used.} @@ -52,6 +53,9 @@ If \code{NULL}, default colors will be used.} If \code{NULL}, default symbols will be used.} \item{plot_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} + +\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. @@ -60,59 +64,82 @@ Object of class \code{teal_module} to be used in \code{teal} applications. This module creates an interactive spider plot visualization that shows value development over time grouped by subjects. The plot displays individual trajectories as connected lines and points, with support for color coding and symbol differentiation. Optional -filtering by event variables allows dynamic data subsetting. The plot includes customizable +filtering by categorical variables allows dynamic data subsetting. The plot includes customizable tooltips and point sizing based on data 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") - ) - - 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) + df <- data.frame( + subject_id = rep(paste0("S", 1:8), each = 6), + time_week = rep(c(0, 4, 8, 12, 16, 20), 8), + percent_change = c( + rnorm(24, -10, 15), # First 4 subjects with some improvement + rnorm(24, 5, 10) # Last 4 subjects with less improvement + ), + response_category = rep(c("Complete Response", "Partial Response", "Stable Disease", "Progressive Disease"), 12), + treatment = rep(c("Active", "Placebo"), each = 24), + age_group = rep(c("Young", "Old", "Young", "Old"), 12), + baseline_tumor_size = rep(rnorm(8, 50, 10), each = 6), + center = rep(c("Site A", "Site B", "Site C", "Site D"), 12) ) - 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) - ) + # Add labels + attr(df$subject_id, "label") <- "Subject ID" + attr(df$time_week, "label") <- "Time (weeks)" + attr(df$percent_change, "label") <- "Percent Change from Baseline" + attr(df$response_category, "label") <- "Response Category" + attr(df$treatment, "label") <- "Treatment Group" + attr(df$age_group, "label") <- "Age Group" + attr(df$baseline_tumor_size, "label") <- "Baseline Tumor Size (mm)" + attr(df$center, "label") <- "Study Center" + }) - 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) +app <- init( + data = data, + modules = modules( + tm_p_spiderplot( + label = "Basic Spider Plot", + plot_dataname = "df", + time_var = "time_week", + value_var = "percent_change", + id_var = "subject_id", + color_var = "response_category", + filter_var = "treatment" ) - }) -join_keys(data) <- join_keys( - join_key("subjects", "spiderplot_ds", keys = c(subject_var = "subject_var")) + ) ) +if (interactive()) { + shinyApp(app$ui, app$server) +} + app <- init( data = data, modules = modules( tm_p_spiderplot( - plot_dataname = "spiderplot_ds", - time_var = "time_var", - value_var = "value_var", - subject_var = "subject_var", - filter_event_var = "filter_event_var", - color_var = "color_var", + label = "Advanced Spider Plot with All Features", + plot_dataname = "df", + time_var = "time_week", + value_var = "percent_change", + id_var = "subject_id", + color_var = "response_category", + filter_var = "treatment", + size_var = "baseline_tumor_size", + tooltip_vars = c("subject_id", "time_week", "percent_change", "response_category", "treatment", "age_group", "center"), point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + "Complete Response" = "#00FF00", + "Partial Response" = "#FFFF00", + "Stable Disease" = "#FFA500", + "Progressive Disease" = "#FF0000" ), point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" + "Complete Response" = "circle", + "Partial Response" = "square", + "Stable Disease" = "triangle-up", + "Progressive Disease" = "diamond" ), - tooltip_vars = c("subject_var") + plot_height = c(700, 400, 1000) ) ) ) diff --git a/man/tm_p_swimlane.Rd b/man/tm_p_swimlane.Rd index 77d71977b..38d843ce1 100644 --- a/man/tm_p_swimlane.Rd +++ b/man/tm_p_swimlane.Rd @@ -8,7 +8,7 @@ tm_p_swimlane( label = "Swimlane", plot_dataname, time_var, - subject_var, + id_var, color_var, group_var, sort_var = time_var, @@ -17,7 +17,8 @@ tm_p_swimlane( point_colors = character(0), point_symbols = character(0), plot_height = c(700, 400, 1200), - show_widgets = TRUE + show_widgets = TRUE, + transformators = list() ) } \arguments{ @@ -28,20 +29,20 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{time_var}{(\code{character(1)}) Name of the numeric column in \code{plot_dataname} to be used as x-axis.} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} -to be used as y-axis (subject lanes).} +\item{id_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +to be used as y-axis (identifier lanes).} \item{color_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} -to name and color subject events in time.} +to name and color data points in time.} \item{group_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} -to categorize type of event. Legend is sorted according to this variable.} +to categorize type of data point. Legend is sorted according to this variable.} \item{sort_var}{(\code{character(1)}) Name of the column in \code{plot_dataname} whose values determine -the order of subjects displayed on the y-axis.} +the order of identifiers 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 showing subject, time, color, and group variables.} +If \code{NULL}, default tooltip is created showing id, time, color, and group variables.} \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.} @@ -55,54 +56,97 @@ If \code{NULL}, default symbols will be used.} \item{plot_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} \item{show_widgets}{(\code{logical(1)}) Whether to show module 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. } \description{ -This module creates an interactive swimlane plot visualization that displays subjects' events -over time. Each subject is represented by a horizontal lane, with events plotted as points +This module creates an interactive swimlane plot visualization that displays data points +over time. Each identifier is represented by a horizontal lane, with data points plotted as points along the timeline. The plot supports color coding and symbol differentiation for different -event types, customizable sorting of subjects, and interactive tooltips. This visualization -is particularly useful for showing temporal sequences of events across multiple subjects. +categories, customizable sorting of lanes, and interactive tooltips. This visualization +is particularly useful for showing temporal sequences of data points across multiple identifiers. } \examples{ data <- teal_data() |> within({ - subjects <- data.frame( - subject_var = c("A", "B", "C"), - AGE = sample(30:100, 3), - ARM = c("Combination", "Combination", "Placebo") + df <- data.frame( + subject_id = rep(paste0("S", 1:12), each = 3), + study_day = c( + rep(c(15, 45, 90), 4), # First 4 subjects with events at days 15, 45, 90 + rep(c(30, 60, 120), 4), # Next 4 subjects with events at days 30, 60, 120 + rep(c(10, 75, 150), 4) # Last 4 subjects with events at days 10, 75, 150 + ), + event_type = rep(c("Screening", "Treatment Start", "Assessment"), 12), + response_status = sample(c("Complete Response", "Partial Response", "Stable Disease", "Progressive Disease"), 36, replace = TRUE), + treatment_arm = rep(c("Experimental", "Control"), each = 18), + age_group = rep(c("Young", "Middle", "Old"), 12), + center = rep(c("Site A", "Site B", "Site C", "Site D"), 9) ) - 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) - ) + # Add labels + attr(df$subject_id, "label") <- "Subject ID" + attr(df$study_day, "label") <- "Study Day" + attr(df$event_type, "label") <- "Event Type" + attr(df$response_status, "label") <- "Response Status" + attr(df$treatment_arm, "label") <- "Treatment Arm" + attr(df$age_group, "label") <- "Age Group" + attr(df$center, "label") <- "Study Center" }) -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( + label = "Basic Swimlane Plot", + plot_dataname = "df", + time_var = "study_day", + id_var = "subject_id", + color_var = "response_status", + group_var = "event_type" + ) + ) ) +if (interactive()) { + shinyApp(app$ui, app$server) +} + 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"), + label = "Advanced Swimlane Plot with All Features", + plot_dataname = "df", + time_var = "study_day", + id_var = "subject_id", + color_var = "response_status", + group_var = "event_type", + sort_var = "study_day", + tooltip_vars = c("subject_id", "study_day", "event_type", "response_status", "treatment_arm", "age_group", "center"), + point_size = c( + "Complete Response" = 15, + "Partial Response" = 12, + "Stable Disease" = 10, + "Progressive Disease" = 8 + ), point_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" + "Complete Response" = "#00FF00", + "Partial Response" = "#FFFF00", + "Stable Disease" = "#FFA500", + "Progressive Disease" = "#FF0000" ), point_symbols = c( - CR = "circle", PR = "square", SD = "triangle-up", PD = "diamond" - ) + "Complete Response" = "circle", + "Partial Response" = "square", + "Stable Disease" = "triangle-up", + "Progressive Disease" = "diamond" + ), + plot_height = c(800, 500, 1200), + show_widgets = TRUE ) ) ) diff --git a/man/tm_p_waterfall.Rd b/man/tm_p_waterfall.Rd index 9878a147b..743e909f4 100644 --- a/man/tm_p_waterfall.Rd +++ b/man/tm_p_waterfall.Rd @@ -7,7 +7,7 @@ tm_p_waterfall( label = "Waterfall", plot_dataname, - subject_var, + x_var, value_var, sort_var = NULL, color_var = NULL, @@ -15,7 +15,8 @@ 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) + plot_height = c(600, 400, 1200), + transformators = list() ) } \arguments{ @@ -24,8 +25,8 @@ For \code{modules()} defaults to \code{"root"}. See \code{Details}.} \item{plot_dataname}{(\code{character(1)}) Name of the dataset to be used for plotting.} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} -to be used as x-axis (subject identifiers).} +\item{x_var}{(\code{character(1)}) Name of the factor or character column in \code{plot_dataname} +to be used as x-axis (typically subject identifiers).} \item{value_var}{(\code{character(1)}) Name of the numeric column in \code{plot_dataname} to be used as y-axis (values determining bar heights).} @@ -48,6 +49,9 @@ horizontal reference lines on the plot.} \item{plot_title}{(\code{character} or \code{NULL}) Title of the plot. If \code{NULL}, no title is displayed.} \item{plot_height}{(\code{numeric(3)}) Vector of length 3 with c(default, min, max) plot height values.} + +\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. @@ -63,36 +67,72 @@ across 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") + df <- data.frame( + subject_id = paste0("S", 1:20), + percent_change = c( + rnorm(5, -40, 10), # 5 subjects with good response (~-40\%) + rnorm(8, -15, 15), # 8 subjects with moderate response (~-15\%) + rnorm(4, 10, 8), # 4 subjects with progression (~10\%) + rnorm(3, 35, 12) # 3 subjects with significant progression (~35\%) + ), + best_response = c( + rep("Complete Response", 3), + rep("Partial Response", 7), + rep("Stable Disease", 6), + rep("Progressive Disease", 4) + ), + treatment_arm = rep(c("Experimental", "Control"), each = 10), + age_group = sample(c("Young", "Middle", "Old"), 20, replace = TRUE), + baseline_size = abs(rnorm(20, 50, 15)), + center = sample(c("Site A", "Site B", "Site C"), 20, 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) - ) + attr(df$subject_id, "label") <- "Subject ID" + attr(df$percent_change, "label") <- "Percent Change from Baseline" + attr(df$best_response, "label") <- "Best Overall Response" + attr(df$treatment_arm, "label") <- "Treatment Arm" + attr(df$age_group, "label") <- "Age Group" + attr(df$baseline_size, "label") <- "Baseline Tumor Size (mm)" + attr(df$center, "label") <- "Study Center" }) -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( + label = "Basic Waterfall Plot", + plot_dataname = "df", + x_var = "subject_id", + value_var = "percent_change", + color_var = "best_response" + ) + ) ) +if (interactive()) { + shinyApp(app$ui, app$server) +} + 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), + label = "Advanced Waterfall Plot with All Features", + plot_dataname = "df", + x_var = "subject_id", + value_var = "percent_change", + sort_var = "percent_change", + color_var = "best_response", + tooltip_vars = c("subject_id", "percent_change", "best_response", "treatment_arm", "age_group", "baseline_size", "center"), bar_colors = c( - CR = "#FF0000", PR = "#00FF00", SD = "#0000FF", PD = "#FFFF00" - ) + "Complete Response" = "#00FF00", + "Partial Response" = "#FFFF00", + "Stable Disease" = "#FFA500", + "Progressive Disease" = "#FF0000" + ), + value_arbitrary_hlines = c(-30, 20), + plot_title = "Tumor Response Waterfall Plot", + plot_height = c(700, 400, 1000) ) ) ) diff --git a/man/waterfallplotly.Rd b/man/waterfallplotly.Rd index 3cfb06163..34d8ce4fd 100644 --- a/man/waterfallplotly.Rd +++ b/man/waterfallplotly.Rd @@ -6,7 +6,7 @@ \usage{ waterfallplotly( df, - subject_var, + x_var, value_var, sort_var = NULL, color_var = NULL, @@ -21,7 +21,7 @@ waterfallplotly( \arguments{ \item{df}{(\code{character(1)}) Name of the data frame to plot} -\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as x-axis (subject identifiers)} +\item{x_var}{(\code{character(1)}) Name of the factor or character column to be used as x-axis (typically subject identifiers)} \item{value_var}{(\code{character(1)}) Name of the numeric column to be used as y-axis (values determining bar heights)} @@ -55,7 +55,7 @@ bar chart creation, and horizontal reference lines. # Generate code for a waterfall plot code <- waterfallplotly( df = "waterfall_data", - subject_var = "subject_id", + x_var = "subject_id", value_var = "response_value", sort_var = "response_value", color_var = "response_category", From e82888fe4bf0309cea729e5f1cb2661eaaf1fe0b Mon Sep 17 00:00:00 2001 From: vedhav Date: Sat, 27 Sep 2025 02:18:50 +0530 Subject: [PATCH 133/135] chore: fox s[oderplot and write docs for reactable module --- R/tm_p_spiderplot.R | 10 ++-- R/tm_t_reactable.R | 117 ++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 118 insertions(+), 9 deletions(-) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index 712f92f4a..c62d024f8 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -174,7 +174,7 @@ ui_p_spiderplot <- function(id, height) { label = "Value variable (y-axis):", choices = NULL, selected = NULL, multiple = FALSE ), - selectInput(ns("id_var"), label = "ID variable:", choices = NULL, selected = NULL, multiple = FALSE), + selectInput(ns("id_var_input"), label = "ID variable:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("color_var"), label = "Color by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("filter_var"), label = "Filter by:", choices = NULL, selected = NULL, multiple = FALSE), selectInput(ns("filter_var_level"), label = "Select value:", choices = NULL, selected = NULL, multiple = FALSE), @@ -210,7 +210,7 @@ srv_p_spiderplot <- function(id, 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 = "id_var", data = reactive(data()[[dataname]]), cs = id_var) + .update_cs_input(inputId = "id_var_input", data = reactive(data()[[dataname]]), cs = id_var) .update_cs_input(inputId = "color_var", data = reactive(data()[[dataname]]), cs = color_var) .update_cs_input(inputId = "filter_var", data = reactive(data()[[dataname]]), cs = filter_var) @@ -244,7 +244,7 @@ srv_p_spiderplot <- function(id, plotly_q <- reactive({ req( input$filter_var_level, input$time_var, input$value_var, - input$id_var, input$filter_var, input$color_var, color_inputs() + input$id_var_input, input$filter_var, input$color_var, color_inputs() ) adjusted_symbols <- .shape_palette_discrete( @@ -259,7 +259,7 @@ srv_p_spiderplot <- function(id, df = plot_dataname, time_var = input$time_var, value_var = input$value_var, - id_var = input$id_var, + id_var = input$id_var_input, filter_var = input$filter_var, selected_value = input$filter_var_level, color_var = input$color_var, @@ -308,7 +308,7 @@ srv_p_spiderplot <- function(id, #' @param df (`character(1)`) Name of the data frame to plot #' @param time_var (`character(1)`) Name of the numeric column to be used as x-axis #' @param value_var (`character(1)`) Name of the numeric column to be used as y-axis -#' @param subject_var (`character(1)`) Name of the factor or character column to be used as grouping variable +#' @param id_var (`character(1)`) Name of the factor or character column to be used as grouping variable #' @param filter_var (`character(1)`) Name of the factor or character column to be used to filter the data #' @param selected_value (`character(1)`) Selected value for filtering #' @param color_var (`character(1)`) Name of the factor or character column to be used to differentiate colors and symbols diff --git a/R/tm_t_reactable.R b/R/tm_t_reactable.R index bba18b681..5ca55456e 100644 --- a/R/tm_t_reactable.R +++ b/R/tm_t_reactable.R @@ -1,10 +1,119 @@ -#' `teal` module: Reactable +#' Interactive Reactable Tables Module #' -#' Wrapper module on [reactable::reactable()] +#' This module creates interactive, filterable, and sortable tables using the `reactable` package. +#' It provides an accordion-style interface where each dataset is displayed in a separate collapsible +#' panel with dynamic column selection and advanced table features. Users can select which columns +#' to display, filter data in real-time, and interact with the tables through various built-in +#' reactable features. +#' +#' @details +#' The module automatically detects datasets in the provided `teal_data` object and creates +#' interactive tables for each one. Each table supports: +#' \itemize{ +#' \item Dynamic column selection with search and multi-select capabilities +#' \item Real-time filtering and sorting +#' \item Row selection (single or multiple) +#' \item Responsive design that adapts to screen size +#' \item Full-screen mode for detailed data exploration +#' \item Custom column definitions and formatting +#' } +#' +#' Column labels are automatically extracted from dataset attributes when available, providing +#' meaningful headers in the table display. The module integrates seamlessly with teal's +#' filtering system, ensuring that table contents update automatically when filters are applied. #' #' @inheritParams teal::module #' @inheritParams shared_params -#' @param reactable_args (`list`) any argument of [reactable::reactable()]. +#' @param datanames (`character` or `"all"`) Names of datasets to include in the module. +#' Use `"all"` to automatically include all datasets from the `teal_data` object, or provide +#' a character vector of specific dataset names to include only those datasets. +#' @param colnames (`named list`) Optional list specifying column names to display for each dataset. +#' Names should correspond to dataset names, and values should be character vectors of column +#' names. If not specified, all columns are displayed by default. +#' @param reactable_args (`list`) Named list of arguments passed to [reactable::reactable()]. +#' This allows customization of table appearance and behavior, including pagination settings, +#' column definitions, themes, and interactive features. Common options include: +#' \itemize{ +#' \item `pagination` - Enable/disable pagination +#' \item `searchable` - Add global search functionality +#' \item `filterable` - Enable column-specific filters +#' \item `sortable` - Enable column sorting +#' \item `resizable` - Allow column resizing +#' \item `defaultPageSize` - Number of rows per page +#' \item `theme` - Custom theme for table styling +#' \item `columns` - Custom column definitions with formatting +#' } +#' +#' @return A teal module object that can be used in teal applications. +#' +#' @examples +#' data <- teal_data() |> +#' within({ +#' # Demographics +#' adsl <- data.frame( +#' USUBJID = paste0("S", 1:10), +#' AGE = sample(25:75, 10), +#' SEX = sample(c("M", "F"), 10, replace = TRUE), +#' ARM = rep(c("Placebo", "Treatment"), each = 5) +#' ) +#' +#' # Adverse events +#' adae <- data.frame( +#' USUBJID = sample(paste0("S", 1:10), 20, replace = TRUE), +#' AEDECOD = sample(c("Headache", "Nausea", "Fatigue"), 20, replace = TRUE), +#' AESEV = sample(c("MILD", "MODERATE", "SEVERE"), 20, replace = TRUE) +#' ) +#' +#' # Add labels +#' attr(adsl$USUBJID, "label") <- "Subject ID" +#' attr(adsl$AGE, "label") <- "Age (years)" +#' attr(adsl$ARM, "label") <- "Treatment Arm" +#' attr(adae$AEDECOD, "label") <- "Adverse Event" +#' attr(adae$AESEV, "label") <- "Severity" +#' }) +#' +#' # Basic usage +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_t_reactables( +#' label = "Interactive Tables" +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' +#' # Advanced usage with custom features +#' app <- init( +#' data = data, +#' modules = modules( +#' tm_t_reactables( +#' label = "Advanced Tables", +#' datanames = c("adsl", "adae"), +#' colnames = list( +#' adsl = c("USUBJID", "AGE", "SEX", "ARM"), +#' adae = c("USUBJID", "AEDECOD", "AESEV") +#' ), +#' reactable_args = list( +#' pagination = TRUE, +#' searchable = TRUE, +#' filterable = TRUE, +#' sortable = TRUE, +#' defaultPageSize = 10, +#' highlight = TRUE, +#' striped = TRUE +#' ) +#' ) +#' ) +#' ) +#' +#' if (interactive()) { +#' shinyApp(app$ui, app$server) +#' } +#' #' @export tm_t_reactables <- function(label = "Table", datanames = "all", @@ -265,7 +374,7 @@ srv_t_reactable <- function(id, data, filter_panel_api, dataname, colnames, deco if (length(col_def_args)) { as.call( c( - list(quote(colDef)), + list(quote(reactable::colDef)), col_def_args ) ) From c3e3c8b999e5a136a1ecfaf97c2bc44063c7e4fb Mon Sep 17 00:00:00 2001 From: vedhav Date: Sat, 27 Sep 2025 02:19:25 +0530 Subject: [PATCH 134/135] docs: update docs --- man/spiderplotly.Rd | 4 +- man/tm_t_reactables.Rd | 125 +++++++++++++++++++++++++++++++++++++---- 2 files changed, 116 insertions(+), 13 deletions(-) diff --git a/man/spiderplotly.Rd b/man/spiderplotly.Rd index 0fda79b7b..6f3113334 100644 --- a/man/spiderplotly.Rd +++ b/man/spiderplotly.Rd @@ -29,6 +29,8 @@ spiderplotly( \item{value_var}{(\code{character(1)}) Name of the numeric column to be used as y-axis} +\item{id_var}{(\code{character(1)}) Name of the factor or character column to be used as grouping variable} + \item{filter_var}{(\code{character(1)}) Name of the factor or character column to be used to filter the data} \item{selected_value}{(\code{character(1)}) Selected value for filtering} @@ -51,8 +53,6 @@ spiderplotly( \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 time, value, id, and color variables.} - -\item{subject_var}{(\code{character(1)}) Name of the factor or character column to be used as grouping variable} } \value{ A code expression that when evaluated creates a plotly plot object diff --git a/man/tm_t_reactables.Rd b/man/tm_t_reactables.Rd index 6257d9d2f..170b4c31b 100644 --- a/man/tm_t_reactables.Rd +++ b/man/tm_t_reactables.Rd @@ -2,7 +2,7 @@ % Please edit documentation in R/tm_t_reactable.R \name{tm_t_reactables} \alias{tm_t_reactables} -\title{\code{teal} module: Reactable} +\title{Interactive Reactable Tables Module} \usage{ tm_t_reactables( label = "Table", @@ -17,14 +17,13 @@ tm_t_reactables( \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{datanames}{(\code{character} or \code{"all"}) Names of datasets to include in the module. +Use \code{"all"} to automatically include all datasets from the \code{teal_data} object, or provide +a character vector of specific dataset names to include only those datasets.} + +\item{colnames}{(\verb{named list}) Optional list specifying column names to display for each dataset. +Names should correspond to dataset names, and values should be character vectors of column +names. If not specified, all columns are displayed by default.} \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")}.} @@ -34,8 +33,112 @@ To learn more check \code{vignette("transform-input-data", package = "teal")}.} 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()}}.} +\item{reactable_args}{(\code{list}) Named list of arguments passed to \code{\link[reactable:reactable]{reactable::reactable()}}. +This allows customization of table appearance and behavior, including pagination settings, +column definitions, themes, and interactive features. Common options include: +\itemize{ +\item \code{pagination} - Enable/disable pagination +\item \code{searchable} - Add global search functionality +\item \code{filterable} - Enable column-specific filters +\item \code{sortable} - Enable column sorting +\item \code{resizable} - Allow column resizing +\item \code{defaultPageSize} - Number of rows per page +\item \code{theme} - Custom theme for table styling +\item \code{columns} - Custom column definitions with formatting +}} +} +\value{ +A teal module object that can be used in teal applications. } \description{ -Wrapper module on \code{\link[reactable:reactable]{reactable::reactable()}} +This module creates interactive, filterable, and sortable tables using the \code{reactable} package. +It provides an accordion-style interface where each dataset is displayed in a separate collapsible +panel with dynamic column selection and advanced table features. Users can select which columns +to display, filter data in real-time, and interact with the tables through various built-in +reactable features. +} +\details{ +The module automatically detects datasets in the provided \code{teal_data} object and creates +interactive tables for each one. Each table supports: +\itemize{ +\item Dynamic column selection with search and multi-select capabilities +\item Real-time filtering and sorting +\item Row selection (single or multiple) +\item Responsive design that adapts to screen size +\item Full-screen mode for detailed data exploration +\item Custom column definitions and formatting +} + +Column labels are automatically extracted from dataset attributes when available, providing +meaningful headers in the table display. The module integrates seamlessly with teal's +filtering system, ensuring that table contents update automatically when filters are applied. +} +\examples{ +data <- teal_data() |> + within({ + # Demographics + adsl <- data.frame( + USUBJID = paste0("S", 1:10), + AGE = sample(25:75, 10), + SEX = sample(c("M", "F"), 10, replace = TRUE), + ARM = rep(c("Placebo", "Treatment"), each = 5) + ) + + # Adverse events + adae <- data.frame( + USUBJID = sample(paste0("S", 1:10), 20, replace = TRUE), + AEDECOD = sample(c("Headache", "Nausea", "Fatigue"), 20, replace = TRUE), + AESEV = sample(c("MILD", "MODERATE", "SEVERE"), 20, replace = TRUE) + ) + + # Add labels + attr(adsl$USUBJID, "label") <- "Subject ID" + attr(adsl$AGE, "label") <- "Age (years)" + attr(adsl$ARM, "label") <- "Treatment Arm" + attr(adae$AEDECOD, "label") <- "Adverse Event" + attr(adae$AESEV, "label") <- "Severity" + }) + +# Basic usage +app <- init( + data = data, + modules = modules( + tm_t_reactables( + label = "Interactive Tables" + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + +# Advanced usage with custom features +app <- init( + data = data, + modules = modules( + tm_t_reactables( + label = "Advanced Tables", + datanames = c("adsl", "adae"), + colnames = list( + adsl = c("USUBJID", "AGE", "SEX", "ARM"), + adae = c("USUBJID", "AEDECOD", "AESEV") + ), + reactable_args = list( + pagination = TRUE, + searchable = TRUE, + filterable = TRUE, + sortable = TRUE, + defaultPageSize = 10, + highlight = TRUE, + striped = TRUE + ) + ) + ) +) + +if (interactive()) { + shinyApp(app$ui, app$server) +} + } From 7a6b7054a62b39c7c4aaf1c42a8116b6aa001be9 Mon Sep 17 00:00:00 2001 From: vedhav Date: Wed, 1 Oct 2025 20:06:50 +0530 Subject: [PATCH 135/135] feat: allow the tooltips to work on dynamic plot ids --- R/tm_p_bargraph.R | 2 +- R/tm_p_scatterplot.R | 2 +- R/tm_p_spaghetti.R | 2 +- R/tm_p_spiderplot.R | 2 +- R/tm_p_swimlane.R | 2 +- R/utils.R | 6 +++--- 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/R/tm_p_bargraph.R b/R/tm_p_bargraph.R index 3931c3189..61180951a 100644 --- a/R/tm_p_bargraph.R +++ b/R/tm_p_bargraph.R @@ -162,7 +162,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) |> + setup_trigger_tooltips(session$ns("plot")) |> plotly::event_register("plotly_selected") }) }) diff --git a/R/tm_p_scatterplot.R b/R/tm_p_scatterplot.R index 661644484..9f4db3a1a 100644 --- a/R/tm_p_scatterplot.R +++ b/R/tm_p_scatterplot.R @@ -162,7 +162,7 @@ srv_p_scatterplot <- function(id, output$plot <- plotly::renderPlotly( plotly_q()$p |> - setup_trigger_tooltips(session$ns) + setup_trigger_tooltips(session$ns("plot")) ) }) } diff --git a/R/tm_p_spaghetti.R b/R/tm_p_spaghetti.R index 6a221ffdd..58f47ff54 100644 --- a/R/tm_p_spaghetti.R +++ b/R/tm_p_spaghetti.R @@ -173,7 +173,7 @@ srv_p_spaghetti <- function(id, output$plot <- plotly::renderPlotly( plotly_q()$p |> - setup_trigger_tooltips(session$ns) |> + setup_trigger_tooltips(session$ns("plot")) |> set_plot_data(session$ns("plot_data")) |> plotly::event_register("plotly_selected") ) diff --git a/R/tm_p_spiderplot.R b/R/tm_p_spiderplot.R index c62d024f8..190a9177b 100644 --- a/R/tm_p_spiderplot.R +++ b/R/tm_p_spiderplot.R @@ -279,7 +279,7 @@ srv_p_spiderplot <- function(id, { plotly_q()$p |> set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) + setup_trigger_tooltips(session$ns("plot")) }, "plotly_selected" )) diff --git a/R/tm_p_swimlane.R b/R/tm_p_swimlane.R index 6eb85e54b..3f0d64b3a 100644 --- a/R/tm_p_swimlane.R +++ b/R/tm_p_swimlane.R @@ -264,7 +264,7 @@ srv_p_swimlane <- function(id, output$plot <- plotly::renderPlotly({ plotly_q()$p |> set_plot_data(session$ns("plot_data")) |> - setup_trigger_tooltips(session$ns) |> + setup_trigger_tooltips(session$ns("plot")) |> plotly::event_register("plotly_selected") }) }) diff --git a/R/utils.R b/R/utils.R index b03c09818..ca2001bc2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -533,19 +533,19 @@ trigger_tooltips_deps <- function() { #' @keywords internal #' @noRd -setup_trigger_tooltips <- function(plot, ns) { +setup_trigger_tooltips <- function(plot, plot_id) { htmlwidgets::onRender( plot, paste0( "function(el) { - const targetDiv = document.querySelector('#", ns("plot"), " .modebar-group:nth-child(4)'); + const targetDiv = document.querySelector('#", plot_id, " .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"), "') + triggerSelectedTooltips('", plot_id, "') }; const icon = document.createElement('i');