Передача данных в forceNetwork с помощью onInputChange и addCustomMessageHandler

Question

Я пытаюсь отправить данные R с сервера на клиент, используя JavaScript с помощью Shiny's onInputChange а также addCustomMessageHandler функциональность описана здесь:

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

Моя цель - добавить всплывающие подсказки к ссылкам на диаграмме forceNetwork в Shiny, используя данные, которые будут храниться в переменной R, передаваемой пользовательскому интерфейсу через JavaScript. Мое приложение должно принять 2 CSV-файла (один с данными узлов, другой с данными ссылок), а затем отобразить его в forceNetwork с подсказками для ссылок. Мне нужно будет извлечь столбец всплывающей подсказки, извлеченный из узлов, и связать данные, когда forceNetwork создает объект forceNetwork. Все работает отлично, за исключением функциональности всплывающей подсказки. Что меня озадачивает, так это

• как передать подмножество данных с помощью только информации всплывающей подсказки в пользовательский интерфейс, не получая ошибки для выставления реактивного значения на сервере, и
• как использовать эти данные и JavaScript для создания всплывающих подсказок для ссылок forceNetwork.

Если бы это был не реактивный график, я бы просто добавил столбец всплывающей подсказки к fn Объект forceNetwork после его создания. Однако, это, кажется, не делает это в граф. Вместо этого я рассматриваю передачу данных всплывающей подсказки тегу в пользовательском интерфейсе, а затем назначаю его для отображения в качестве всплывающей подсказки для ссылок.

Вот код:

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)

---

(Примечание: чтобы людям было легче помогать, и чтобы это могло быть полезно для других людей, которые его читают, я настоятельно рекомендую вам сделать минимальное количество (то есть вы вырезали как можно больше ненужного кода, пока демонстрируете проблема), воспроизводимые (это означает, что вы включаете примеры данных и все остальное, что нужно для запуска вашего кода) примеры. Смотрите здесь для хорошего объяснения этого.)