From 9beabd0125d8f069d3ef9dcfb65cc6fb9c820cce Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Wed, 6 Nov 2024 10:27:00 +0100 Subject: [PATCH 1/4] WIP --- R/brush_filter.R | 121 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 121 insertions(+) create mode 100644 R/brush_filter.R diff --git a/R/brush_filter.R b/R/brush_filter.R new file mode 100644 index 000000000..7dd944ca9 --- /dev/null +++ b/R/brush_filter.R @@ -0,0 +1,121 @@ +#' @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, 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("data_table") + } else { + shinyjs::show("title") + 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" + ) + ) + ) + }) + + brushed_table <- reactive({ + plot_brush <- brush() + if (is.null(plot_brush)) { + return(NULL) + } + dataset <- isolate(teal.code::dev_suppress(data()[["ANL"]])) + teal.widgets::clean_brushedPoints(dataset, plot_brush) + }) + + 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" + )) + set_filter_state(filter_panel_api, slice) + }) + + output$data_table <- DT::renderDataTable(server = TRUE, { + brushed_df <- 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)) + } + }) + }) +} + +#' 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"))]) + ) + }) +} From 127f1ce354a727ae80119937ccbf1a32e1de1d71 Mon Sep 17 00:00:00 2001 From: go_gonzo Date: Thu, 7 Nov 2024 22:34:05 +0100 Subject: [PATCH 2/4] WIP on spotfire_poc --- R/brush_filter.R | 121 ----------------------------------------- R/plot_with_settings.R | 109 +++++++++++++++++++++++++++---------- 2 files changed, 79 insertions(+), 151 deletions(-) delete mode 100644 R/brush_filter.R diff --git a/R/brush_filter.R b/R/brush_filter.R deleted file mode 100644 index 7dd944ca9..000000000 --- a/R/brush_filter.R +++ /dev/null @@ -1,121 +0,0 @@ -#' @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, 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("data_table") - } else { - shinyjs::show("title") - 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" - ) - ) - ) - }) - - brushed_table <- reactive({ - plot_brush <- brush() - if (is.null(plot_brush)) { - return(NULL) - } - dataset <- isolate(teal.code::dev_suppress(data()[["ANL"]])) - teal.widgets::clean_brushedPoints(dataset, plot_brush) - }) - - 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" - )) - set_filter_state(filter_panel_api, slice) - }) - - output$data_table <- DT::renderDataTable(server = TRUE, { - brushed_df <- 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)) - } - }) - }) -} - -#' 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/plot_with_settings.R b/R/plot_with_settings.R index 2a6810657..311e5d6db 100644 --- a/R/plot_with_settings.R +++ b/R/plot_with_settings.R @@ -242,6 +242,7 @@ plot_with_settings_ui <- function(id) { #' plot_with_settings_srv <- function(id, plot_r, + gg2plotly = TRUE, height = c(600, 200, 2000), width = NULL, show_hide_signal = reactive(TRUE), @@ -296,7 +297,10 @@ plot_with_settings_srv <- function(id, } plot_type <- reactive({ - if (inherits(plot_r(), "ggplot")) { + req(plot_suppress(plot_r())) + if (inherits(plot_r(), "ggplot") && gg2plotly) { + "ggplotly" + } else if (inherits(plot_r(), "ggplot")) { "gg" } else if (inherits(plot_r(), "trellis")) { "trel" @@ -373,17 +377,55 @@ plot_with_settings_srv <- function(id, p_height <- reactive(`if`(!is.null(input$height), input$height, height[1])) p_width <- reactive(`if`(!is.null(input$width), input$width, default_slider_width()[1])) - output$plot_main <- renderPlot( - apply_plot_modifications( - plot_obj = plot_suppress(plot_r()), - plot_type = plot_suppress(plot_type()), - dblclicking = dblclicking, - ranges = ranges - ), - res = get_plot_dpi(), - height = p_height, - width = p_width - ) + + observeEvent(plot_type(), ignoreNULL = TRUE, once = TRUE, { + output$plot_main <- if (identical(plot_type(), "ggplotly")) { + plotly::renderPlotly({ + plotly::event_register( + plotly::layout( + plotly::ggplotly(plot_r(), layerData = 1), + dragmode = "select" + ), + "plotly_selected" + ) + }) + } else { + renderPlot( + { + apply_plot_modifications( + plot_obj = plot_suppress(plot_r()), + plot_type = plot_suppress(plot_type()), + dblclicking = dblclicking, + ranges = ranges + ) + }, + res = get_plot_dpi(), + height = p_height, + width = p_width + ) + } + }) + + + + plotly_brush <- reactive({ + req(plot_suppress(plot_r())) + # layer_data(plot_r(), 3) + # ggplot_build(plot_r())$plot$data + bbox <- plotly::event_data("plotly_selected") + if (is.null(bbox)) { + return(NULL) + } + list( + mapping = list( + x = rlang::as_label(plot_r()$mapping$x), + y = rlang::as_label(plot_r()$mapping$y) + ), + xmin = min(bbox$x), xmax = max(bbox$x), + ymin = min(bbox$y), ymax = max(bbox$y), + direction = "xy" + ) + }) output$plot_modal <- renderPlot( apply_plot_modifications( @@ -399,17 +441,21 @@ plot_with_settings_srv <- function(id, output$plot_out_main <- renderUI({ req(plot_suppress(plot_r())) - tags$div( - align = graph_align, - plotOutput( - ns("plot_main"), - height = "100%", - brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = FALSE), NULL), - click = `if`(clicking, clickOpts(ns("plot_click")), NULL), - dblclick = `if`(dblclicking, dblclickOpts(ns("plot_dblclick")), NULL), - hover = `if`(hovering, hoverOpts(ns("plot_hover")), NULL) + if (identical(plot_type(), "ggplotly")) { + plotly::plotlyOutput(ns("plot_main")) + } else { + tags$div( + align = graph_align, + plotOutput( + ns("plot_main"), + height = "100%", + brush = `if`(brushing, brushOpts(ns("plot_brush"), resetOnNew = FALSE), NULL), + click = `if`(clicking, clickOpts(ns("plot_click")), NULL), + dblclick = `if`(dblclicking, dblclickOpts(ns("plot_dblclick")), NULL), + hover = `if`(hovering, hoverOpts(ns("plot_hover")), NULL) + ) ) - ) + } }) output$width_warning <- renderUI({ @@ -500,25 +546,28 @@ plot_with_settings_srv <- function(id, return( list( brush = reactive({ - # refresh brush data on the main plot size change - input$height - input$width - input$plot_brush + if (identical(plot_type(), "ggplotly")) { + plotly_brush() + } else { + input$height + input$width + input$plot_brush + } }), click = reactive({ - # refresh click data on the main plot size change + # # refresh click data on the main plot size change input$height input$width input$plot_click }), dblclick = reactive({ - # refresh double click data on the main plot size change + # # refresh double click data on the main plot size change input$height input$width input$plot_dblclick }), hover = reactive({ - # refresh hover data on the main plot size change + # # refresh hover data on the main plot size change input$height input$width input$plot_hover @@ -603,7 +652,7 @@ type_download_srv <- function(id, plot_reactive, plot_type, plot_w, default_w, p #' x = "AGE", #' y = "BMRKR1" #' ), -#' xmin = 30, xmax = 40, +#' xmin = 30.1, xmax = 40, #' ymin = 0.7, ymax = 10, #' direction = "xy" #' ) From 41b7002272a47782830053975c4f5a533c6cccbf 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 09:06:15 +0000 Subject: [PATCH 3/4] [skip roxygen] [skip vbump] Roxygen Man Pages Auto Update --- man/clean_brushedPoints.Rd | 2 +- man/plot_with_settings.Rd | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/man/clean_brushedPoints.Rd b/man/clean_brushedPoints.Rd index 36980fe02..e0bfb12af 100644 --- a/man/clean_brushedPoints.Rd +++ b/man/clean_brushedPoints.Rd @@ -27,7 +27,7 @@ brush <- list( x = "AGE", y = "BMRKR1" ), - xmin = 30, xmax = 40, + xmin = 30.1, xmax = 40, ymin = 0.7, ymax = 10, direction = "xy" ) diff --git a/man/plot_with_settings.Rd b/man/plot_with_settings.Rd index b508a5d18..348827e65 100644 --- a/man/plot_with_settings.Rd +++ b/man/plot_with_settings.Rd @@ -11,6 +11,7 @@ plot_with_settings_ui(id) plot_with_settings_srv( id, plot_r, + gg2plotly = TRUE, height = c(600, 200, 2000), width = NULL, show_hide_signal = reactive(TRUE), From 026d72bab4c9c9f1ca612ef73bfe418719aaad70 Mon Sep 17 00:00:00 2001 From: vedhav Date: Tue, 19 Nov 2024 20:02:57 +0530 Subject: [PATCH 4/4] fix: allow dynamic height adjustment for plotly plots --- R/plot_with_settings.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/plot_with_settings.R b/R/plot_with_settings.R index 311e5d6db..2bf18978e 100644 --- a/R/plot_with_settings.R +++ b/R/plot_with_settings.R @@ -383,7 +383,7 @@ plot_with_settings_srv <- function(id, plotly::renderPlotly({ plotly::event_register( plotly::layout( - plotly::ggplotly(plot_r(), layerData = 1), + plotly::ggplotly(plot_r(), layerData = 1, height = p_height()), dragmode = "select" ), "plotly_selected" @@ -442,7 +442,7 @@ plot_with_settings_srv <- function(id, output$plot_out_main <- renderUI({ req(plot_suppress(plot_r())) if (identical(plot_type(), "ggplotly")) { - plotly::plotlyOutput(ns("plot_main")) + plotly::plotlyOutput(ns("plot_main"), height = "100%") } else { tags$div( align = graph_align,