D3.js forcegraph in Shiny

Question

I am trying to draw a network graph / forcegraph. I already tried VisNetwork package in R, but I am not very happy neither with the design, nor with the functionalities of the package. From what I saw, r2d3 package allows way more freedom with different features.

I could successefully write a .js script and read it into my Shiny dashboard. Though I'm a newby to JS, and it could be the issue rather with that than with Shiny!

My issue is that I cannot use the input sliders (or any input functions) so easily like on a usual plot. For the forcegraph my data has NODES and EDGES, and I'm struggling whether I need observeEvent, reactiveEvent or smth else, and how exactly to use it... It seems like when calling "data" as toJSON(data) from an complete JSON file is successefull, but when binding it after filtering together again is not...

Any help with experienced D3+Shiny users is appreciated!

This is what I came with so far:

library(shiny)
library(shinydashboard)
library(readxl)
library(dplyr)
library(shinyjs)
library(shinythemes)
library(tidyr)
library(r2d3)
library(jsonlite)

### Nodes as df
nodes <- structure(list(id = c("i01", "i02", "i03", "s01", "s02", "s03", "s04", "s05", "s06", "s07", "s08", "s09", "s10"), 
                        project = c("hub node 1", "hub node 2", "hub node 3", "project 1", "project 2", "project 3", "project 4", "project 5", "project 6", "project 7", "project 8", "project 9", "project 10"), 
                        is_hub = c("TRUE", "TRUE", "TRUE", "NA", "NA", "NA", "NA", "NA", "NA", "NA", "NA","NA","NA"),
                        category = c(NA, NA, NA, "category Y", "category Y", "category X", "category Z", "category Y", "category X", "category Z", "category Y", "category Z", "category Y"), 
                        type = c("NA","NA", "NA", "type C", "type B", "type B", "type A", "type C", "type C", "type A", "type B", "type B", "type A"), 
                        description = c(NA, NA, NA, "asdf", "qwerty", "abcd", "yxcv", "poiu", "vbnm", "ghjkl", "abcd", "tzuio", "lkjhg"), 
                        runtime_start = c(NA, NA, NA, "01.01.2002", "01.01.2005", "15.07.2001", "2020", "15.12.2007", "01.07.2012", 
                                          "01.01.2014", "01.01.2021", "01.01.2019", "01.01.2007"), 
                        runtime_start_year = c("NA", "NA", "NA", "2002", "2005", "2001", "2020", "2007", "2012", "2014", "2021", "2019", "2007"), 
                        runtime_end = c(NA, NA, NA, "31.12.2004", "01.01.2011", "20.10.2001", "2021", "15.12.2009", "31.06.2013", "31.12.2020", "31.12.2023", "31.12.2021", "31.12.2018"), 
                        runtime_end_year = c(NA, NA, NA, "2004", "2011", "2001", "2021", "2009", "2013", "2020", "2023", "2021", "2018")), 
                   class = "data.frame", 
                   row.names = c(NA, 13L))

### Links as df
links <- structure(list(source= c("i01", "i02", "i03", "s01", "s02", "s03", "s03", "s04", "s04", "s05", "s06", "s07", "s07", "s07", "s08", "s09", "s09", "s10"), 
                        project = c("hub node 1", "hub node 2", "hub node 3", "project 1", "project 2", "project 3", "project 3", "project 4", "project 4", "project 5", "project 6", "project 7", "project 7", "project 7", "project 8", "project 9", 
                                    "project 9", "project 10"), 
                        target= c("i01", "i02", "i03", "i01", "i01", "i03", "i02", "i02", "i01", "i01", "i03", "i01", "i02", "i03", "i01", "i01", "i03", "i02"), 
                        value = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), 
                        start = c("NA", "NA", "NA", "2002", "2005", "2001", "2001", "2020", "2020", "2007", "2012", "2014", "2014", "2014", "2021", "2019", "2019", "2018"), 
                        end = c("NA", "NA", "NA", "2004", "2011", "2001", "2001", "2021", "2021", "2009", "2013", "2020", "2020", 
                                "2020", "2023", "2021", "2021", "2018")), 
                   class = "data.frame", 
                   row.names = c(NA, 18L))

