Logo Questions Linux Laravel Mysql Ubuntu Git Menu
 

Tiny plot output from sankeyNetwork (NetworkD3) in Firefox

As per object, I get a very small plot in Firefox when using sankeyNetwork() from networkd3 in shiny but not in Chrome or RStudio.

I have not included any CSS or JS in the script - the code below produces this result for me.

Is there any CSS property I have missed?

I am using R 3.4.1, shiny 1.1.0, networkD3 0.4 and Firefox 52.9.0.

Firefox: Firefox

Chrome: Chrome

library(shiny)
library(magrittr)
library(shinydashboard)
library(networkD3)

labels = as.character(1:9)
ui <- tagList(
  dashboardPage(
    dashboardHeader(
      title = "appName"
    ),
    ##### dasboardSidebar #####
    dashboardSidebar(
      sidebarMenu(
        id = "sidebar",
        menuItem("plots",
                 tabName = "sPlots")
      )
    ),
    ##### dashboardBody #####
    dashboardBody(
      tabItems(
        ##### tab #####
        tabItem(
          tabName = "sPlots",
          tabsetPanel(
            tabPanel(
              "Sankey plot",
              fluidRow(
                box(title = "title",
                    solidHeader = TRUE, collapsible = TRUE, status = "primary",
                    sankeyNetworkOutput("sankeyHSM1")
                )
              )
            )
          )
        )
      )
    )
  )
)

server <- function(input, output, session) {

  HSM = matrix(rep(c(10000, 700, 10000-700, 200, 500, 50, 20, 10, 2,40,10,10,10,10),4),ncol = 4)
  sankeyHSMNetworkFun = function(x,ndx) {
    nodes = data.frame("name" = factor(labels, levels = labels),
                       "group" = as.character(c(1,2,2,3,3,4,4,4,4)))
    links = as.data.frame(matrix(byrow=T,ncol=3,c(
      0, 1, NA,
      0, 2, NA,
      1, 3, NA,
      1, 4, NA,
      3, 5, NA,
      3, 6, NA,
      3, 7, NA,
      3, 8, NA
    )))
    links[,3] = HSM[2:(nrow(links)+1),] %>% {rowSums(.[,(ndx-1)*2+c(1,2)])}
    names(links) = c("source","target","value")
    sankeyNetwork(Links = links, Nodes = nodes, Source = "source", Target = "target", Value = "value", NodeID = "name",NodeGroup = "group",
                  fontSize=12,sinksRight = FALSE)
  }
  output$sankeyHSM1 = renderSankeyNetwork({
    sankeyHSMNetworkFun(values$HSM,1)
  })
}

# Run the application
shinyApp(ui = ui, server = server)

------------------ EDIT --------------------

Thanks to @CJYetman for indicating onRender() as a possible solution - however this fails when there are two plots generated side by side as in the MRE below (note in addition to the second sankey plot I have also added javascript code to re-draw the figures when the window size changes as the plot does not appear to do it automatically).

library(shiny)
library(magrittr)
library(shinydashboard)
library(networkD3)
library(htmlwidgets)

