Question

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

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

我的目标是使用数据将工具提示添加到Shiny中forceNetwork图中的链接，这些数据将存储在通过JavaScript传递给ui的R变量中。我的应用程序应该接受2个CSV文件（一个带有节点数据，一个带有链接数据），然后在forceNetwork中用链接的工具提示绘制它。当forceNetwork生成forceNetwork对象时，我需要检索从节点剥离的工具提示列并链接数据。除工具提示功能外，一切正常。是什么让我感到困惑，是

如何将带有工具提示信息的子集化数据传递给ui而不会在服务器中暴露出无效值时出错，
如何使用该数据和javascript为forceNetwork链接制作工具提示。

如果这不是一个反应图，我只需在创建它后将工具提示列附加到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"))

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

＆＃13;

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)

＆＃13;

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

＆＃13;

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)

＆＃13;

（附注：所以人们更容易帮助你，所以这对其他阅读它的人有用，我强烈建议你极小（这意味着你在尽可能多地展示问题时尽可能多地删除不必要的代码，可重现（意味着你包含了示例数据以及运行代码所需的任何其他内容）示例。See here for a good explanation of that.）

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

1 个答案: