Search box in network Plot

Question

I have created a Network of protein mutations using the forceNetwork() function of the networkD3 package. It get's rendered on the RStudio's "Viewer" pane.

I can then save this as an HTML file, for sharing, with the dynamic nature (like clicking nodes, highlighting connections etc) preserved.

A png version of my network plot looks like below:

This is a representation of a top 20% in my original data, and the complete data looks even more huge and complex.

I need to be able to add a search to this forceNetwork, so that then specific nodes can be located in a complex network. The javascript or jquery part of this can be easily achieved by editing the copy of package networkD3 and repackaging. But my main challenge is adding the html code for including a search box.

My main R code looks like this:

library(networkD3)
library(XLConnect)

wb <- loadWorkbook("input.xlsx")
nodes <- readWorksheet(wb, sheet="Node", startRow = 1, startCol = 1, header = TRUE)
links <- readWorksheet(wb, sheet="Edges", startRow = 1, startCol = 1, header = TRUE)


fn <- forceNetwork(Links = links, Nodes = nodes,
                   Source = "Source", Target = "ID", Value = "Combo",
                   NodeID = "Mutation", linkDistance = JS('function(d){return d.value * 50;}'), 
                   Nodesize = "IF", Group = "Combo", radiusCalculation = JS("d.nodesize+6"),
                   zoom = T, bounded = F, legend = T, 
                   opacity = 0.8,
                   fontSize = 16 )

fn

My inspiration has come from the jsfiddle by Simon Raper. What would be the best way to include a search in this situation? The option I have thought of is to first save the rendering as an html. Then read and edit the html and insert the piece of code for the search. I tried to use Rhtml for this, but it doesn't seem trivial. Any pointers would be greatly appreciated.

Answer 1

Although I'm not crazy about this interactivity, I thought it would be a good opportunity for demonstrating how to use htmltools with htmlwidgets. Later, I will recreate with crosstalk, but for now, here is how I would replicate the example provided.

direct replication

library(htmltools)
library(networkD3)

data(MisLinks)
data(MisNodes)

# make a forceNetwork as shown in ?forceNetwork
fn <- forceNetwork(
  Links = MisLinks, Nodes = MisNodes, Source = "source",
  Target = "target", Value = "value", NodeID = "name",
  Group = "group", opacity = 0.4, zoom = TRUE
)

fn <- htmlwidgets::onRender(
  fn,
  '
function(el,x){
debugger;
  var optArray = [];
  for (var i = 0; i < x.nodes.name.length - 1; i++) {
    optArray.push(x.nodes.name[i]);
  }

  optArray = optArray.sort();

  $(function () {
    $("#search").autocomplete({
      source: optArray
    });
  });

  d3.select(".ui-widget button").node().onclick=searchNode;

  function searchNode() {
    debugger;
    //find the node

    var selectedVal = document.getElementById("search").value;
    var svg = d3.select(el).select("svg");
    var node = d3.select(el).selectAll(".node");

    if (selectedVal == "none") {
      node.style("stroke", "white").style("stroke-width", "1");
    } else {
      var selected = node.filter(function (d, i) {
        return d.name != selectedVal;
      });
      selected.style("opacity", "0");
      var link = svg.selectAll(".link")
      link.style("opacity", "0");
      d3.selectAll(".node, .link").transition()
        .duration(5000)
        .style("opacity", 1);
    }
  }
}  
  '
)

browsable(
  attachDependencies(
    tagList(
      tags$head(
        tags$link(
          href="http://code.jquery.com/ui/1.11.0/themes/smoothness/jquery-ui.css",
          rel="stylesheet"
        )
      ),
      HTML(
  '
  <div class="ui-widget">
      <input id="search">
      <button type="button">Search</button>
  </div>
  '     
      ),
      fn
    ),
    list(
      rmarkdown::html_dependency_jquery(),
      rmarkdown::html_dependency_jqueryui()
    )
  )
)

crosstalk version

note: crosstalk is experimental, so this might change

I did not spend time to optimize and perfect, but here is a version that sort-of does the same thing as the example but using crosstalk instead of custom code and a jquery-ui autocomplete.

library(htmltools)
library(networkD3)


# demonstrate with experimental crosstalk
#  this will get much easier once we start converting
#  htmlwidgets to work natively with crosstalk

#devtoools::install_github("rstudio/crosstalk")
library(crosstalk)

data(MisLinks)
data(MisNodes)

# make a forceNetwork as shown in ?forceNetwork
fn <- forceNetwork(
  Links = MisLinks, Nodes = MisNodes, Source = "source",
  Target = "target", Value = "value", NodeID = "name",
  Group = "group", opacity = 0.4, zoom = TRUE
)

sd <- SharedData$new(MisNodes, key=~name, group="grp1" )

# no autocomplete so not the same
#  but will use this instead of writing something new
fs <- filter_select(
  id = "filter-node",
  label = "Search Nodes",
  sharedData = sd,
  group = ~name
)

fn <- htmlwidgets::onRender(
  fn,
'
function(el,x){
  // get the crosstalk group
  //  we used grp1 in the SharedData from R
  var ct_grp = crosstalk.group("grp1");
debugger;
  ct_grp
    .var("filter")
    .on("change", function(val){searchNode(val.value)});

  function searchNode(filter_nodes) {
    debugger;
    //find the node
    var selectedVal = filter_nodes? filter_nodes : [];
    var svg = d3.select(el).select("svg");
    var node = d3.select(el).selectAll(".node");

    if (selectedVal.length===0) {
      node.style("opacity", "1");
      svg.selectAll(".link").style("opacity","1");
    } else {
      var selected = node.filter(function (d, i) {
        return selectedVal.indexOf(d.name) >= 0;
      });
      node.style("opacity","0");
      selected.style("opacity", "1");
      var link = svg.selectAll(".link").style("opacity", "0");
      /*
      svg.selectAll(".node, .link").transition()
        .duration(5000)
        .style("opacity", 1);
      */
    }
  }
}  
'
)

browsable(
  tagList(
    fs,
    fn
  )
)