Aktualisieren mehrerer Infobox mit plotly_click in R und plotly

Question

Wenn Sie bitte das Skript ausführen, gibt es Ihnen eine grundlegende Sankey-Diagramm in R und Plotly und eine Datentabelle neben. Außerdem befinden sich oben drei InfoBoxen. Wenn ich auf die Sankey-Linien im Plot klicke, sehe ich den Wert in der Datentabelle mit plotly_click. Ich möchte eine Funktionalität, wenn ich auf eine Sankey-Linie klicke, sie wählt "pointNumber" Column-Wert in der Datentabelle aus und multipliziert mit 2 in der ersten Infobox, 3 in der zweiten Infobox und multipliziert mit 4 in der dritten Infobox snap befestigt. Danke und bitte helfen Sie.

## app.R ## 
library(shiny) 
library(shinydashboard) 
library(devtools) 
library(ggplot2) 
library(plotly) 
library(proto) 
library(RColorBrewer) 
library(gapminder) 
library(stringr) 
library(broom) 
library(mnormt) 
library(DT) 

ui <- dashboardPage(
dashboardHeader(title = "Multiple hover"), 
dashboardSidebar(
width = 0 
), 
dashboardBody(

infoBox("Multiply by 2", 2 * 2, icon = icon("credit-card")), 
infoBox("Multiply by 3", 2 * 3, icon = icon("credit-card")), 
infoBox("Multiply by 4", 2 * 4, icon = icon("credit-card")), 
tags$br(), 

box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader = 
T, 
plotlyOutput("sankey_plot")), 

box(title = "Case Summary", status = "primary", height = "455",solidHeader 
= T, 
    dataTableOutput("sankey_table")) 
) 
) 
server <- function(input, output) 
{ 
output$sankey_plot <- renderPlotly({ 
trace1 <- list(
    domain = list(
    x = c(0, 1), 
    y = c(0, 1) 
), 
    link = list(
    label = c("Case1", "Case2", "Case3", "Case4", "Case5", "Case6", 
    "Case7"), 
    source = c(0, 1, 2, 3, 4, 5, 6, 7), 
    target = c(11, 12, 7, 10, 13, 9, 8), 
    value = c(5, 6, 2, 4, 10, 6, 2) 
), 
    node = list(label = c("R1", "R2", "R3","R4","R5","R6","R7","Blood 
    Test","Check Out","Discuss Results", 
         "MRI Scan", "Registration", "Triage and Assessment", 
    "X-RAY")), 
    type = "sankey" 
) 
    data <- list(trace1) 
    p <- plot_ly() 
    p <- add_trace(p, domain=trace1$domain, link=trace1$link, 
    node=trace1$node, type=trace1$type) 
    p 
    }) 
    output$sankey_table <- renderDataTable({ 
    d <- event_data("plotly_click") 
    if(is.null(d)) 
    { 
    print("Hello, Please hover to see the result") 
    } else 
    d 
    }) 
    } 
    shinyApp(ui, server) 

Answer 1

event_data() Betrachtet man gibt einen Datenrahmen, der unten Codezugriffs dass bestimmten Wert pointNumber und dynamische UI macht.

Code:

## app.R ## 
library(shiny) 
library(shinydashboard) 
library(devtools) 
library(ggplot2) 
library(plotly) 
library(proto) 
library(RColorBrewer) 
library(gapminder) 
library(stringr) 
library(broom) 
library(mnormt) 
library(DT) 

ui <- dashboardPage(
    dashboardHeader(title = "Multiple hover"), 
    dashboardSidebar(
    width = 0 
), 
    dashboardBody(

    uiOutput('box1'), 
    tags$br(), 

    box(title = "Sankey Chart", status = "primary",height = "455" ,solidHeader = 
      T, 
     plotlyOutput("sankey_plot")), 

    box(title = "Case Summary", status = "primary", height = "455",solidHeader 
     = T, 
     dataTableOutput("sankey_table")) 
) 
) 
server <- function(input, output) 
{ 
    output$sankey_plot <- renderPlotly({ 
    trace1 <- list(
     domain = list(
     x = c(0, 1), 
     y = c(0, 1) 
    ), 
     link = list(
     label = c("Case1", "Case2", "Case3", "Case4", "Case5", "Case6", 
        "Case7"), 
     source = c(0, 1, 2, 3, 4, 5, 6, 7), 
     target = c(11, 12, 7, 10, 13, 9, 8), 
     value = c(5, 6, 2, 4, 10, 6, 2) 
    ), 
     node = list(label = c("R1", "R2", "R3","R4","R5","R6","R7","Blood 
          Test","Check Out","Discuss Results", 
          "MRI Scan", "Registration", "Triage and Assessment", 
          "X-RAY")), 
     type = "sankey" 
    ) 
    data <- list(trace1) 
    p <- plot_ly() 
    p <- add_trace(p, domain=trace1$domain, link=trace1$link, 
        node=trace1$node, type=trace1$type) 
    p 
    }) 
    output$sankey_table <- renderDataTable({ 
    d <- event_data("plotly_click") 
    if(is.null(d)) 
    { 
     print("Hello, Please hover to see the result") 
    } else 
     d 
    }) 

    output$box1 <- renderUI({ 
    tagList(

    infoBox("Multiply by 2", event_data("plotly_click")$pointNumber * 2, icon = icon("credit-card")), 
    infoBox("Multiply by 3", event_data("plotly_click")$pointNumber * 3, icon = icon("credit-card")), 
    infoBox("Multiply by 4", event_data("plotly_click")$pointNumber * 4, icon = icon("credit-card")) 
    ) 


    }) 

} 
shinyApp(ui, server) 

Screenshot: