i2b2metadata/server.R

library(tidyverse)
library(data.tree)
library(shiny)
library(shinyjs)
library(shinyTree)
library(rclipboard)

source("helper_functions.R")
source("ui.R")

# Load data
read_csv("metadata.csv") %>%
  filter(C_VISUALATTRIBUTES != "LI") %>%                                                              # will be dealt in extraction
  mutate(C_FULLNAME = paste0("\\i2b2\\", C_FULLNAME),                                                 # will be dealt in extraction
         C_HLEVEL = if_else(C_VISUALATTRIBUTES == "RA", str_count(C_FULLNAME, "\\\\") - 2, C_HLEVEL),     # C_HLEVEL of modifiers are all 1, changing it to the correct number (either 2 or 3)
         C_FULLNAME2 = str_replace_all(C_FULLNAME, regex("\\\\( ){1,3}"), "\\\\"),                        # remove leading whitespace on nodes in the full path
         C_FULLNAME2 = str_replace_all(C_FULLNAME2, regex("( ){1,11}\\\\"), "\\\\"),                      # remove trailing whitespace on nodes in the full path
         sticon = recode(C_VISUALATTRIBUTES,                                                              # to delete ?
                         "FA"="glyphicon glyphicon-folder-close",
                         "LA"="glyphicon glyphicon-file",
                         "RA"="glyphicon glyphicon-file blue"),
         type = C_VISUALATTRIBUTES) -> metadata                                 # to delete too ?

# Generate base trees
metadata %>%
  filter(C_HLEVEL == 1) -> explore_tree_df

explore_tree_df %>%
  df_to_treelist -> explore_tree

metadata %>%
  search_in_df("hyp(o|er)gly", "C_NAME", T) -> search_tree_df

search_tree_df %>%
  df_to_tree -> search_tree

server <- shinyServer(function(input, output, session)
{
  v <- reactiveValues()
  v$df <- explore_tree_df
  v$df2 <- search_tree_df
  v$requests <- c()                                                             # store previous requests for children to prevent doing them twice
  v$selected <- NULL

  output$explore_tree <- renderTree(explore_tree)

  # Controls conditional panel
  output$selected <- reactive(length(v$selected) > 0)

  # When a node is selected, display information
  observeEvent(input$explore_tree,
  {
    v$selected <- get_selected(input$explore_tree)

    if (length(v$selected) > 0)
    {
      v$c_name <- v$selected[[1]][1]
      v$node_ancestors <- attr(v$selected[[1]], 'ancestry')
      v$node_path <- get_path(v$c_name, v$node_ancestors)
      v$node_line <- get_line(v$df, v$node_path)
      v$c_fullname <- v$node_line$C_FULLNAME
      v$node_level <- v$node_line$C_HLEVEL
      v$is_leaf <- v$node_line$C_VISUALATTRIBUTES %in% c("LA", "RA", "LI")
      v$c_basecode <- v$node_line$C_BASECODE
    }
  })

  # Display node info
  output$c_basecode <- renderText(v$c_basecode)
  output$c_name <- renderText(v$c_name)
  output$clip <- renderUI(rclipButton("clipbtn",
                                      v$c_fullname,
                                      str_replace_all(v$c_fullname, fixed("\\"), fixed("\\\\")),     # with the button, escape chars are interpreted so \\ have to be doubled
                                      icon("clipboard")))

  # render a table with all node whose C_BASECODE match the one of the currently selected node
  output$codes <- renderTable(
  {
    if (length(v$selected)>0)
    {
      metadata %>%
        filter(C_BASECODE == v$c_basecode) %>%
        select(C_NAME) %>%
        arrange(nchar(C_NAME))
    }
  })

  #Append children
  observeEvent(v$selected,
  {
    if (all(length(v$selected) > 0,                                                   # a node was selected
            nrow(v$node_line) == 1,                                                   # node was found in the dataframe
            v$is_leaf == F,                                                           # node is not a leaf
      !(v$node_path %in% v$requests)))                                          # request was not already done
    {
      v$requests <- c(v$requests, v$node_path)                                  # store the request
      children <- request_children(metadata, v$node_path, v$node_level)

      if (nrow(children) > 0)                                                   # children found
      {
        v$df <- v$df %>% bind_rows(children)                                    #%>% distinct()

        path_list <- c(v$node_ancestors, v$c_name)

        t <- input$explore_tree

        # insert the structure(list(), attr = ,) on the corresponding node
        pluck(t, !!!path_list) <- structure(df_to_treelist(children), stselected = T, stopened = T, sticon="glyphicon glyphicon-folder-open")  # stopened = input$open_children

        updateTree(session, "explore_tree", t)
      }
    }
  })

  matching_codes <- reactive(
  {
    if (!is.null(v$c_basecode))
    {
        metadata %>% filter(C_BASECODE == v$c_basecode)
    }
  })

  matching_code_json <- reactive(
  {
    matching_codes() %>%
      df_to_tree() %>%
      treeToJSON()
  })

  output$matching_code_tree <- renderTree(
  {
    if (!is.null(v$c_basecode))
    {
      matching_code_json()
    }
  })

  observeEvent(matching_codes(),
  {
    updateTree(session, "matching_code_tree", matching_code_json())
  })

  observeEvent(input$open_matching_code,
  {
    runjs(HTML('$("#matching_code_tree").jstree("open_all");'))
  })


  #############
  # Search
  #############

  output$search_tree <- renderTree(
  {
    treeToJSON(search_tree)                                                     # use treeToJSON because there are multiple levels
  })

  observeEvent(input$search_tree,
  {
    v$selected_search_tree <- get_selected(input$search_tree)

    if (length(v$selected_search_tree) > 0)
    {
      v$s_name <- v$selected_search_tree[[1]][1]
      v$s_node_ancestors <- attr(v$selected_search_tree[[1]], 'ancestry')
      v$s_node_path <- get_path(v$s_name, v$s_node_ancestors)
      v$s_node_line <- get_line(metadata, v$s_node_path)
      v$s_fullname <- v$s_node_line$C_FULLNAME

      v$s_node_level <- v$s_node_line$C_HLEVEL
      v$s_is_leaf <- v$s_node_line$C_VISUALATTRIBUTES %in% c("LA", "RA", "LI")
      v$s_basecode <- v$s_node_line$C_BASECODE

    }
  })

  # command the conditional panel
  output$s_selected <- reactive(
  {
    length(v$selected_search_tree) > 0
  })

  output$s_basecode <- renderText(v$s_basecode)
  output$s_name <- renderText(v$s_name)
  output$s_clip <- renderUI(rclipButton("clipbtn",
                                        v$s_fullname,
                                        str_replace_all(v$s_fullname, fixed("\\"), fixed("\\\\")),
                                        icon("clipboard")))

  observeEvent(input$perform_search,
  {
    search_results <- search_in_df(metadata, input$text_to_search, input$search_on, input$use_regex)
    if (nrow(search_results) > 0)
    {
      v$df2 <- search_results
    }
  })

  observeEvent(v$df2,
  {
    updateTree(session, "search_tree", treeToJSON(df_to_tree(v$df2)))
  })

  observeEvent(input$open_all,
  {
    runjs(HTML('$("#search_tree").jstree("open_all");'))
  })

  outputOptions(output, "selected", suspendWhenHidden = F)
  outputOptions(output, "s_selected", suspendWhenHidden = F)
})

shinyApp(ui, server, options = list(host = "0.0.0.0", port = 4321))