feat: improve the trigger tooltips

vedhav · vedhav · commit 68d212f5f6f6 · 2025-05-14T12:21:18.000+05:30
diff --git 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
@@ -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
@@ -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
@@ -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/triggerTooltips/triggerTooltips.js b/inst/triggerTooltips/triggerTooltips.js
