Introduce interactive path choice and observers

.github/workflows/test.yml

@@ -0,0 +1,50 @@
+name: test
+'on':
+  pull_request:
+    branches:
+    - devel
+env:
+  CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }}
+jobs:
+  rworkflows:
+    permissions: write-all
+    runs-on: ${{ matrix.config.os }}
+    name: ${{ matrix.config.os }} (${{ matrix.config.r }})
+    container: ${{ matrix.config.cont }}
+    strategy:
+      fail-fast: ${{ false }}
+      matrix:
+        config:
+        - os: ubuntu-latest
+          bioc: devel
+          r: auto
+          cont: ghcr.io/bioconductor/bioconductor_docker:devel
+          rspm: ~
+        - os: macOS-latest
+          bioc: devel
+          r: auto
+          cont: ~
+          rspm: ~
+        - os: windows-latest
+          bioc: devel
+          r: auto
+          cont: ~
+          rspm: ~
+    steps:
+    - uses: neurogenomics/rworkflows@master
+      with:
+        run_bioccheck: ${{ true }}
+        run_rcmdcheck: ${{ true }}
+        as_cran: ${{ true }}
+        run_vignettes: ${{ false }}
+        has_testthat: ${{ true }}
+        run_covr: ${{ false }}
+        run_pkgdown: ${{ false }}
+        has_runit: ${{ false }}
+        has_latex: ${{ false }}
+        GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        run_docker: ${{ false }}
+        DOCKER_TOKEN: ${{ secrets.DOCKER_TOKEN }}
+        runner_os: ${{ runner.os }}
+        cache_version: cache-v1
+        docker_registry: ghcr.io

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: ariadneApp
-Version: 0.0.1
-Authors@R: 
+Version: 0.0.2
+Authors@R:
     c(person(given = "Giulio", family = "Benedetti", role = c("aut", "cre"),
           email = "giulio.benedetti@utu.fi",
           comment = c(ORCID = "0000-0002-8732-7692")),
@@ -19,12 +19,13 @@ biocViews:
 License: Artistic-2.0
 Encoding: UTF-8
 Depends:
-    R (>= 4.1)
-Imports:
-    ariadne,
+    R (>= 4.1),
     igraph,
     shiny,
     visNetwork
+Imports:
+    ariadne,
+    bslib
 Suggests:
     BiocStyle,
     rmarkdown,

NAMESPACE

@@ -2,13 +2,7 @@
 
 export(shinePath)
 importFrom(ariadne,ariadne)
-importFrom(igraph,as_undirected)
-importFrom(shiny,fluidPage)
-importFrom(shiny,shinyApp)
-importFrom(visNetwork,renderVisNetwork)
-importFrom(visNetwork,visEdges)
-importFrom(visNetwork,visIgraph)
-importFrom(visNetwork,visInteraction)
-importFrom(visNetwork,visNetworkOutput)
-importFrom(visNetwork,visNodes)
-importFrom(visNetwork,visOptions)
+importFrom(ariadne,drawPath)
+importFrom(bslib,bs_theme)
+importFrom(bslib,page_sidebar)
+importFrom(bslib,sidebar)

R/app.R

@@ -1,35 +1,185 @@
 
-#' @importFrom ariadne ariadne
-#' @importFrom igraph as_undirected
-#' @importFrom visNetwork renderVisNetwork visIgraph visNodes visEdges visOptions visInteraction
+#' @importFrom ariadne ariadne drawPath
 server <- function(input, output) {
 
     graph <- ariadne() |>
-        as_undirected(mode = "collapse")
+        as_undirected(mode = "each")
 
-    output$ariadne <- renderVisNetwork({
-
+    vertex_attr(graph, "id") <- V(graph)$name
+    edge_attr(graph, "id") <- seq_along(E(graph))
+
+    node_df <- as_data_frame(graph, what = "vertices")
+    edge_df <- as_data_frame(graph, what = "edges")
+
+    output$network <- renderVisNetwork({
+
         visIgraph(graph, randomSeed = 123) |>
             visNodes(color = "darkorange") |>
-            visEdges(color = "lightgrey", value = "source") |>
-            visOptions(
-                selectedBy = list(variable = "id"),
-                highlightNearest = TRUE
+            visEdges(color = list(color = "lightgrey", highlight = "red")) |>
+            visInteraction(
+                dragNodes = FALSE,
+                multiselect = TRUE,
+                selectConnectedEdges = FALSE
             ) |>
-            visInteraction(multiselect = TRUE)
+            visEvents(
+                select = "function(x) {
+                    Shiny.onInputChange('net_data', x);
+                ;}"
+            )
+    })
+
+    observe({
+
+        if( is.null(input$resource) ){
+            node_df$hidden <- FALSE
+            edge_df$hidden <- FALSE
+        }else{
+            edge_selected <- edge_df$source %in% input$resource
+
+            nodes <- unique(
+                c(edge_df$from[edge_selected], edge_df$to[edge_selected])
+            )
+
+            edge_df$hidden <- !edge_selected
+            node_df$hidden <- !node_df$id %in% nodes
+        }
+
+        visNetworkProxy("network") |>
+            visUpdateNodes(nodes = node_df) |>
+            visUpdateEdges(edges = edge_df)
+    })
+
+    observe({
+
+        nodes <- unlist(input$net_data$nodes)
+        req(length(nodes) < 2L)
+
+        edge_df$label <- " "
+
+        if( !is.null(nodes) ){
+
+            visNetworkProxy("network") |>
+                visUpdateEdges(edges = edge_df) |>
+                visSetSelection(nodesId = nodes, highlightEdges = FALSE)
+        }
+
+        updateTextInput(inputId = "by", value = NA)
+        updateSelectInput(inputId = "include", selected = NA)
+        updateSelectInput(inputId = "exclude", selected = NA)
+    })
+
+    observe({
+
+        nodes <- unlist(input$net_data$nodes)
+        req(length(nodes) > 1L)
+
+        path_by <- c(nodes[1], nodes[length(nodes)]) |>
+            paste(collapse = "~") |>
+            as.formula()
+
+        include <- if(length(nodes) > 2L) nodes[2:(length(nodes) - 1)] else NULL
+
+        updateTextInput(inputId = "by", value = deparse(path_by))
+        updateSelectInput(inputId = "include", selected = include)
+
+        path_df <- drawPath(
+            graph,
+            by = path_by,
+            k = input$k,
+            include = input$include,
+            exclude = input$exclude,
+            res.name = input$resource
+        )
+
+        edges <- get_edge_ids(graph, path_df)
+
+        edge_selected <- edge_df$id %in% edges
+        node_selected <- node_df$id %in% union(path_df$from, path_df$to)
+
+        edge_df$label <- ifelse(edge_selected, edge_df$source, " ")
+
+        node_df$hidden <- if(input$prune) !node_selected else FALSE
+        edge_df$hidden <- if(input$prune) !edge_selected else FALSE
+
+        visNetworkProxy("network") |>
+            visUpdateNodes(nodes = node_df) |>
+            visUpdateEdges(edges = edge_df) |>
+            visSetSelection(
+                nodesId = nodes,
+                edgesId = edges,
+                highlightEdges = FALSE
+            )
+
+        if( input$focus ){
+
+            visNetworkProxy("network") |>
+                visFit(nodes = nodes)
+        }
     })
 }
 
-#' @importFrom shiny fluidPage
-#' @importFrom visNetwork visNetworkOutput
+
+#' @importFrom bslib page_sidebar bs_theme sidebar
 ui <- function(){
-    fluidPage(
-        visNetworkOutput("ariadne", height = "100vh", width = "100vw")
+
+    graph <- ariadne()
+
+    page_sidebar(
+        fillable = FALSE,
+        theme = bs_theme(bootswatch = "united"),
+        sidebar = sidebar(
+
+            textInput("by", "Path:", placeholder = "from ~ to"),
+
+            numericInput("k", "k:", value = 1, min = 1),
+
+            selectInput("include", "Include:", choices = V(graph)$name,
+                selected = NULL, multiple = TRUE),
+
+            selectInput("exclude", "Exclude:", choices = V(graph)$name,
+                selected = NULL, multiple = TRUE),
+
+            selectInput("resource", "Resource:",
+                choices = unique(E(graph)$source), selected = NULL,
+                multiple = TRUE),
+
+            tags$style(HTML("
+                .shiny-options-group .radio-inline {margin-right: 1rem;}
+            ")),
+
+            radioButtons(
+                "init_type", "Initial values as:", choices = c("text", "file"),
+                inline = TRUE,
+            ),
+
+            conditionalPanel(
+                condition = "input.init_type == 'text'",
+
+                selectizeInput(
+                    "init_text", "Initial values:", choices = NULL,
+                    multiple = TRUE, options = list(create = TRUE)
+                )
+            ),
+
+            conditionalPanel(
+                condition = "input.init_type == 'file'",
+
+                fileInput(
+                    "init_file", "Initial values:", accept = c("csv", "tsv")
+                )
+            ),
+
+            checkboxInput("focus", "Focus"),
+            checkboxInput("prune", "Prune"),
+
+            actionButton("weave", "Weave", class = "btn-warning", icon = icon("pencil"))
+        ),
+        visNetworkOutput("network", height = "100vh", width = "100vw")
     )
 }
 
+
 #' @export
-#' @importFrom shiny shinyApp
 shinePath <- function(){
     shinyApp(ui = ui(), server = server)
 }