labels = as.character(1:9)
ui <- tagList(
  tags$head(
    tags$script('
var dimension = [0, 0];
$(document).on("shiny:connected", function(e) {
    dimension[0] = window.innerWidth;
    dimension[1] = window.innerHeight;
    Shiny.onInputChange("dimension", dimension);
});
$(window).resize(function(e) {
    dimension[0] = window.innerWidth;
    dimension[1] = window.innerHeight;
    Shiny.onInputChange("dimension", dimension);
});
                            ')
  ),
  dashboardPage(
    dashboardHeader(
      title = "appName"
    ),
    ##### dasboardSidebar #####
    dashboardSidebar(
      sidebarMenu(
        id = "sidebar",
        menuItem("plots",
                 tabName = "sPlots")
      )
    ),
    ##### dashboardBody #####
    dashboardBody(
      tabItems(
        ##### tab #####
        tabItem(
          tabName = "sPlots",
          tabsetPanel(
            tabPanel(
              "Sankey plot",
              fluidRow(
                box(title = "title",
                    solidHeader = TRUE, collapsible = TRUE, status = "primary",
                    sankeyNetworkOutput("sankeyHSM1")
                ),
                box(title = "plot2",
                    solidHeader = TRUE, collapsible = TRUE, status = "primary",
                    sankeyNetworkOutput("sankeyHSM2"))
              )
            )
          )
        )
      )
    )
  )
)

server <- function(input, output, session) {

  HSM = matrix(rep(c(10000, 700, 10000-700, 200, 500, 50, 20, 10, 2,40,10,10,10,10),4),ncol = 4)
  sankeyHSMNetworkFun = function(x,ndx) {
    nodes = data.frame("name" = factor(labels, levels = labels),
                       "group" = as.character(c(1,2,2,3,3,4,4,4,4)))
    links = as.data.frame(matrix(byrow=T,ncol=3,c(
      0, 1, NA,
      0, 2, NA,
      1, 3, NA,
      1, 4, NA,
      3, 5, NA,
      3, 6, NA,
      3, 7, NA,
      3, 8, NA
    )))
    links[,3] = HSM[2:(nrow(links)+1),] %>% {rowSums(.[,(ndx-1)*2+c(1,2)])}
    names(links) = c("source","target","value")
    sankeyNetwork(Links = links, Nodes = nodes, Source = "source", Target = "target", Value = "value", NodeID = "name",NodeGroup = "group",
                  fontSize=12,sinksRight = FALSE)
  }
  output$sankeyHSM1 = renderSankeyNetwork({
    req(input$dimension)
    sankeyHSMNetworkFun(values$HSM,1) %>%
      onRender('document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')
  })
  output$sankeyHSM2 = renderSankeyNetwork({
    req(input$dimension)
    sankeyHSMNetworkFun(values$HSM,2) %>%
      onRender('document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')
  })
}

# Run the application
shinyApp(ui = ui, server = server)

------------------ EDIT2 --------------------

Second problem above solved - either by referring to the second svg item on the page as per @CJYetman's comment below using document.getElementsByTagName("svg")[1].setAttribute("viewBox",""), or by going into the objects themselves selecting their first svg element with document.getElementById("sankeyHSM2").getElementsByTagName("svg")[0].setAttribute("viewBox","").

like image 542
Andrea Avatar asked Jul 03 '18 01:07

Andrea


1 Answers

This seems to be the result of Firefox reacting to the viewbox svg property differently than other browsers. It might be worthwhile to submit this as an issue here https://github.com/christophergandrud/networkD3/issues

In the meantime, you could work around this by resetting the viewbox attribute using some JavaScript and htmlwidgets::onRender(). Here's an example using a minimized version of your example. (Resetting the viewbox attribute may have other consequences)

library(htmlwidgets)
library(networkD3)
library(magrittr)

nodes = data.frame("name" = factor(as.character(1:9)),
                   "group" = as.character(c(1,2,2,3,3,4,4,4,4)))

links = as.data.frame(matrix(byrow = T, ncol = 3, c(
  0, 1, 1400,
  0, 2, 18600,
  1, 3, 400,
  1, 4, 1000,
  3, 5, 100,
  3, 6, 40,
  3, 7, 20,
  3, 8, 4
)))
names(links) = c("source","target","value")

sn <- sankeyNetwork(Links = links, Nodes = nodes, Source = "source", 
                    Target = "target", Value = "value", NodeID = "name", 
                    NodeGroup = "group", fontSize = 12, sinksRight = FALSE)

htmlwidgets::onRender(sn, 'document.getElementsByTagName("svg")[0].setAttribute("viewBox", "")')

UPDATE (2019.10.26)

This is probably a safer implementation of removing the viewBox...

htmlwidgets::onRender(sn, 'function(el) { el.getElementsByTagName("svg")[0].removeAttribute("viewBox") }')

UPDATE 2020.04.02

My currently preferred method to do this is to use htmlwidgets::onRender to target specifically the SVG contained by the passed htmlwidget, like this...

onRender(sn, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')

That can then be done specifically to as many htmlwidgets on your page as necessary, for instance...

onRender(sn, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')

onRender(sn2, 'function(el) { el.querySelector("svg").removeAttribute("viewBox") }')
like image 200
CJ Yetman Avatar answered Sep 28 '22 09:09

CJ Yetman