使用OnInputChange和AddCustommessageHandler将数据传递给Forcenetwork

我正在尝试使用Shiny's onInputChange和addCustomMessageHandler功能使用JavaScript将服务器从服务器发送到客户端：

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

我的目标是使用将通过JavaScript传递给UI的R变量中的数据将工具提示添加到forcenetwork图中的链接中。我的应用程序应该接受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)

如果有人可以将我指向正确的方向，我将非常感谢。

将这两行添加到您的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)

（旁注：这样人们就更容易帮助您，因此，这对阅读它的其他人很有用，我强烈建议您制作 minimal （这意味着您剪切了在仍在说明问题的同时，尽可能多的不必要的代码），可重复可（这意味着您包含示例数据以及运行代码的其他所有内容）示例。请参阅此处的很好的解释。）

相关内容

最新更新

热门标签：