Merge pull request #120 from casperhart/convert-to-single-widget

convert to single widget

Author: casperhart

NAMESPACE

@@ -9,9 +9,8 @@ export(clear_highlight)
 export(clear_points)
 export(dependence_tour)
 export(detour)
-export(displayScatter2dOutput)
-export(displayScatter3dOutput)
-export(display_scatter_proxy)
+export(detourOutput)
+export(detour_proxy)
 export(enlarge_points)
 export(force_rerender)
 export(frozen_guided_tour)
@@ -24,8 +23,7 @@ export(is_detour)
 export(little_tour)
 export(local_tour)
 export(planned_tour)
-export(shinyRenderDisplayScatter2d)
-export(shinyRenderDisplayScatter3d)
+export(shinyRenderDetour)
 export(show_sage)
 export(show_scatter)
 export(show_slice)

R/shiny_bindings.r

@@ -1,4 +1,3 @@
-
 #' Shiny bindings for detourr
 #'
 #' Output and render functions for using detourr with shiny. The output
@@ -13,31 +12,15 @@
 #'
 #' @return An output or render function that enables the use of the widget
 #' within shiny applications
-#' 
+#'
 #' @name detour-shiny
 #' @export
-displayScatter3dOutput <- function(output_id,
-                                   width = "100%",
-                                   height = "400px") {
-  htmltools::attachDependencies(
-    shiny::tagList(
-      htmlwidgets::shinyWidgetOutput(output_id, "show_scatter_3d",
-        width, height,
-        package = "detourr"
-      )
-    ),
-    crosstalk::crosstalkLibs()
-  )
-}
-
-#' @rdname detour-shiny
-#' @export
-displayScatter2dOutput <- function(output_id,
-                                   width = "100%",
-                                   height = "400px") {
+detourOutput <- function(output_id,
+                         width = "100%",
+                         height = "400px") {
   htmltools::attachDependencies(
     shiny::tagList(
-      htmlwidgets::shinyWidgetOutput(output_id, "show_scatter_2d",
+      htmlwidgets::shinyWidgetOutput(output_id, "detourr",
         width, height,
         package = "detourr"
       )
@@ -48,40 +31,31 @@ displayScatter2dOutput <- function(output_id,
 
 #' @rdname detour-shiny
 #' @export
-shinyRenderDisplayScatter2d <- function(expr, env = parent.frame(), quoted = FALSE) {
+shinyRenderDetour <- function(expr, env = parent.frame(), quoted = FALSE) {
   if (!quoted) {
     expr <- substitute(expr)
   }
-  htmlwidgets::shinyRenderWidget(expr, displayScatter2dOutput, quoted = TRUE, env = env)
-}
-
-#' @rdname detour-shiny
-#' @export
-shinyRenderDisplayScatter3d <- function(expr, env = parent.frame(), quoted = FALSE) {
-  if (!quoted) {
-    expr <- substitute(expr)
-  }
-  htmlwidgets::shinyRenderWidget(expr, displayScatter3dOutput, quoted = TRUE, env = env)
+  htmlwidgets::shinyRenderWidget(expr, detourOutput, 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}}.
+#' already being rendered using \code{\link{shinyRenderDetour}}.
 #' To be used in Shiny apps only.
-#' @param id output id of the detourr instance
+#' @param id output id of the detour 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")
+detour_proxy <- function(id, session = shiny::getDefaultReactiveDomain()) { # nolint
+  structure(list(id = id, session = session), class = "detour_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 proxy Proxy object created by \code{\link{detour_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.
@@ -95,15 +69,14 @@ display_scatter_proxy <- function(id, session = shiny::getDefaultReactiveDomain(
 #' @rdname detour-shiny
 #' @export
 add_points <- function(
-  proxy,
-  points,
-  .data = NULL,
-  .col_means = NULL,
-  .scale_factor = NULL,
-  colour = "black",
-  size =  1,
-  alpha = 1
-) {
+    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(
@@ -144,7 +117,7 @@ add_points <- function(
 
 #' @title Function to add a bunch of lines to existing shiny instance
 #'
-#' @param proxy Proxy object created by \code{\link{display_scatter_proxy}}
+#' @param proxy Proxy object created by \code{\link{detour_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,
@@ -153,7 +126,9 @@ add_points <- function(
 #' @rdname detour-shiny
 #' @export
 add_edges <- function(proxy, edge_list) {
-  edge_list <- edge_list |> as.matrix() |> unname()
+  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)
@@ -164,7 +139,7 @@ add_edges <- function(proxy, edge_list) {
 #' 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 proxy proxy object created by \code{\link{detour_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
@@ -183,7 +158,7 @@ highlight_points <- function(proxy, point_list, alpha = 0.3) {
 #' 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 proxy proxy object created by \code{\link{detour_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
@@ -200,7 +175,7 @@ enlarge_points <- function(proxy, point_list, size = 2) {
 
 
 #' Function to clear added points
-#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param proxy proxy object created by \code{\link{detour_proxy}}
 #' @rdname detour-shiny
 #' @export
 clear_points <- function(proxy) {
@@ -209,7 +184,7 @@ clear_points <- function(proxy) {
 }
 
 #' Function to clear added edges
-#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param proxy proxy object created by \code{\link{detour_proxy}}
 #' @rdname detour-shiny
 #' @export
 clear_edges <- function(proxy) {
@@ -218,7 +193,7 @@ clear_edges <- function(proxy) {
 }
 
 #' Function to clear highlighted points
-#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param proxy proxy object created by \code{\link{detour_proxy}}
 #' @rdname detour-shiny
 #' @export
 clear_highlight <- function(proxy) {
@@ -227,7 +202,7 @@ clear_highlight <- function(proxy) {
 }
 
 #' Function to clear enlarged points
-#' @param proxy proxy object created by \code{\link{display_scatter_proxy}}
+#' @param proxy proxy object created by \code{\link{detour_proxy}}
 #' @rdname detour-shiny
 #' @export
 clear_enlarge <- function(proxy) {
@@ -238,10 +213,10 @@ clear_enlarge <- function(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}}
+#' @param proxy proxy object created by \code{\link{detour_proxy}}
 #' @rdname detour-shiny
 #' @export
 force_rerender <- function(proxy) {
   proxy$session$sendCustomMessage("clear-enlarge", list(id = proxy$id))
   return(proxy)
-}
+}

R/show_sage.R

@@ -59,7 +59,7 @@ show_sage <- function(x,
 
   x <- make_detour(x, d)
 
-  widget <- paste0("show_sage", "_", tour_output_dim(x), "d")
+  widget_type <- paste0("DisplaySage", tour_output_dim(x), "d")
 
-  make_widget(x, widget, dots$width, dots$height, d$crosstalk$crosstalk_libs)
+  make_widget(x, widget_type, dots$width, dots$height, d$crosstalk$crosstalk_libs)
 }

R/show_scatter.R

@@ -1,4 +1,3 @@
-
 #' 2D and 3D Scatter Plot Display for Tours
 #'
 #' @description
@@ -36,9 +35,9 @@ show_scatter <- function(x,
 
   d <- attributes(x)
 
-  widget <- paste0("show_scatter", "_", tour_output_dim(x), "d")
+  widget_type <- paste0("DisplayScatter", tour_output_dim(x), "d")
 
-  make_widget(x, widget, dots$width, dots$height, d$crosstalk$crosstalk_libs)
+  make_widget(x, widget_type, dots$width, dots$height, d$crosstalk$crosstalk_libs)
 }
 
 #' Internal method for 2D and 3D Scatter Plot Display

R/show_slice.R

@@ -63,9 +63,9 @@ show_slice <- function(x,
 
   d$config$anchor <- anchor
 
-  x <- make_detour(x, d)
+  widget_type <- paste0("DisplaySlice", tour_output_dim(x), "d")
 
-  widget <- paste0("show_slice", "_", tour_output_dim(x), "d")
+  x <- make_detour(x, d)
 
-  make_widget(x, widget, dots$width, dots$height, d$crosstalk$crosstalk_libs)
+  make_widget(x, widget_type, dots$width, dots$height, d$crosstalk$crosstalk_libs)
 }

R/utils.R

@@ -123,10 +123,13 @@ check_dots <- function(dots, supported_arg_names) {
   }
 }
 
-make_widget <- function(x, widget, width, height, dependencies) {
+make_widget <- function(x, widget_type, width, height, dependencies) {
+  x <- as.list(x)
+  x$widgetType <- widget_type
+
   htmlwidgets::createWidget(
-    widget,
-    as.list(x),
+    "detourr",
+    x,
     sizingPolicy = htmlwidgets::sizingPolicy(
       viewer.padding = 0,
       viewer.paneHeight = 500,

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 <- 2 
+  box_dist <- 2
   bounds_list <- rbind(datum + box_dist, datum - box_dist) |>
     as.list()
   do.call(tidyr::expand_grid, bounds_list)
@@ -15,13 +15,16 @@ create_fake_box <- function(datum) {
 main_ui <- function(id) {
   ns <- NS(id)
   fluidPage(
-    column(6,
-      displayScatter2dOutput(
-        ns("detourr_out"), width = "100%", height = "400px"
+    column(
+      6,
+      detourOutput(
+        ns("detourr_out"),
+        width = "100%", height = "400px"
       ),
       textOutput(ns("detour_click_output"))
     ),
-    column(6,
+    column(
+      6,
       h1("Adding points and edges to detourr through Shiny"),
       p(
         "In this demonstration,",
@@ -34,9 +37,10 @@ main_ui <- function(id) {
 }
 
 main_server <- function(id) {
-  moduleServer(id, function(input, output, session){
-    output$detourr_out <- shinyRenderDisplayScatter2d({
-      detour(dataset,
+  moduleServer(id, function(input, output, session) {
+    output$detourr_out <- shinyRenderDetour({
+      detour(
+        dataset,
         tour_aes(projection = -c(id, species), colour = species, label = id)
       ) |>
         tour_path(grand_tour(2), fps = 60) |>
@@ -64,7 +68,7 @@ main_server <- function(id) {
 
       cube_box <- geozoo::cube.iterate(p = ncol(data_to_send))
 
-      display_scatter_proxy(session$ns("detourr_out")) |>
+      detour_proxy(session$ns("detourr_out")) |>
         add_points(
           box_to_send,
           .data = dataset |> dplyr::select(-c(id, species))
@@ -73,7 +77,6 @@ main_server <- function(id) {
           edge_list = cube_box$edges
         )
     })
-
   })
 }
 

demo/shiny_detourr/app.r

@@ -18,7 +18,7 @@ ui <- fluidPage(
 
     # output function used matches display method (show_scatter) and tour
     # dimension (3d)
-    column(8, displayScatter3dOutput("detour", height = "800px"))
+    column(8, detourOutput("detour", height = "800px"))
   )
 )
 
@@ -39,7 +39,7 @@ server <- function(input, output, session) {
     )
   })
 
-  output$detour <- shinyRenderDisplayScatter3d({
+  output$detour <- shinyRenderDetour({
     set.seed(input$seed)
 
     detour(shared_iris, tour_aes(projection = -Species, colour = Species)) |>

demo/shiny_detourr/click_events.R

@@ -4,14 +4,16 @@ library(detourr)
 ui <- function() {
   fluidPage(
     fluidRow(
-      column(6,
-        displayScatter3dOutput(
+      column(
+        6,
+        detourOutput(
           "detourr_out",
           width = "100%",
           height = "400px"
         )
       ),
-      column(6,
+      column(
+        6,
         h1("Click events through shiny"),
         p(
           "This app demonstrates how to obtain click events through Shiny.",
@@ -26,7 +28,7 @@ ui <- function() {
 }
 
 server <- function(input, output, session) {
-  output$detourr_out <- shinyRenderDisplayScatter2d({
+  output$detourr_out <- shinyRenderDetour({
     detour(
       tourr::flea |>
         dplyr::mutate(id = dplyr::row_number()),
@@ -46,4 +48,4 @@ server <- function(input, output, session) {
   })
 }
 
-shinyApp(ui, server, options = list(port = 5534))
+shinyApp(ui, server, options = list(port = 5534))