javascript - 使用 onInputChange 和 addCustomMessageHandler 将数据传递给forceNetwork

Question

我正在尝试使用此处描述的 Shiny 的 onInputChange 和 addCustomMessageHandler 功能，使用 JavaScript 将 R 数据从服务器发送到客户端:

https://ryouready.wordpress.com/2013/11/20/sending-data-from-client-to-server-and-back-using-shiny/

我的目标是使用将存储在通过 JavaScript 传递到 ui 的 R 变量中的数据，将工具提示添加到 Shiny 中的 ForceNetwork 图表中的链接。我的应用程序应该接受 2 个 CSV 文件(一个包含节点数据，一个包含链接数据)，然后将其绘制在带有链接工具提示的 ForceNetwork 中。当forceNetwork创建forceNetwork对象时，我需要检索从节点和链接数据中剥离的工具提示列。除了工具提示功能之外，一切正常。让我难受的是

• 如何将仅包含工具提示信息的子集数据传递到 UI，而不会因在服务器中公开 react 值而出现错误，以及
• 如何使用该数据和 JavaScript 为 ForceNetwork 链接制作工具提示。

如果这不是 react 图，我只需在创建它后将工具提示列附加到 fn forceNetwork 对象。然而，这似乎并没有出现在图表中。我正在考虑将工具提示数据传递到 ui 中的标签，然后将其指定为显示为链接的工具提示。

代码如下:

library(shiny)
library(networkD3)

server <- function(input, output, session) {

  # User uploads CSV for nodes (file has name, group, tooltip columns)
  mydata_n <- reactive({
    req(input$file_n) 

    inFile <- input$file_n 
    df <- read.csv(inFile$datapath)
    return(df)
  })

# User uploads CSV for links (file has source, target, value, tooltip columns)
  mydata_l <- reactive({
    req(input$file_l) 

    inFile <- input$file_l
    df <- read.csv(inFile$datapath)

    # The source and target columns have names rather than zero-indexed row numbers as forceNetwork requires, so fix them using nodes file as reference
    df$source <- match(df$source, mydata_n()$name)
    df$target <- match(df$target, mydata_n()$name)
    df[1:2] <- df[1:2]-1
    return(df)
  })

  # Render tables showing content of uploaded files 

  output$table_n <- renderTable({
    mydata_n()
  })

  output$table_l <- renderTable({
    mydata_l()
  })

  # make network with data

  output$net <- renderForceNetwork({
    fn <- forceNetwork(
      Links = mydata_l(), Nodes = mydata_n(), Source = "source",
      Target = "target", Value = "value", NodeID = "name",
      Group = "group", opacity = 1, zoom = FALSE, bounded = F, linkWidth = 1, linkColour = "#939393", charge = -80
    ) 
  }

    )

 # This part is broken. When a links file is uploaded, subset it to make a linkTooltips df with just tooltip data and pass it to the browser using myCallbackHandler
  observe({
    input$file_l
    linkTooltips <- mydata_l()["tooltip"]
    session$sendCustomMessage(type = "myCallbackHandler", linkTooltips)
  })

    # Show table output

}

ui <- fluidPage(

  # This is where the linkTooltips data should be assigned to display as a tooltip, but I'm not sure how to access that R variable in javascript and assign each tooltip to the appropriate link. My start (based on an answer to a previous question) is below.
  tags$head( tags$script('Shiny.addCustomMessageHandler("myCallbackHandler",
                         function(linkTooltips) {
                        d3.selectAll(".link")
                        .attr("title", "linkTooltips");
                         });
                         ')
  ),

  titlePanel("ForceNetD3"),
  mainPanel(forceNetworkOutput("net"), 

            # start input
            fluidRow(column( 12, wellPanel( h3("Upload a file"),
          fileInput('file_n', 'Choose CSV File for Nodes', accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv')),
          fileInput('file_l', 'Choose CSV File for Links', accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))

            )

            )),

            fluidRow( 
              tabsetPanel(
                tabPanel( "Nodes Data", tableOutput(outputId = "table_n")), 
                tabPanel( "Links Data", tableOutput(outputId = "table_l"))
            )

            # end input

            ))
  )



shinyApp(ui = ui, server = server)

如果有人能指出我正确的方向，我将非常感激。

Answer 1

将这两行添加到 renderForceNetwork 函数中的代码中...

fn$x$links$tooltip <- mydata_l()$tooltip
htmlwidgets::onRender(fn, 'function(el, x) { d3.selectAll(".link").append("svg:title").text(function(d) { return d.tooltip; }); }')