# Both nodes and edges as list (json)
data_from_json_file <- list(nodes = structure(list(id = c("i01", "i02", "i03", "s01", "s02", "s03", "s04", "s05", "s06", "s07", "s08", "s09", "s10"), project = c("hub node 1", "hub node 2", "hub node 3", "project 1", "project 2", "project 3", "project 4", "project 5", "project 6", "project 7", "project 8", "project 9", "project 10"), is_hub = c("TRUE", "TRUE", "TRUE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE", "FALSE"), category = c(NA, NA, NA, "category Y", "category Y", "category X", "category Z", "category Y", "category X", "category Z", "category Y", "category Z", "category Y"), type = c("NA", "NA", "NA", "type C", "type B", "type B", "type A", "type C", "type C", "type A", "type B", "type B", "type A"), description = c(NA, NA, NA, "asdf", "qwerty", "abcd", "yxcv", "poiu", "vbnm", "ghjkl", "abcd", "tzuio", "lkjhg"), runtime_start = c(NA, NA, NA, "01.01.2002", "01.01.2005", "15.07.2001", "2020", "15.12.2007", 
                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        "01.07.2012", "01.01.2014", "01.01.2021", "01.01.2019", "01.01.2007"), runtime_start_year = c("NA", "NA", "NA", "2002", "2005", "2001", "2020", "2007", "2012", "2014", "2021", "2019", "2007"), runtime_end = c(NA, NA, NA, "31.12.2004", "01.01.2011", "20.10.2001", "2021", "15.12.2009", "31.06.2013", "31.12.2020", "31.12.2023", "31.12.2021", "31.12.2018"), runtime_end_year = c(NA, NA, NA, "2004", "2011", "2001", "2021", "2009", "2013", "2020", "2023", "2021", "2018")), class = "data.frame", row.names = c(NA, 13L)), edges = structure(list(source = c("i01", "i02", "i03", "s01", "s02", "s03", "s03", "s04", "s04", "s05", "s06", "s07", "s07", "s07", "s08", "s09", "s09", "s10"), project = c("hub node 1", "hub node 2", "hub node 3", "project 1", "project 2", "project 3", "project 3", "project 4", "project 4", "project 5", "project 6", "project 7", "project 7", "project 7", "project 8", "project 9", "project 9", "project 10"), target = c("i01", "i02", "i03", "i01", "i01", "i03", "i02", "i02", "i01", "i01", "i03", "i01", "i02", "i03", "i01", "i01", "i03", "i02"), value = c(1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L, 1L), start = c("NA", "NA", "NA", "2002", "2005", "2001", "2001", "2020", "2020", "2007", "2012", "2014", "2014", "2014", "2021", "2019", "2019", "2018"), end = c("NA", "NA", "NA", "2004", "2011", "2001", "2001", "2021", "2021", "2009", "2013", "2020", "2020", "2020", "2023", "2021", "2021", "2018")), class = "data.frame", row.names = c(NA, 18L)))

create_nodes <- function(nodes, start_year) {
  filtered_nodes <- nodes %>%
    filter(runtime_start_year == start_year)
  return(filtered_nodes)
}

create_links <- function(links, nodes) {
  filtered_links <- links %>%
    filter(source%in% nodes$project | target%in% nodes$project)
  return(filtered_links)
}

header <- dashboardHeader(
  
  title = "My title", 
  titleWidth = 300, 
  disable = F
)


sidebar <- dashboardSidebar(
  useShinyjs(),
  collapsed = F, 
  width = 270,
  
  sliderInput(
    inputId = "yearStart",
    label = "Filter by project start year",
    min = 2003,
    max = 2023,
    value = 2023,
    sep = ""
  )
)

body <- dashboardBody(
  useShinyjs(),
  
  fluidPage(
    tagList(
      "Navigation",
      d3Output("d3")
    )
  )
)

ui <- dashboardPage(header, sidebar, body) 

server <- function(input, output, session) {
  
  output$d3 <- r2d3::renderD3({
    
    if (!is.null(input$yearStart) && input$yearStart != "") {
      
      filtered_nodes <- create_nodes(nodes, input$yearStart)
      filtered_links <- create_links(links, filtered_nodes)
    } else {
      filtered_nodes <- nodes
      filtered_links <- links
    }
    r2d3(
      data = list(nodes = filtered_nodes, links = filtered_links),
      #data = toJSON(data_from_json_file), 
      d3_version = 4,
      script = "d3_2.js")
  })
  
}

