add Shiny click events

[trafficonese]

This addresses #290

For now a click on a node, creates a Shiny input object with node id and the text content. It would be nice to have some highlighting options too. But I hope this will do as a start.

Here's a test shiny-app:

library(DiagrammeR)
library(shiny)

# Load in a the small repository graph
graph <-
  open_graph(
    system.file(
      "extdata/example_graphs_dgr/repository.dgr",
      package = "DiagrammeR"))

ui <- fluidPage(
  grVizOutput("dg")
  , verbatimTextOutput("print")
  , DiagrammeROutput("dg1")
  , verbatimTextOutput("print1")
)

server <- function(input, output, session) {
  output$dg <- renderGrViz({
    render_graph(graph, layout = "kk")
  })
  output$print <- renderPrint({
    req(input$dg_click)
    print(unlist(input$dg_click))
  })
  
  output$dg1 <- renderDiagrammeR({
    DiagrammeR("graph LR;A(Rounded)-->B[Squared];B-->C{A Decision};
 C-->D[Square One];C-->E[Square Two];
 style A fill:#E5E25F;  style B fill:#87AB51; style C fill:#3C8937;
 style D fill:#23772C;  style E fill:#B6E6E6;"
    )
  })
  output$print1 <- renderPrint({
    req(input$dg1_click)
    print(unlist(input$dg1_click))
  })
}

shinyApp(ui, server)

[codecov]

Codecov Report

Merging #362 into master will not change coverage.
The diff coverage is n/a.

@@           Coverage Diff           @@
##           master     #362   +/-   ##
=======================================
  Coverage   80.69%   80.69%           
=======================================
  Files         244      244           
  Lines       14321    14321           
=======================================
  Hits        11557    11557           
  Misses       2764     2764

---

Continue to review full report at Codecov.

Legend - Click here to learn more
Δ = absolute <relative> (impact), ø = not affected, ? = missing data
Powered by Codecov. Last update 82bb7f9...35200b3. Read the comment docs.

[rich-iannone]

Thank you, this is great!

[ewanwhittakerwalker]

Hello Rich Iannone!
Thanks for writing the Diagrammer library for rShiny it's super useful, however I encountered an issue.

I have a shiny app with multiple clickable graphs however when I use input$dg1_click$nodeValues, or input$dg2_click$nodeValues it returns the clicked values for both in the list. Any way around this? Thanks!

Looks like there could be some problem in the code below checking the widget ID, meaning that the rshiny app cant differentiate between different diagrams clicked nodes.

https://github.com/rich-iannone/DiagrammeR/blob/d2464923c7b409bbbd1e8f67b2694a2d295c1358/inst/htmlwidgets/grViz.js

[ewanwhittakerwalker]

txt_A378 <- reactive({
req(input$diagram_A378_click$nodeValues)
print(unlist(input$diagram_A378_click$nodeValues))
})

output$print_A378 <- renderPrint({
cell_pop_A378 <- txt_A378()
cell_pop_A378 <- str_replace_all(string=cell_pop_A378, pattern=" ", repl="")
cat("You have selected : ", cell_pop_A378)
})

I have this duplicated for multiple graphs but nodeValues always returns the same thing.

[trafficonese]

Could you maybe come up with a small reproducible example?

[ewanwhittakerwalker]