这样，您的 SVG 线条/边缘将具有标题，当您将鼠标悬停在它们上方时，这些标题将显示为工具提示(并且 addCustomMessageHandler 等中的所有其他内容都是不必要的)。

我预测，你接下来会问如何集成tipsy.js？将此添加到您的 renderForceNetwork 函数中的代码中(而不是上面的代码)...

fn$x$links$tooltip <- mydata_l()$tooltip
fn$x$nodes$tooltip <- mydata_n()$tooltip
htmlwidgets::onRender(fn, 'function(el, x) {
    d3.selectAll(".node circle, .link")
        .attr("title", function(d) { return d.tooltip; });
    tippy("[title]");
}')

然后确保您的 fluidPage 命令包含...

tags$head(tags$script(src = "https://unpkg.com/tippy.js@2.0.2/dist/tippy.all.min.js"))

这是一个完整的工作示例...

library(shiny)
library(networkD3)
library(htmlwidgets)

server <- function(input, output, session) {
  
  # User uploads CSV for nodes (file has name, group, tooltip columns)
  mydata_n <- reactive({
req(input$file_n) 

inFile <- input$file_n 
df <- read.csv(inFile$datapath)
return(df)
  })
  
  # User uploads CSV for links (file has source, target, value, tooltip columns)
  mydata_l <- reactive({
req(input$file_l) 

inFile <- input$file_l
df <- read.csv(inFile$datapath)

# The source and target columns have names rather than zero-indexed row numbers as forceNetwork requires, so fix them using nodes file as reference
df$source <- match(df$source, mydata_n()$name)
df$target <- match(df$target, mydata_n()$name)
df[1:2] <- df[1:2]-1
return(df)
  })
  
  # Render tables showing content of uploaded files 
  
  output$table_n <- renderTable({
mydata_n()
  })
  
  output$table_l <- renderTable({
mydata_l()
  })
  
  # make network with data
  
  output$net <- renderForceNetwork({
fn <- forceNetwork(
  Links = mydata_l(), Nodes = mydata_n(), Source = "source",
  Target = "target", Value = "value", NodeID = "name",
  Group = "group", opacity = 1, zoom = FALSE, bounded = F, linkWidth = 1, linkColour = "#939393", charge = -80
) 
fn$x$links$tooltip <- mydata_l()$tooltip
fn$x$nodes$tooltip <- mydata_n()$tooltip
htmlwidgets::onRender(fn, 'function(el, x) {
         d3.selectAll(".node circle, .link")
         .attr("title", function(d) { return d.tooltip; });
         tippy("[title]");
}'
)
  }
  )
  
}

ui <- fluidPage(
  tags$head(tags$script(src = "https://unpkg.com/tippy.js@2.0.2/dist/tippy.all.min.js")),
  titlePanel("ForceNetD3"),
  mainPanel(forceNetworkOutput("net"), 
        
        # start input
        fluidRow(column( 12, wellPanel( h3("Upload a file"),
                                        fileInput('file_n', 'Choose CSV File for Nodes', accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv')),
                                        fileInput('file_l', 'Choose CSV File for Links', accept=c('text/csv', 'text/comma-separated-values,text/plain', '.csv'))
                                        
        )
        
        )),
        
        fluidRow( 
          tabsetPanel(
            tabPanel( "Nodes Data", tableOutput(outputId = "table_n")), 
            tabPanel( "Links Data", tableOutput(outputId = "table_l"))
          )
          
          # end input
          
        ))
  )



shinyApp(ui = ui, server = server)

这里有一些 R 代码，用于生成 nodes.csv 和 links.csv 来测试它...

links <- read.csv(header = T, text ="
source,target,value,tooltip
first,second,1,link1
first,third,1,link2
second,third,1,link3
third,fourth,1,link4
")
write.csv(links, "links.csv", row.names = F)

nodes <- read.csv(header = T, text ="
name,group,tooltip
first,1,node1
second,1,node2
third,1,node3
fourth,1,node4
")
write.csv(nodes, "nodes.csv", row.names = F)

<小时/>

(旁注:为了让人们更容易帮助您，并且这对其他阅读它的人有用，我强烈鼓励您最小化(这意味着您削减了尽可能多地删除不必要的代码，同时仍然演示问题)，可重现(意味着您包含示例数据和运行代码所需的任何其他内容)示例。See here for a good explanation of that. )