1

networkD3我正在寻找在 Shiny的图中创建鼠标悬停时出现的工具提示。在下面的示例中，我曾经twitteR允许 Shiny 应用程序用户从twitteR搜索中生成数据，并且我曾经graphTweets创建一个networkD3兼容的边缘列表，其中包含源屏幕名称、目标屏幕名称和推文的文本。然后我将此边缘列表传递给simpleNetwork.

我在下面的示例中展示了如何将 twitter 帐户的超链接绑定到clickAction. 我还在网络图中添加了一个列表，其中包含与每个链接关联的每条推文的文本。是否有 R 或 JS 代码可用于在每个链接的鼠标悬停时显示此文本？

library(shiny)
library(networkD3)
library(twitteR)
library(graphTweets)
library(dplyr)

ui <- shinyUI(fluidPage(sidebarLayout(
  sidebarPanel(
    textInput("searchkw", "Search:"),
    actionButton("btn", "Click to Generate")
  ),
  mainPanel(simpleNetworkOutput("network"))
)))

server <- shinyServer(function(input, output) {
  #Set up twitteR OAuth
  consumer_key <- xxxxxxxxxxxxxxxxxxxxxxxxx
  consumer_secret <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  access_token <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  access_secret <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  setup_twitter_oauth(consumer_key, consumer_secret, access_token, access_secret)

  edges <- eventReactive(input$btn, {
    #search twitter, convert to dataframe, and get edges with text vector
    tw.edges <- twListToDF(searchTwitter(input$searchkw)) %>%
     getEdges(tweets = "text", source = "screenName", str.length = NULL, "text")
    tw.edges$text <- sapply(tw.edges$text, function(row) iconv(row, "latin1", "ASCII", sub = "")) #convert text to useable format
    return(tw.edges)
  })

  output$network <- renderSimpleNetwork({
    sn <- simpleNetwork(edges()) #Create simplenetwork graph
    sn$x$nodes$link <- paste0('https://twitter.com/', sn$x$nodes$name) #Add links to twitter accounts to nodes
    sn$x$options$clickAction = 'window.open(d.link)' #Bind node clicks to links
    sn$x$links$text <- edges()$text #Add text as links property
    #How to bind to mouse over/out??#
    return(sn)
  })
})

shinyApp(ui = ui, server = server)
4

1 回答 1

2

这不是官方支持的，但您可以通过添加一些 JavaScript 来实现它htmlwidgets::onRender...

library(shiny)
library(networkD3)
library(twitteR)
library(graphTweets)
library(dplyr)

ui <- shinyUI(fluidPage(sidebarLayout(
  sidebarPanel(
    textInput("searchkw", "Search:"),
    actionButton("btn", "Click to Generate")
  ),
  mainPanel(simpleNetworkOutput("network"))
)))

server <- shinyServer(function(input, output) {
  #Set up twitteR OAuth
  consumer_key <- xxxxxxxxxxxxxxxxxxxxxxxxx
  consumer_secret <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  access_token <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  access_secret <- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
  setup_twitter_oauth(consumer_key, consumer_secret, access_token, access_secret)

  edges <- eventReactive(input$btn, {
    #search twitter, convert to dataframe, and get edges with text vector
    tw.edges <- twListToDF(searchTwitter(input$searchkw)) %>%
      getEdges(tweets = "text", source = "screenName", str.length = NULL, "text")
    tw.edges$text <- sapply(tw.edges$text, function(row) iconv(row, "latin1", "ASCII", sub = "")) #convert text to useable format
    return(tw.edges)
  })

  output$network <- renderSimpleNetwork({
    sn <- simpleNetwork(edges()) #Create simplenetwork graph
    sn$x$nodes$link <- paste0('https://twitter.com/', sn$x$nodes$name) #Add links to twitter accounts to nodes
    sn$x$options$clickAction = 'window.open(d.link)' #Bind node clicks to links
    sn$x$links$text <- edges()$text #Add text as links property

    # add onRender JavaScript to set the title to the value of 'text' for each link
    sn <- htmlwidgets::onRender(
      sn,
      '
      function(el, x) {
      d3.selectAll(".link")
        .append("title")
        .text(function(d) { return d.text; });
      }
      '
    )

    return(sn)
  })
})

shinyApp(ui = ui, server = server)
于 2017-09-06T15:18:41.263 回答