datastorm-open / visNetwork

R package, using vis.js library for network visualization
Other
542 stars 127 forks source link

The pop-up for Add Node in visNetwork appears in the wrong tab in shinydashboard #435

Open kjgra-fdir opened 2 years ago

kjgra-fdir commented 2 years ago

Edit: simplified the reprex.

I'm trying to create a shinyapp to view and maintain data to be used in risk analysis.

The code below creates a shinydashboard with two tabs, each containing a tabBox with one panel rendering a visNetwork graph.

I want to create an arbitrary number of tabs, so I use variants of do.call and purrr::map to create both ui and server-elements.

In the graph, I use visOption(manipulation = TRUE) in order to update information in the database based on user input (in the code below i skip the writing-to-database part).

My problem is that the pop-up for Add Node appears in the first tab (PO1 - Name 1) even if I've selected the second (PO2 - Name 2), and started my manipulation there.

It is possible to start the manipulation in the second tab/graph, move to the first tab to define columns in the pop-up, and move back to the second graph to see the change. Not very user-friendly though...

reprex:

library(shiny)
library(shinydashboard)
library(tidyverse)
library(visNetwork)

poer <- data.frame(id = 1:2, navn = stringr::str_c("Name ", 1:2))

noder <- list(
    data.frame(id = 1:5, level = c(1,2,2,3,3), label = stringr::str_c("Tree 1 - Node ", 1:5)),
    data.frame(id = 1:5, level = c(1,2,2,3,3), label = stringr::str_c("Tree 2 - Node ", 1:5))
)

kanter <- list(
    data.frame(from = c(1,1,2,2), to = 2:5),
    data.frame(from = c(1,1,2,2), to = 2:5)
)

ui <- dashboardPage(

    dashboardHeader(title = "Dashboard title", titleWidth = 250),

    dashboardSidebar(
        width = 250,
        do.call(
            sidebarMenu,
            map(seq_len(nrow(poer)),
                ~menuItem(text = glue::glue("PO{poer$id[.]} - {poer$navn[.]}"),
                          tabName = glue::glue("po_{poer$id[.]}")))
        )
    ),

    dashboardBody(
        do.call(
            tabItems, 
            map(seq_len(nrow(poer)),
                ~tabItem(
                    tabName = glue::glue("po_{poer$id[.]}"),
                    h2(glue::glue("EDIT page for {poer$id[.]}")),
                    h5("Here you can do stuff"),
                    tabBox(
                        tabPanel("Tree", visNetworkOutput(glue::glue("tre_{poer$id[.]}"), height = "450px"))
                    )
                )
            )
        )
    )
)

server <- function(input, output) {

    data <- reactiveValues(noder = noder, kanter = kanter)

    map(seq_len(nrow(poer)), function(x) {
        tre_nr <- glue::glue("tre_{poer$id[x]}")
        output[[tre_nr]] <- renderVisNetwork({
            visNetwork(data$noder[[x]], data$kanter[[x]]) %>% 
                visEdges(arrows = "from", arrowStrikethrough = F, shadow = T) %>% 
                visNodes(borderWidth = 5, shape = "ellipse", shadow = F, physics = F) %>% 
                visHierarchicalLayout(nodeSpacing = 150) %>% 
                visInteraction(zoomSpeed = .5) %>%
                visOptions(manipulation = list(enabled = TRUE, addNodeCols = c("level", "label")))
        })
    })
}

shinyApp(ui = ui, server = server)

Also, the result of sessionInfo():

R version 4.0.2 (2020-06-22)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 19044)

Matrix products: default

locale:
[1] LC_COLLATE=Norwegian Bokmål_Norway.1252  LC_CTYPE=Norwegian Bokmål_Norway.1252   
[3] LC_MONETARY=Norwegian Bokmål_Norway.1252 LC_NUMERIC=C                            
[5] LC_TIME=Norwegian Bokmål_Norway.1252    

attached base packages:
[1] stats     graphics  grDevices utils     datasets  methods   base     

other attached packages:
 [1] DT_0.20              visNetwork_2.1.0     forcats_0.5.0        stringr_1.4.0        dplyr_1.0.2         
 [6] purrr_0.3.4          readr_1.3.1          tidyr_1.1.2          tibble_3.0.3         ggplot2_3.3.3       
[11] tidyverse_1.3.0      shinydashboard_0.7.2 shiny_1.5.0         

loaded via a namespace (and not attached):
 [1] tidyselect_1.1.0  haven_2.3.1       colorspace_1.4-1  vctrs_0.3.4       generics_0.0.2    htmltools_0.5.0  
 [7] yaml_2.2.1        blob_1.2.1        rlang_0.4.7       jquerylib_0.1.4   later_1.1.0.1     pillar_1.4.6     
[13] glue_1.4.2        withr_2.3.0       DBI_1.1.0         dbplyr_1.4.4      modelr_0.1.8      readxl_1.3.1     
[19] lifecycle_0.2.0   munsell_0.5.0     gtable_0.3.0      cellranger_1.1.0  rvest_0.3.6       htmlwidgets_1.5.2
[25] fastmap_1.0.1     crosstalk_1.1.0.1 httpuv_1.5.4      fansi_0.4.1       broom_0.7.1       Rcpp_1.0.7       
[31] xtable_1.8-4      promises_1.1.1    backports_1.1.10  scales_1.1.1      jsonlite_1.7.2    mime_0.9         
[37] fs_1.5.0          hms_0.5.3         digest_0.6.25     stringi_1.5.3     grid_4.0.2        cli_2.0.2        
[43] tools_4.0.2       magrittr_1.5      crayon_1.3.4      pkgconfig_2.0.3   ellipsis_0.3.1    rsconnect_0.8.16 
[49] xml2_1.3.2        reprex_0.3.0      lubridate_1.7.9   assertthat_0.2.1  httr_1.4.2        rstudioapi_0.11  
[55] R6_2.4.1          compiler_4.0.2