R/shiny_showtree.R

In tdanker/ephys2: Read, analyze and plot HEKA Patchmaster files

#' Interactive visualisation of the tree structure (using shiny)
#'
#' @param tree  a tree as generated with \code{get_treeinfo}
#' @param level how many levels of the tree shall be shown (affects performance)
#' @param active_trace select which trace is selected; usefull if 'level' is <4, so that traces are not shown in the tree
#' @param helptext a string that would be shown above the treeview
#'
#' @import shinyTree
#' @import shiny
#' @return a tree
#' @export
#'

showtree <- function(tree,
                     level = 3,
                     active_trace = 1,
                     helptext = "", myrow2=
                        ".myRow2{border-color: white; 
                    
    border-top-color: lightgrey; 
                        border-style: solid; 
                        border-width: 1px; 
                        border-bottom-color: black}"
) {

  assertthat::assert_that(inherits(tree,"HEKA_treeinfo"))
  
  if (!exists("CURSORS"))
    CURSORS <<- list()
  
  if (is.null(tree$setup))
    tree$setup <- list()
  if (is.null(tree$setup$cursor))
    tree$setup$cursor <- list()

  #requireNamespace would be preferable to make R CMD CHECK happy, but it is not sufficient here. 
  # We would end up with an errormessage: "No handler registered for type tree:shinyTree"
  require("shinyTree")  
  
  app <- shinyApp(
   
    ui =
      fluidPage(#pageWithSidebar(
        #headerPanel(header_panel),
        tags$head(tags$style(myrow2)),
        sidebarLayout(
          
          sidebarPanel(
            helpText(HTML(helptext)),
            shinyTree("tree", checkbox = T, three_state = F, whole_node = F, tie_selection = F), style = "overflow-y:scroll; height: 95vh" ),
          
          mainPanel(
            shinyjs::useShinyjs(),
            plotOutput( "plot", brush = brushOpts(id = "plot_brush", direction = "x", resetOnNew = T )),
            fluidRow(class="myRow2",
                column(6, radioButtons("cursortype", "cursor", c("zoom", "zoom out"), selected = NULL, inline = T, width = NULL )),
                column(2, textInput(   "sweeps", "sweeps")),
                column(2, textInput(   "newcursor", "newcursor")),
                column(2, selectInput( "cursormeasurement", "measure", c("Min", "Max", "Mean", "AP") )),
                column(2, HTML("<b>scope</b><br>"),  checkboxInput("EventCur","Event", value = F)),
                column(2, HTML("<b>remove</b><br>"), actionButton( "delCur",   "X",    block = T))
            ),
            plotOutput("plot2"),
            verbatimTextOutput("str"),
            textInput("par", "parameters"),
            actionButton("myBtn", "OK")
          )
        )),

    server = function(input, output, session) {
      shinyjs::disable("EventCur")
      # handle closing of browser window
      session$onSessionEnded(function() {
        stopApp(tree)
      })
      
      last_selection<-NULL
      unzoom_clicked<-F
      brushed<-F
      
      values <- reactiveValues()
      values$res = ""
      
      tree_ <- tree
      tree_$setup <- NULL
      tree_ <- prune_closed(tree_)
      
      output$tree <- renderTree({
        tree_
      })
      
      
      
      output$str <- renderPrint({
      
      })
      
      # "remove" button to delete cursors
      observe({ 
        input$delCur
        isolate({
          try(selection <- get_selected(input$tree, format = "names")[[1]],
              sil = T)
          if (exists("selection")) {
            #delete this cursor from CURSORS
            stim <- getStimName(tree, selection)
            CURSORS[[stim]]$cursors[[input$cursortype]] <<- NULL
            
            # Update radiobuttons
            curnames = get_curnames(tree,selection)
            choices = c("zoom", "zoom out", curnames[!curnames %in% c("zoom", "zoom out")])
            updateRadioButtons(
              session,
              "cursortype",
              choices = choices,
              selected = choices[1],
              inline = T
            )
          }
        })
      })
      
      # newcursor: unselect all existing cursors
      observe({
        if (!input$newcursor == "") {
          updateRadioButtons(
            session,
            "cursortype",
            choices = "",
            selected = "",
            inline = T
          )
        }
      })
      
      observe({
        # detect if nodes are opened and closed
        if(detect_toggle(tree_, input$tree)){
          #pruning childs of closed nodes discards their checked state, so this is synced to the original tree first 
          tree<<-sync_trees(tree, input$tree)
          # prune childs of closed nodes
          tree_<<-prune_closed(tree, input$tree)
          print("updating tree")
          updateTree(session, "tree", tree_)
        }

      })
      
      # observe selection changes
      observe({
        try(selection <- get_selected(input$tree, format = "names")[[1]],
            sil = T)
        try(selection_ <<- get_selected(input$tree, format = "names"),
            sil = T)
        if (exists("selection")) {
          
          # unzoom option
          stim <- getStimName(tree, selection)
          if (input$cursortype == "zoom out") {
            CURSORS[[stim]]$cursors$zoom$range <<- NULL
            unzoom_clicked<<-T
          }
          
          
          
          
          # update parameter text box
          sel_ <- c(attr(selection, "ancestry"), selection)
          par <- attr(tree[[sel_]], "par")
          updateTextInput(session, "par", value = as.character(par))
          
          # update radiobuttons 
          curnames = get_curnames(tree,selection)
          choices = c("zoom", "zoom out", curnames[!curnames %in% c("zoom", "zoom out")])
          updateRadioButtons(
            session,
            "cursortype",
            choices = choices,
            selected = input$cursortype,
            inline = T
          )
          
          # enable / disable eventcusor
          if(input$cursortype=="" && !is.na(sel_[5])){
            #shinyjs::enable("EventCur")
            updateCheckboxInput(session,"EventCur",value = T)
          }else{
            #shinyjs::disable("EventCur")
            updateCheckboxInput(session,"EventCur",value = F)
          }
          
          # update cursortype selectbox after cursor selection change
          type <- CURSORS[[stim]]$cursors[[input$cursortype]]$type
          updateSelectInput(session, "cursormeasurement", selected = type)
          # brushing
          if (!is.null(input$plot_brush)) {
            isolate({
              
              # zoom via brush
              if (input$cursortype == "zoom") {
                
                CURSORS[[stim]]$cursors$zoom$range <<-
                  c(input$plot_brush$xmin, input$plot_brush$xmax)
                if (is.null(CURSORS[[stim]]$plot.fun)) {
                  CURSORS[[stim]]$plot.fun <<- default.plot.fun
                }
                
              }
              
              # update cursor via brush
              if (!input$cursortype == "zoom" &&  !input$cursortype == "zoom out") {
                
                if (length(sel_) > 2) {
                  method = curMean_
                  if (input$cursormeasurement == "Min")
                    method = curMin_
                  if (input$cursormeasurement == "Mean")
                    method = curMean_
                  if (input$cursormeasurement == "Max")
                    method = curMax_
                  if (input$cursormeasurement == "AP")
                    method = curAP_
                  
                  s <- getSeries(tree, sel_[1], sel_[2], sel_[3])
                  ctype <- input$cursortype
                  path<-NULL
                  event<-F
                  if (!is.null(input$newcursor))
                    if (!input$newcursor == ""){
                      ctype <- input$newcursor
                      if(!is.na(sel_[5])){
                        #new eventcursor!
                        path=make_path_from_selection(tree, selection)
                        event<-T
                      }
                    }
                  
                  s$set_cursor(ctype,
                               method,
                               range = c(input$plot_brush$xmin, input$plot_brush$xmax), path=path,event=event)
                  if(!event){
                    updateTextInput(session, "newcursor", value = "")
                    updateRadioButtons(
                      session,
                      "cursortype",
                      choices = c(choices, ctype),
                      selected = ctype,
                      inline = T
                    )
                    
                  }
                }
              }
              
            })
            brushed<<-T
          }
          
          #check if theres a reason to replot #selection changed
          if(!exists("last_selection") || !identical(selection, last_selection ) || unzoom_clicked || brushed){
            last_selection<<-selection
            unzoom_clicked<<-F
            brushed<<-F
            # render plot1, brushing
            output$plot <- renderPlot({
              isolate(
                values$res <- render.default(tree, input$tree, active_trace)
              )
              
              #hide/unhide plot2
              if (exists("stim") && exists("CURSORS")) {
                if (is.null(CURSORS[[stim]]$plot2.fun)) {
                  shinyjs::hide("plot2")
                } else{
                  shinyjs::show("plot2")
                  
                  #render plot2
                  output$plot2 <- renderPlot({
                    input$plot_brush
                    isolate(
                      render.default(tree, input$tree, active_trace, plot = 2)
                    )
                  })
                }
              }    
              
              
            })
          }
         
          
          
                    
   
        }

      })
      
      

      

      # OK button
      observe({
        
        if (input$myBtn > 0) {
          tree <- sync_trees(tree, input$tree)
          stopApp(tree)
        }
        
        # textinput "par" is changed:
        try(sel <- get_selected(input$tree)[[1]], sil = T)
        if (exists("sel")) {
          sel_ <- c(attr(sel, "ancestry"), sel)
          tree <- sync_trees(tree, input$tree)
          par <- input$par
          attr(tree[[sel_]], "par") <- par
          tree <<- tree
        }
      })
    }
  )
  
  invisible( runApp(app))
}