rshinyzoomingpan

How to add controls in pan&zoom functionality in shiny app?


I have used panzoom package in order to pan and zoom on my svg file in my shiny app. Is there a way to have controls like this?

library(shiny)
library(DiagrammeR)
library(magrittr)

ui <- fluidPage(
  tags$head(
    tags$script(src = "https://unpkg.com/panzoom@9.4.0/dist/panzoom.min.js")
  ),

  grVizOutput("grr", width = "100%", height = "90vh"),

  tags$script(
    HTML('panzoom($("#grr")[0])')
  )
)

server <- function(input, output) {

  reactives <- reactiveValues()

  observe({
    reactives$graph <- render_graph(create_graph() %>%
                                      add_n_nodes(n = 2) %>%
                                      add_edge(
                                        from = 1,
                                        to = 2,
                                        edge_data = edge_data(
                                          value = 4.3)))
  })

  output$grr <- renderGrViz(reactives$graph)

}

shinyApp(ui, server)

Solution

  • Here is a way, but if you click too quickly on the +/- buttons, there's an undesirable effect.

    library(shiny)
    library(shinyWidgets)
    library(DiagrammeR)
    library(magrittr)
    
    js <- '
    $(document).ready(function(){
      var element = document.getElementById("grr");
      var instance = panzoom(element);
      $("#zoomout").on("click", function(){
        instance.smoothZoom(0, 0, 0.9);
      });
      $("#zoomin").on("click", function(){
        instance.smoothZoom(0, 0, 1.1);
      });
    });
    '
    
    ui <- fluidPage(
      tags$head(
        tags$script(src = "https://unpkg.com/panzoom@9.4.0/dist/panzoom.min.js"),
        tags$script(HTML(js))
      ),
    
      grVizOutput("grr", width = "100%", height = "90vh"),
    
      actionGroupButtons(
        inputIds = c("zoomout", "zoomin"),
        labels = list(icon("minus"), icon("plus")),
        status = "primary"
      )
    
    )
    
    server <- function(input, output) {
    
      reactives <- reactiveValues()
    
      observe({
        reactives$graph <- render_graph(
          create_graph() %>%
            add_n_nodes(n = 2) %>%
            add_edge(
              from = 1,
              to = 2,
              edge_data = edge_data(
                value = 4.3
              )
            )
          )
      })
    
      output$grr <- renderGrViz(reactives$graph)
    
    }
    
    shinyApp(ui, server)
    

    EDIT

    Add this JavaScript to prevent the undesirable effect:

      $("#zoomout").on("dblclick", function(){
        return false;
      });
      $("#zoomin").on("dblclick", function(){
        return false;
      });