shinyApp(ui = ui, server = server)

Provided code does not display any plot right now... So, I cannot even test my attempted code.

Further the JS snippet works separately from my Shiny. Please help me to be able to apply input functions on D3.js graph inside of Shiny!

// !preview r2d3 data = jsonlite::read_json("my_test.json"), d3_version = "4"

var color = d3.scaleOrdinal(d3.schemeCategory20);
var radius = 5;

var zoom = d3.zoom()
    .scaleExtent([0.1, 10])
    .on("zoom", zoomed);

svg.call(zoom);

var simulation = d3.forceSimulation()
    .force("link", d3.forceLink().id(function(d) { return d.id; }))
    .force("charge", d3.forceManyBody())
    .force("center", d3.forceCenter(width / 2, height / 2));

var selectedNode = null;

// Define zoomed function here
function zoomed() {
    svg.selectAll('.nodes circle, .links line')
        .attr("transform", d3.event.transform);
}

r2d3.onRender(function(graph, svg, width, height, options) {
    svg.selectAll('.nodes').remove();
    svg.selectAll('.links').remove();

    var link = svg.append("g")
        .attr("class", "links")
      .selectAll("line")
      .data(graph.links)
      .enter().append("line")
        .attr("stroke-width", function(d) { return Math.sqrt(d.value); });

    var node = svg.append("g")
        .attr("class", "nodes")
      .selectAll("circle")
      .data(graph.nodes)
      .enter().append("circle")
        .attr("r", radius)
        .call(d3.drag()
            .on("start", dragstarted)
            .on("drag", dragged)
            .on("end", dragended)
        )
        .on("click", handleClick);

    node.append("title")
        .text(function(d) { return d.project; });

    simulation
        .nodes(graph.nodes)
        .on("tick", ticked);

    simulation.force("link")
        .links(graph.links);

    function ticked() {
        node
            .attr("cx", function(d) { return d.x; })
            .attr("cy", function(d) { return d.y; });

        link
            .attr("x1", function(d) { return d.source.x; })
            .attr("y1", function(d) { return d.source.y; })
            .attr("x2", function(d) { return d.target.x; })
            .attr("y2", function(d) { return d.target.y; });
    }

    function handleClick(d) {
        if (selectedNode === d) {
            // If the same node is clicked again, clear the highlight
            clearHighlight();
        } else {
            // Otherwise, highlight the clicked node and its links
            highlightNodeAndLinks(d);
        }
    }

    function highlightNodeAndLinks(clickedNode) {
        clearHighlight();

        selectedNode = clickedNode;

        // Highlight the clicked node
        svg.selectAll('.nodes circle')
            .filter(function(d) { return d === clickedNode; })
            .attr("fill", "red")
            .attr("r", radius * 1.5); // Increase the radius

        // Highlight the links connected to the clicked node
        svg.selectAll('.links line')
            .filter(function(d) { return d.source === clickedNode || d.target === clickedNode; })
            .attr("stroke", "red");

        // Additionally, highlight the connected nodes
        svg.selectAll('.nodes circle')
            .filter(function(d) { return d === clickedNode || areConnected(d, clickedNode); })
            .attr("fill", "red")
            .attr("r", radius * 1.5); // Increase the radius
    }

    function clearHighlight() {
        selectedNode = null;

        // Reset the color and size of all nodes and links
        svg.selectAll('.nodes circle')
            .attr("r", radius);

        svg.selectAll('.links line')
            .attr("stroke", null);
    }

    function areConnected(nodeA, nodeB) {
        // Check if two nodes are connected by an edge
        return graph.links.some(function(link) {
            return (link.source === nodeA && link.target === nodeB) || (link.source === nodeB && link.target === nodeA);
        });
    }

    function dragstarted(d) {
        if (!d3.event.active) simulation.alphaTarget(0.3).restart();
        d.fx = d.x;
        d.fy = d.y;
    }

    function dragged(d) {
        d.fx = d3.event.x;
        d.fy = d3.event.y;
    }

    function dragended(d) {
        if (!d3.event.active) simulation.alphaTarget(0);
        d.fx = null;
        d.fy = null;
    }
});