ui <- tabPanel("A358 Memory T-Cell panel",
sidebarPanel(
selectInput("datatype", "select a datatype:",
choices = c("%", "ABS", "MFI"))),
mainPanel(
tabsetPanel(
tabPanel("Data",
grVizOutput('diagram', width = "100%", height = "500px"),
uiOutput("print"))),
tabPanel("A167 Memory T-Cell panel",
sidebarPanel(
selectInput("datatype_A167", "select a datatype:",
choices = c("%", "ABS", "MFI"))),
mainPanel(
tabsetPanel(
tabPanel("Data_A167",
grVizOutput('diagram_A167', width = "100%", height = "500px"),
uiOutput("print_A167")))
))

server <- function(input, output, session) {
output$diagram <- renderGrViz({
grViz("
digraph A {

    node [shape = circle,
          style = filled,
          color = orange,
          label = ''
          fontsize = 20
          overlap='scalexy']
    
    a [label = 'CD3+']
    
    
    b [label = 'CD4+CD8-']
    c [label = 'CD8+CD4-']
    a -> {b c}

txt <- reactive({
req(input$diagram_click$nodeValues[1])
print(unlist(input$diagram_click$nodeValues))

ls_nodes <- unlist(input$diagram_click$nodeValues)
print(ls_nodes[0])

})

output$print <- renderPrint({
cell_pop_A358 <- paste(txt(), collapse = '_')
cell_pop_A358 <- str_replace_all(string=cell_pop_A358, pattern=" ", repl="")
cat("You have selected : ", cell_pop_A358)
})

output$diagram_A167 <- renderGrViz({
grViz("
digraph C {

    node [shape = circle,
          style = filled,
          color = orange,
          label = ''
          fontsize = 20
          overlap='scalexy']
    
    a2 [label = 'Lin-']
    
    
    b2 [label = 'DR+']
    c2 [label = 'DR-/low']   
    
    a2 -> {b2 c2}

txt_A167 <- reactive({
req(input$diagram_A167_click$nodeValues)
ls_nodes <- unlist(input$diagram_A167_click$nodeValues))
print(ls_nodes[0])
})

output$print_A167 <- renderPrint({
cell_pop_A167 <- txt_A167()
cell_pop_A167 <- str_replace_all(string=cell_pop_A167, pattern=" ", repl="")

cat("You have selected : ", cell_pop_A167)

})
})

#########################################

When i click the top node of diagram i get this from print:
[1] "CD3+" You have selected : CD3+
Then i click the next tab Data_A167 and click the top node i get:
[1] "CD3+" "Lin-" You have selected : CD3+_Lin-
Interestingly, when i refresh the page on Data_A167 and click the top node i get the correct output:
[1] "Lin-" You have selected : Lin-

[stevepowell99]

this is great, am I correct in thinking this only works for nodes, not edges?

[trafficonese]

yes exactly, it only works for the nodes currently.

[akshaytuptewar19]

I am trying to update name of node label which I have selected but its not working
is their any way to do it?
library(shiny)
library(DiagrammeR)

ui <- fluidPage(
grVizOutput("dg"),
textInput("node_label", "Enter new label"),
actionButton("update_label", "Update label"),
verbatimTextOutput("print")
)

server <- function(input, output, session) {
node_labels <- reactiveVal(list(a = "Start", b = "Step 1", c = "Step 2", d = "Step 3", e = "Step 4", f = "Step 5", g = "Step 6", h = "Step 7", i = "Step 8", j = "Step 9"))

output$dg <- renderGrViz({
grViz(paste0("
digraph a_nice_graph {
# node definitions with substituted label text
node [fontname = Helvetica]
a [label = '", node_labels()$a, "']
b [label = '", node_labels()$b, "']
c [label = '", node_labels()$c, "']
d [label = '", node_labels()$d, "']
e [label = '", node_labels()$e, "']
f [label = '", node_labels()$f, "']
g [label = '", node_labels()$g, "']
h [label = '", node_labels()$h, "']
i [label = '", node_labels()$i, "']
j [label = '", node_labels()$j, "']
# edge definitions with the node IDs
a -> {b c d e f g h i j}
}
"))
})

observeEvent(input$update_label, {
if (!is.null(input$dg_click)) {
node_val <- input$dg_click$nodeValues[[1]]
new_val <- input$node_label
node_labels(node_labels() %>% {.[[node_val]] <- new_val; .})
}
})

txt <- reactive({
req(input$dg_click)
nodeval <- input$dg_click$nodeValues[[1]]
return(paste(nodeval, " is clicked"))
})

output$print <- renderPrint({
txt()
})
}

shinyApp(ui, server)

[trafficonese]

@akshaytuptewar19
Maybe its easier with a reactiveValues list.
The following example works:

Example

library(shiny)
library(DiagrammeR)
ui <- fluidPage(
  grVizOutput("dg"),
  textInput("node_label", "Enter new label"),
  actionButton("update_label", "Update label"),
  verbatimTextOutput("print")
)
server <- function(input, output, session) {
  node_labels <- reactiveValues(a = "Start", b = "Step 1", c = "Step 2", d = "Step 3", 
                                  e = "Step 4", f = "Step 5", g = "Step 6", h = "Step 7", 
                                  i = "Step 8", j = "Step 9")
  output$dg <- renderGrViz({
    grViz(paste0("
      digraph a_nice_graph {
      # node definitions with substituted label text
      node [fontname = Helvetica]
      a [label = '", node_labels$a, "']
      b [label = '", node_labels$b, "']
      c [label = '", node_labels$c, "']
      d [label = '", node_labels$d, "']
      e [label = '", node_labels$e, "']
      f [label = '", node_labels$f, "']
      g [label = '", node_labels$g, "']
      h [label = '", node_labels$h, "']
      i [label = '", node_labels$i, "']
      j [label = '", node_labels$j, "']
      # edge definitions with the node IDs
      a -> {b c d e f g h i j}
      }
      "))
  })
  observeEvent(input$update_label, {
    if (!is.null(input$dg_click)) {
      node_val <- input$dg_click$nodeValues[[1]]
      new_val <- input$node_label
      rvli <- reactiveValuesToList(node_labels)
      name <- names(rvli[rvli %in% node_val])
      which <- which(rvli %in% node_val) 
      node_labels[[name]] <- new_val
    }
  })
  txt <- reactive({
    req(input$dg_click)
    nodeval <- input$dg_click$nodeValues[[1]]
    return(paste(nodeval, " is clicked"))
  })
  output$print <- renderPrint({
    txt()
  })
}
shinyApp(ui, server)

[akshaytuptewar19]

i am creating separate input box for changing node label name can we update node name by clicking on it only without creating input box separately?