Merge pull request #123 from janithwanni/feat/highlight-enlarge-points

Feature: Highlight and Enlarge points

Author: casperhart

NAMESPACE

@@ -3,16 +3,23 @@
 S3method(as.list,detour)
 export(add_edges)
 export(add_points)
+export(clear_edges)
+export(clear_enlarge)
+export(clear_highlight)
+export(clear_points)
 export(dependence_tour)
 export(detour)
 export(displayScatter2dOutput)
 export(displayScatter3dOutput)
 export(display_scatter_proxy)
+export(enlarge_points)
+export(force_rerender)
 export(frozen_guided_tour)
 export(frozen_tour)
 export(grand_tour)
 export(guided_section_tour)
 export(guided_tour)
+export(highlight_points)
 export(is_detour)
 export(little_tour)
 export(local_tour)

R/shiny_bindings.r

@@ -88,6 +88,9 @@ display_scatter_proxy <- function(id, session = shiny::getDefaultReactiveDomain(
 #'  Defaults to the result of `attributes(scale(.data))[["scaled:center"]]`
 #' @param .scale_factor Numeric value to multiply the centered data.
 #' Defaults to `1 / max(sqrt(rowSums(scale(.data)^2)))`
+#' @param colour Vector or single value containing hex values of colors (or web colors)
+#' @param size Numeric value for the size of the added points
+#' @param alpha Transparency of the added points
 #' @return Proxy object to be used for piping
 #' @rdname detour-shiny
 #' @export
@@ -155,3 +158,90 @@ add_edges <- function(proxy, edge_list) {
   proxy$session$sendCustomMessage("add-edges", proxy$message)
   return(proxy)
 }
+
+#' Function to highlight a given set of points
+#'
+#' The given points will have the original opacity while the other points
+#' will have reduced opacity
+#'
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param point_list Numeric vector. indexes to highlight in the prinary dataset
+#' @param alpha The transparency value of the points outside of the point_list
+#' @rdname detour-shiny
+#' @export
+highlight_points <- function(proxy, point_list, alpha = 0.3) {
+  if (length(point_list) == 1) {
+    point_list <- list(point_list)
+  }
+  proxy$message$point_list <- point_list
+  proxy$session$sendCustomMessage("highlight-points", proxy$message)
+  return(proxy)
+}
+
+#' Function to enlarge a given set of points
+#'
+#' The given points will have a larger size while the rest
+#' remains the same
+#'
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param point_list Numeric vector. indexes to enlarge in the prinary dataset
+#' @param size the size of the points to be enlarged
+#' @rdname detour-shiny
+#' @export
+enlarge_points <- function(proxy, point_list, size = 2) {
+  if (length(point_list) == 1) {
+    point_list <- list(point_list)
+  }
+  proxy$message$enlarge_point_list <- point_list
+  proxy$message$size <- size
+  proxy$session$sendCustomMessage("enlarge-points", proxy$message)
+  return(proxy)
+}
+
+
+#' Function to clear added points
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @rdname detour-shiny
+#' @export
+clear_points <- function(proxy) {
+  proxy$session$sendCustomMessage("clear-points", list(id = proxy$id))
+  return(proxy)
+}
+
+#' Function to clear added edges
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @rdname detour-shiny
+#' @export
+clear_edges <- function(proxy) {
+  proxy$session$sendCustomMessage("clear-edges", list(id = proxy$id))
+  return(proxy)
+}
+
+#' Function to clear highlighted points
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @rdname detour-shiny
+#' @export
+clear_highlight <- function(proxy) {
+  proxy$session$sendCustomMessage("clear-highlight", list(id = proxy$id))
+  return(proxy)
+}
+
+#' Function to clear enlarged points
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @rdname detour-shiny
+#' @export
+clear_enlarge <- function(proxy) {
+  proxy$session$sendCustomMessage("clear-enlarge", list(id = proxy$id))
+  return(proxy)
+}
+
+#' Function to force rerender of detourr
+#'
+#' Useful when detourr will not update unless put on focus
+#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @rdname detour-shiny
+#' @export
+force_rerender <- function(proxy) {
+  proxy$session$sendCustomMessage("clear-enlarge", list(id = proxy$id))
+  return(proxy)
+}

demo/shiny_detourr/add_points_edges.R

@@ -6,7 +6,7 @@ dataset <- tourr::flea |>
 
 create_fake_box <- function(datum) {
   # expected tibble needs to have two rows with ncols(datum) + 1 columns
-  box_dist <- rnorm(1, mean = 3)
+  box_dist <- 2 
   bounds_list <- rbind(datum + box_dist, datum - box_dist) |>
     as.list()
   do.call(tidyr::expand_grid, bounds_list)

demo/shiny_detourr/detour_shiny_feature_demo.R

@@ -0,0 +1,132 @@
+library(shiny)
+library(detourr)
+
+dataset <- tourr::flea |>
+  dplyr::mutate(id = dplyr::row_number())
+
+create_fake_box <- function(datum) {
+  # expected tibble needs to have two rows with ncols(datum) + 1 columns
+  box_dist <- 2 
+  bounds_list <- rbind(datum + box_dist, datum - box_dist) |>
+    as.list()
+  do.call(tidyr::expand_grid, bounds_list)
+}
+
+main_ui <- function(id) {
+  ns <- NS(id)
+  fluidPage(
+    column(6,
+      displayScatter2dOutput(
+        ns("detourr_out"), width = "100%", height = "400px"
+      ),
+      textOutput(ns("detour_click_output"))
+    ),
+    column(6,
+      h1(
+        "Tour of aesthetic changes",
+        "for points and edges added to detourr through Shiny"
+      ),
+      p(
+        "In this demonstration,",
+        "clicking on points on the detourr instance to the left",
+        "adds a box around the point.",
+        "Click on the play button to view the box in different projections"
+      ),
+      p(
+        "A random set of points will be highlighted",
+        "(By having a higher opacity than others)",
+        "The point clicked on has a bigger radius"
+      ),
+      p(
+        "Click on an empty space in the dataset",
+        "to remove the aesthetics completely.",
+        "Or else click on the eraser (clear) button",
+        "on the right handside of the controls" 
+      )
+    )
+  )
+}
+
+main_server <- function(id) {
+  moduleServer(id, function(input, output, session){
+    output$detourr_out <- shinyRenderDisplayScatter2d({
+      detour(dataset,
+        tour_aes(projection = -c(id, species), colour = species, label = id)
+      ) |>
+        tour_path(grand_tour(2), fps = 60) |>
+        show_scatter(
+          alpha = 0.7,
+          axes = TRUE
+        )
+    })
+
+    output$detour_click_output <- renderText({
+      input$detourr_out_detour_click
+    })
+
+    observeEvent(input$detourr_out_detour_click, {
+      if (
+        is.null(
+          input$detourr_out_detour_click
+          ) || input$detourr_out_detour_click == -1
+      ) {
+        display_scatter_proxy(session$ns("detourr_out")) |>
+          clear_points() |>
+          clear_edges() |>
+          clear_highlight() |>
+          clear_enlarge()
+      }
+      req(
+        !is.null(input$detourr_out_detour_click),
+        input$detourr_out_detour_click != -1
+      )
+      data_to_send <- dataset |>
+        dplyr::select(-species) |>
+        dplyr::filter(id == input$detourr_out_detour_click) |>
+        dplyr::select(-id)
+
+      box_to_send <- data_to_send |> create_fake_box()
+
+      cube_box <- geozoo::cube.iterate(p = ncol(data_to_send))
+
+      display_scatter_proxy(session$ns("detourr_out")) |>
+        add_points(
+          box_to_send,
+          .data = dataset |> dplyr::select(-c(id, species)),
+          colour = sample(
+            c(
+              "#d62b4d",
+              "#01a760",
+              "#9a0582",
+              "#626300",
+              "#ff9d4a"
+            ),
+            nrow(box_to_send),
+            replace = TRUE
+          ),
+          size = 1,
+          alpha = 0.6
+        ) |>
+        add_edges(
+          edge_list = cube_box$edges
+        ) |>
+        highlight_points(
+          point_list = sample(nrow(dataset))[1:(floor(nrow(dataset)*0.5))] # snap half of the points out
+        ) |>
+        enlarge_points(
+          input$detourr_out_detour_click, size = 3
+        )
+    })
+
+  })
+}
+
+ui <- function() {
+  main_ui("main")
+}
+
+server <- function(input, output, session) {
+  main_server("main")
+}
+
+shinyApp(ui, server, options = list(port = 5534))