bvt: Visualization Tools for Bioconductor

Documented in pick_points

#' @title Interactively Pick Points and Group Data
#' @description A Shiny Widget to Inspect Points and Define Groups in Existing bvt and NicePlots Graphs
#'
#' @details
#' The pick_points function provides a shiny based interactive environment to inspect data points on a graph
#' and create new factors based on selected data. A basic data summary table is provided that updates as data
#' points are assigned to different factor levels. Useful for exploratory data analysis and quality assurance checks.
#' Any saved plot with drawn point generated with \code{bvt} or \code{NicePlots} can be used with this interface.
#'
#' @param data A saved plot of class npData (plots generated by bvt and NicePlots)
#' @param dataTable An optional table of phenotype data used to explore point and group characteristics
#' @param selectFillCol A valid R color used as the fill color for selected points
#' @param selectLineCol A valid R color used for the outline of selected points
#' @param selectSize A cex size of selected points
#'
#' @examples
#' data(iris)
#' a<-genePlot(t(iris[,1:4]), group=iris$Species)
#' #Note that devtools::check()  has issues shiny gadget returns
#' #newFactor is being assigned to Species just to let it compile
#' newFactor<-iris$Species
#' #newFactor<-pick_points(a)
#' summary(newFactor)
#' pairwise.wilcox.test(iris[,2],newFactor)
#'
#' @importFrom NicePlots setAlpha basicTheme
#' @importFrom graphics points
#' @importFrom stats median
#' @importFrom magrittr %>%
#' @importFrom dplyr group_by summarize bind_cols n ungroup filter
#' @importFrom tidyr pivot_longer spread
#' @importFrom purrr map_dbl
#' @importFrom rlang .data
#' @export
#' @seealso \code{\link[bvt]{genePlot}}
pick_points <- function(data,dataTable=NULL,selectFillCol=setAlpha("gold",0.6),selectLineCol=setAlpha("darkgoldenrod1",0.9),selectSize=1.5) {

  #Make sure shiny and miniUI are available to load or stop and throw a warning message
  if(requireNamespace("shiny",quietly = TRUE) & requireNamespace("miniUI",quietly = TRUE) == FALSE){
    stop("Missing required libraries for interactive shiny UI. Please install shiny and miniUI.")
  }

  #make sure the input data is for the right class (ie has any chance of working)
  if(! "npData" %in% class(data)) {
    stop("pick_points only works with graphs generated by bvt and NicePlots.")
  }

  #make sure the plot type is compatible with pick_points
  if(data$plotType=="bar") {
    stop("This function only supports graphs were inditidual data points are draw.\nUse the plotType option to change the plot type to something other than bar plots.")
  } else if(data$plotType=="density") {
    if(is.vector(data$options$x) | is.factor(data$options$x)) {
      stop("Pick points only supports 2D density plots at this time.")
    } else if (ncol(data$options$x)!=2) {
      stop("Pick points can not currently support 3D surface/perpective plots or standard kernal density plots of a single variable.")
    }
  }

  #Establishing if there are any point color factors active in the graph.
  #Sets up a Group 1/Group2 Defaults there are none.
  #Note that 2D density plots and scatter plots need special handling here
  tFact<-1
  dfilter<-1
  if(is.vector(data$options$x) | is.factor(data$options$x)){
    dfilter<- seq(length(data$options$x)) %in% data$options$xypos$ID
  } else {
    dfilter<- seq(nrow(data$options$x)) %in% data$options$xypos$ID
  }
  if(data$plotType=="scatter") {
    if(data$options$color==FALSE | is.null(data$options$color)) {
      tFact<-factor(rep("Group 1",length(unique(data$options$xypos$ID))))
      levels(tFact)<-c("Group 1", "Group 2")
    } else {
      if(is.vector(data$options$by) | is.factor(data$options$by)) {
        tFact<-factor(data$options$by[dfilter])
      } else {
        tFact<-factor(data$options$by$color)[dfilter]
      }
    }
  } else {
    if(data$options$pointHighlights==FALSE) {
      tFact<-factor(rep("Group 1",length(unique(data$options$xypos$ID))))
      levels(tFact)<-c("Group 1", "Group 2")
    } else {
      if(is.vector(data$options$by) | is.factor(data$options$by)) {
        tFact<-factor(data$options$by[dfilter])
      } else {
        if(data$plotType=="density"){
          tFact<-factor(data$options$by[,1])
        } else {
          if(data$options$subgroup==TRUE) {
            tFact<-factor(data$options$by[dfilter,min(3,ncol(data$options$by))])
          } else {
            tFact<-factor(data$options$by[dfilter,min(2,ncol(data$options$by))])
          }
        }
      }
    }
  }

  #Begin UI layout section
  ui <- miniUI::miniPage(
    miniUI::gadgetTitleBar(paste("Select points")),
    miniUI::miniContentPanel(padding = 0,
      shiny::uiOutput("UIplot1"),
      shiny::fillRow(height = "65px", style = "background-color:#BEBEBE33;",flex=c(1,2,2,2),
        shiny::fillCol(style = "margin-top: 25px;",
          shiny::actionButton("clearSelection",label="Clear",icon=shiny::icon("ban"),width="95%")
        ),
        shiny::fillCol(style = "margin-top: 25px;",
          shiny::actionButton("Select",label="Select",icon=shiny::icon("check-circle"),width="95%")
        ),
        shiny::fillCol(
          shiny::selectInput("groupLevels",label="Select Level",choices = if(any(as.character(tFact) != "Group 1")){tFact}else{c("Group 1", "Group 2")}, selected=if(any(as.character(tFact) != "Group 1")){as.character(tFact[1])}else{"Group 2"},width="95%")
        ),
        shiny::fillCol(
          shiny::textInput("groupLabels", label="Level Name", value=if(any(as.character(tFact) != "Group 1")){as.character(tFact[1])} else {"Group 2"}, width="95%")
        )
      ),
      shiny::fillRow(height = "65px", style = "background-color:#BEBEBE33;",flex=c(1,2,2,2),
        shiny::fillCol(style = "margin-top: 25px;",
          shiny::br()
        ),
        shiny::fillCol(
          shiny::actionButton("newGroup",label="New Group",icon=shiny::icon("plus-square"),width="95%")
        ),
        shiny::fillCol(
          shiny::actionButton("addToGroup",label="Add to Level",icon=shiny::icon("arrow-right"),width="95%")
        ),
        shiny::fillCol(
          shiny::actionButton("delGroup",label="Remove Level",icon=shiny::icon("trash-alt"),width="95%")
        )
      ),
      shiny::h4("Data Point Inspector"),
      shiny::fillRow(height = "40px",
        shiny::fillCol(
          shiny::textOutput("Inspector")
        )
      ),
      shiny::h4("Factor Summary Table"),
      shiny::fillRow(style="background-color: #FFFFFFFF",flex=1,
        shiny::fillCol(
          shiny::tableOutput("FactorStats")
        )
      )
    )
  )


  #Begin reactive server section
  server<-function(input, output, session) {
    #The point group variable will track selected and assigned data points
    pointGroup<-shiny::reactiveValues()
    pointGroup$selected<-rep(FALSE,nrow(data$options$xypos))
    pointGroup$pGroup<-tFact
    pointGroup$cHighlight<-1

    #Reactive brush object. Returns selected samples when brushed() is called.
    brushed<-shiny::reactive({
      bpoints<-shiny::brushedPoints(data$options$xypos, xvar = "x", yvar="y", input$brush, allRows = TRUE)$selected_
      sIDS<-unlist(unique(data$options$xypos$ID[bpoints]))
    })

    #Sets of an active observer for plot clicks allowing them to toggle the selection status of a point
    #This is tracked by pointGroup$selected
    shiny::observe({
      input$plot_click
      npoint<-shiny::nearPoints(data$options$xypos,  xvar = "x", yvar="y", allRows=T, coordinfo=input$plot_click,maxpoints=1)$selected_
      if(!is.null(npoint)){
        shiny::isolate({
          sID<-data$options$xypos$ID[npoint]
          pointGroup$selected[which(data$options$xypos$ID == sID)] <- !pointGroup$selected[which(data$options$xypos$ID == sID)]
        })
      }
    })

    #Sets up an active hover observer that reports the nearest point data to the text output field "Inspector"
    shiny::observe({
      input$hover
      npoint<-shiny::nearPoints(data$options$xypos,  xvar = "x", yvar="y", allRows=T, coordinfo=input$hover,maxpoints=1)$selected_
      if(!is.null(npoint)){
        IDpos<-as.numeric(data$options$xypos$ID[npoint])
        ID<-data$options$xypos$ID[npoint]
        if(!is.null(rownames(data$options$x))){
          ID<-rownames(data$options$x)[IDpos]
        }
        value<-if(is.vector(data$options$x)){
            paste0("Expression = ", data$options$x[IDpos])
          } else {
            paste(colnames(data$options$x), round(data$options$x[IDpos,],4), sep=" = ", collapse=", ")
          }
        output$Inspector<-shiny::renderText(paste0("ID = ",ID,", Group = ",as.character(pointGroup$pGroup)[IDpos],", ",value))
      }
    })

    #plot rendering instructions
    output$plot1<-shiny::renderPlot({
      if(is.vector(data$options$x)){
        cHighlight<-rep(NA,length(data$options$x))
      } else {
        cHighlight<-rep(NA,nrow(data$options$x))
      }
      cHighlight[dfilter]<- as.character(pointGroup$pGroup)
      cHighlight<-factor(cHighlight, levels=levels(pointGroup$pGroup))
      pointGroup$cHighlight<-cHighlight
      if(data$plotType=="scatter") {
        geneScatter(data,pointSize=0, RSOverride=TRUE, color = cHighlight, legend="Legend")
      } else {
        genePlot(data,pointSize=0, RSOverride=TRUE, highlight = cHighlight, legend="Legend")
      }
      bIDs<-brushed()
      bSelected<-data$options$xypos$ID %in% bIDs
      points(data$options$xypos[,1:2], pch=16, col=data$options$theme$plotColors$points[cHighlight[dfilter]])
      points(data$options$xypos[pointGroup$selected | bSelected,1:2], bg=selectLineCol,col=selectFillCol,pch=21, cex=selectSize)
    }
    )

    #By wrapping the plot element in a renderUI, it helps it conform to the natural plot size.
    #This helped keep plots from appearing too squished.
    output$UIplot1 <- shiny::renderUI({
      shiny::plotOutput("plot1",
        width="100%",
        brush = "brush", hover = "hover", click="plot_click")
    })

    #Render data summary table based on user defined groups
    output$FactorStats<-shiny::renderTable(
      bind_cols(data$options$x, factor=data$options$by,Group=pointGroup$cHighlight) %>%
        filter(!is.na(.data$Group)) %>%
        pivot_longer(cols=if(is.vector(data$options$x)){1}else{seq(ncol(data$options$x))}, names_to = "Feature",values_to="Expression") %>%
        group_by(.data$Group,.data$Feature) %>%
        summarize(N=n(),Median_Expression=paste0(round(median(.data$Expression,na.rm=TRUE),3)," (",round(min(.data$Expression,na.rm=TRUE),3), "-",round(max(.data$Expression,na.rm=TRUE),3),")"), .groups = 'drop') %>%
        ungroup() %>%
        spread(key=.data$Feature,value=.data$Median_Expression)
    )

    #unselect all points
    shiny::observeEvent(input$clearSelection, {
      pointGroup$selected <- rep(FALSE,nrow(data$options$xypos))
    })

    #adds points selected by the brush zone to the list of selected points
    #Otherwise the points be become unselected when the brush zone moves
    shiny::observeEvent(input$Select, {
      bIDs<-brushed()
      pointGroup$selected[data$options$xypos$ID %in% bIDs] <- TRUE
    })

    #Pull down of available group levels. Selects which level is currently active
    shiny::observeEvent(input$groupLevels, {
      cSel<-shiny::renderText(input$groupLevels)
      shiny::updateTextInput(session,inputId = "groupLabels", val=cSel())
    })

    #Name of selected group level. Changing the text changes the level name
    shiny::observeEvent(input$groupLabels, {
      newName<-shiny::renderText(input$groupLabels)
      oldName<-shiny::renderText(input$groupLevels)
      if(!is.null(newName())) {
        if(newName() != oldName() & newName() != "" & !newName() %in% levels(pointGroup$pGroup) ) {
          cLab<-levels(pointGroup$pGroup)
          cLab[which(cLab==oldName())]<-newName()
          levels(pointGroup$pGroup)<-cLab
          shiny::updateSelectInput(session,inputId = "groupLevels", choices=levels(pointGroup$pGroup),selected = newName())
        }
      }
    })

    #Adds a new group level
    shiny::observeEvent(input$newGroup, {
      levels(pointGroup$pGroup)<-c(levels(pointGroup$pGroup),paste0("Group ",length(levels(pointGroup$pGroup))+1))
      shiny::updateSelectInput(session,inputId = "groupLevels", choices=levels(pointGroup$pGroup), selected = paste0("Group ",length(levels(pointGroup$pGroup))))
    })

    #Assigns the selected points to the active group and reseets the selection vector
    shiny::observeEvent(input$addToGroup, {
      cLevel<-shiny::renderText(input$groupLevels)
      bIDs<-brushed()
      bSelected<-as.character(data$options$xypos$ID) %in% as.character(bIDs)
      filter<-bSelected | pointGroup$selected
      filter<-map_dbl(unique(data$options$xypos$ID[filter]),function(x) min(grep(x,data$options$xypos$ID)))
      newFactor<-as.character(pointGroup$pGroup)
      newFactor[filter]<-cLevel()
      newLevels<-levels(pointGroup$pGroup)
      if(! cLevel() %in% newLevels) {newLevels<-c(newLevels,cLevel())}
      pointGroup$pGroup<-factor(newFactor,levels=newLevels)
      pointGroup$selected <- rep(FALSE,nrow(data$options$xypos))
    })

    #Delete the active group level. Any points assigned to this level are moved to the first group
    shiny::observeEvent(input$delGroup, {
      dLevel<-shiny::renderText(input$groupLevels)
      cLevels<-levels(pointGroup$pGroup)
      if(length(cLevels)>1) {
        cLevels<-cLevels[cLevels!=dLevel()]
        tfact<-as.character(pointGroup$pGroup)
        tfact[which(as.character(pointGroup$pGroup)==dLevel())]<-cLevels[1]
        tfact<-factor(tfact)
        levels(tfact)<-cLevels
        pointGroup$pGroup<-tfact
        shiny::updateSelectInput(session,inputId = "groupLevels", choices=levels(pointGroup$pGroup), selected = levels(pointGroup$pGroup)[1])
      }
    })

    shiny::observeEvent(input$cancel, {
      shiny::stopApp(NULL)
    })

    #Returns the user defined vector
    shiny::observeEvent(input$done, {
      shiny::stopApp(returnValue = invisible(pointGroup$cHighlight))
    })
  }
  viewer<-shiny::dialogViewer(dialogName = "Interactive Data Inpector and Factor Creator",height = 2000)
  shiny::runGadget(ui, server, viewer = viewer)
}