CODEWITHSUNDEEP
rshinyhtmlwidgetsnetworkd3
HGupta
HGupta

Reputation: 127

Shiny + networkD3 Mouseover Edges to Display Included Vector

I'm looking to create tooltips that appear on mouseover in networkD3 plots in Shiny. In the example below, I've used twitteR to allow the Shiny app users to generate data from a twitteR search, and I've used graphTweets to create a networkD3 compatible edge list that contains the source screenName, the target screenName, and the text of the tweet. I then pass this edgelist to simpleNetwork.

I've shown in the example below how to bind hyperlinks to twitter accounts to clickAction. I've also added a list in the network graph that contains the text from each tweet associated with each link. Is there R or JS code I can use to display this text on mouseover on each link?

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)

Upvotes: 1

Views: 738

Answers (1)

CJ Yetman
CJ Yetman

Reputation: 8848

This is not officially supported, but you can achieve it by adding some JavaScript with 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)

Upvotes: 2

Related Questions