From ce784bba061cd69b4ab025e9bb7cb12d333e83a8 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 6 Nov 2024 12:31:53 +0100 Subject: [PATCH 1/3] WIP --- DESCRIPTION | 1 + NAMESPACE | 2 + R/brush_filter.R | 128 +++++++++++++++++++++++++++++++++++++++++++++++ man/foo1.Rd | 11 ++++ 4 files changed, 142 insertions(+) create mode 100644 R/brush_filter.R create mode 100644 man/foo1.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 32392c391c..ad5c995ced 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -90,6 +90,7 @@ Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 Collate: 'TealAppDriver.R' + 'brush_filter.R' 'checkmate.R' 'dummy_functions.R' 'get_rcode_utils.R' diff --git a/NAMESPACE b/NAMESPACE index e4c3a538d9..99d0bdcf0d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -29,12 +29,14 @@ export(report_card_template) export(reporter_previewer_module) export(set_datanames) export(show_rcode_modal) +export(srv_brush_filter) export(srv_teal) export(srv_teal_with_splash) export(tdata2env) export(teal_data_module) export(teal_slices) export(teal_transform_module) +export(ui_brush_filter) export(ui_teal) export(ui_teal_with_splash) export(validate_has_data) diff --git a/R/brush_filter.R b/R/brush_filter.R new file mode 100644 index 0000000000..22cfdca54c --- /dev/null +++ b/R/brush_filter.R @@ -0,0 +1,128 @@ +# todo: this can't be in teal - it should be in teal.widgets, but... teal.widgets doesn't depend +# on teal.slice nor teal.transform. It is a mess and there is no easy solution to this now. +#' @export +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%") + ) +} + +#' @export +srv_brush_filter <- function(id, brush, dataset, filter_panel_api, selectors = list(), table_dec = 4) { + moduleServer(id, function(input, output, session) { + # selector_list <- isolate(selectors()) + + observeEvent(brush(), ignoreNULL = FALSE, { + if (is.null(brush())) { + shinyjs::hide("title") + shinyjs::hide("data_table") + } else { + shinyjs::show("title") + shinyjs::show("data_table") + } + }) + + brushed_table <- reactive({ + if (is.null(brush())) { + return(NULL) + } + teal.widgets::clean_brushedPoints(isolate(dataset()), brush()) + }) + + output$data_table <- DT::renderDataTable(server = TRUE, { + brushed_df <- req(brushed_table()) + if (is.null(brushed_df)) { + return(NULL) + } + 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)) + } + }) + + 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) + # }) + brushed_df <- brushed_table()[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(brushed_df$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") + } + }) + }) +} + +#' 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/man/foo1.Rd b/man/foo1.Rd new file mode 100644 index 0000000000..ab5dfc4a80 --- /dev/null +++ b/man/foo1.Rd @@ -0,0 +1,11 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/brush_filter.R +\name{foo1} +\alias{foo1} +\title{get axis dataname, varname and ranges} +\usage{ +foo1(brush, selector_list) +} +\description{ +get axis dataname, varname and ranges +} From d8cd81d119d16d5972286c6c28ff013660a4d6ba Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 7 Nov 2024 22:34:36 +0100 Subject: [PATCH 2/3] some changes --- R/brush_filter.R | 35 ++--------------------------------- 1 file changed, 2 insertions(+), 33 deletions(-) diff --git a/R/brush_filter.R b/R/brush_filter.R index 22cfdca54c..4cb411539c 100644 --- a/R/brush_filter.R +++ b/R/brush_filter.R @@ -6,10 +6,7 @@ ui_brush_filter <- function(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") - ), + actionButton(ns("apply_brush_filter"), "Apply filter"), DT::dataTableOutput(ns("data_table"), width = "100%") ) } @@ -30,6 +27,7 @@ srv_brush_filter <- function(id, brush, dataset, filter_panel_api, selectors = l }) brushed_table <- reactive({ + req(brush()) if (is.null(brush())) { return(NULL) } @@ -84,35 +82,6 @@ srv_brush_filter <- function(id, brush, dataset, filter_panel_api, selectors = l 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") - } - }) }) } From 4d47422cf1d5bb7f632eee01c2595ba7650f7a3b Mon Sep 17 00:00:00 2001 From: github-actions <41898282+github-actions[bot]@users.noreply.github.com> Date: Fri, 15 Nov 2024 09:07:48 +0000 Subject: [PATCH 3/3] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/teal_data_module.Rd | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/man/teal_data_module.Rd b/man/teal_data_module.Rd index 9c3cbd29f9..9765ce4504 100644 --- a/man/teal_data_module.Rd +++ b/man/teal_data_module.Rd @@ -35,7 +35,9 @@ App user will be able to interact and change the data output from the module mul \item{object}{(\code{teal_data_module})} -\item{code}{(\code{character} or \code{language}) code to evaluate. If \code{character}, comments are retained.} +\item{code}{(\code{character}, \code{language} or \code{expression}) code to evaluate. +It is possible to preserve original formatting of the \code{code} by providing a \code{character} or an +\code{expression} being a result of \code{parse(keep.source = TRUE)}.} \item{data}{(\code{teal_data_module}) object}