Feature: Highlight and Enlarge points

DESCRIPTION

@@ -18,7 +18,8 @@ Imports:
     rlang,
     purrr,
     viridisLite,
-    grDevices
+    grDevices,
+    cli
 RoxygenNote: 7.3.2
 Roxygen: list(markdown = TRUE)
 Suggests: 

NAMESPACE

@@ -1,15 +1,25 @@
 # Generated by roxygen2: do not edit by hand
 
 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

@@ -63,3 +63,185 @@ shinyRenderDisplayScatter3d <- function(expr, env = parent.frame(), quoted = FAL
   }
   htmlwidgets::shinyRenderWidget(expr, displayScatter3dOutput, quoted = TRUE, env = env)
 }
+
+#' Send commands to a detourr instance in a Shiny app
+#'
+#' Creates a proxy object that can be used to add
+#' or remove points to a detour instance that has
+#' already being rendered using \code{\link{shinyRenderDisplayScatter3d}}.
+#' To be used in Shiny apps only.
+#' @param id output id of the detourr instance
+#' @param session the Shiny session object used in the app.
+#' Default should work for most cases
+#'
+#' @rdname detour-shiny
+#' @export
+display_scatter_proxy <- function(id, session = shiny::getDefaultReactiveDomain()) { #nolint
+  structure(list(id = id, session = session), class = "detourr_proxy")
+}
+
+#' @title Add a set of points to an existing detourr instance in Shiny
+#' @param proxy Proxy object created by \code{\link{display_scatter_proxy}}
+#' @param points Data.frame of points
+#' @param .data Original dataset used in creating the detourr instance
+#' @param .col_means Vector of column means of the original dataset.
+#'  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
+add_points <- function(
+  proxy,
+  points,
+  .data = NULL,
+  .col_means = NULL,
+  .scale_factor = NULL,
+  colour = "black",
+  size =  1,
+  alpha = 1
+) {
+  if (is.null(.data)) {
+    if (is.null(.col_means) || is.null(.scale_factor)) {
+      cli::cli_abort(c(
+        "Either {.var .data} or both {.var .col_means} and {.var .scale_factor} should be given",
+        "i" = "Pass the data used to create the detourr instance as {.var .data}"
+      ))
+    }
+  } else {
+    scaled_data <- scale(.data, scale = FALSE)
+    .col_means <- attributes(scaled_data)[["scaled:center"]]
+    .scale_factor <- 1 / max(sqrt(rowSums(scaled_data^2)))
+  }
+  points <- unname(as.matrix(points)) |>
+    scale(
+      center = .col_means,
+      scale = FALSE
+    )
+  points <- points * .scale_factor
+  message <- list(
+    id = proxy$id,
+    data = apply(points, 1, as.list),
+    config = list(
+      colour = colour,
+      size = size,
+      alpha = alpha
+    )
+  )
+  if (!is.null(proxy$message)) {
+    # previous proxy message exists
+    proxy$message$data <- message$data
+    proxy$message$config <- message$config
+  } else {
+    proxy$message <- message
+  }
+  proxy$session$sendCustomMessage("add-points", proxy$message)
+  return(proxy)
+}
+
+#' @title Function to add a bunch of lines to existing shiny instance
+#'
+#' @param proxy Proxy object created by \code{\link{display_scatter_proxy}}
+#' @param edge_list Data.frame with two columns with the `from` node at first.
+#' The indexing of points starts with the original dataset.
+#' If \code{\link{add_points}} has been called before hand,
+#' the indexing of these points starts from the end of the original dataset.
+#' @return Proxy object to be used for piping
+#' @rdname detour-shiny
+#' @export
+add_edges <- function(proxy, edge_list) {
+  edge_list <- edge_list |> as.matrix() |> unname()
+  proxy$message$edges <- apply(edge_list, 1, as.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

@@ -0,0 +1,88 @@
+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 <- rnorm(1, mean = 3)
+  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("Adding points and edges 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"
+      )
+    )
+  )
+}
+
+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, {
+      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))
+        ) |>
+        add_edges(
+          edge_list = cube_box$edges
+        )
+    })
+
+  })
+}
+
+ui <- function() {
+  main_ui("main")
+}
+
+server <- function(input, output, session) {
+  main_server("main")
+}
+
+shinyApp(ui, server, options = list(port = 5534))