R/gatingModules.R

In laderast/flowDashboard: Shiny Modules for Building interactive Dashboards for flow cytometry analysis

#' Title
#'
#' @param GO
#' @param objId
#'
#' @return
#' @export
#'
#' @examples
gatingModuleUIFromGO <- function(GO, objId=NULL){

  if(is.null(objId)){
    objId <- GO$objId
  }

  gatingModuleUI(id=objId, popSubsets = GO$popSubsets)

}

#' Title
#'
#' @param id unique identifier for object
#' @param label unique name for UI module
#' @param sortConditions
#' @param subsetCondition
#' @param annotation
#'
#' @return
#' @export
#'
#' @examples
gatingModuleUI <- function(id, label = "gatingModule", popSubsets){

    ns <- NS(id)

    div(style = 'overflow-x: scroll',
    tagList(
    # checkboxGroupInput("panelDisplayPop", label="Show Panel",
    #                    choices=c("1", "3"), selected=c("1","3")),
    #uiOutput(ns("gatingDynamicUI")),
    #fluidRow(
    shinydashboard::box(
      absolutePanel(id=ns("gating"), draggable=TRUE,top=0,
                    fixed=FALSE,
                    style="opacity: 0.8; background-color: white",
                    height=200,width="auto",
                    h4("Gating Scheme (draggable)"),
                    imageOutput(ns("gating"))),
      width=12, height=225#)
    ),
    #fluidRow(
    shinydashboard::box(
      #absolutePanel(id=ns("heatmap"),
                    h4("Population Heatmap (Click on box to see provenance)"),
                    selectInput(ns("ps"), "Select Cellular Subsets", choices=names(popSubsets),
                                selected=names(popSubsets)[1]),
                   #plotOutput(ns("popHeatmap"), click = clickOpts(id=ns("clickGate"), clip=TRUE),
                    #          hover=hoverOpts(id=ns("hoverGate"), clip=TRUE,delay = 300,
                     #                         delayType="debounce")),
                  plotlyOutput(ns("popHeatmap2")),

                  uiOutput(ns("clickTipG")),
                  uiOutput(ns("hoverTipG")),
                  width=12

      ) #,
                   #)

    # absolutePanel(id="scheme",imageOutput(ns("pipelineHierarchy")), top=250, left=650),

    ))
}



#' Title
#'
#' @param input
#' @param output
#' @param session
#' @param GO
#' @param annotation
#' @param objId
#' @param plotObj
#'
#' @return
#' @export
#'
#' @examples
gatingModuleOutputGGFromGO <- function(input, output, session, GO, annotation, objId=NULL){

  if(is.null(objId)){

    objId <- GO$objId
  }

  plotObj <- reactiveValues(gating="")

  callModule(gatingModuleGGOutput, id=objId, popTable = GO$popTable, annotation=annotation,
             imageDir = GO$imageDir, displayNodes =GO$populations, plotObj=plotObj,
             popSubsets=GO$popSubsets, annotCols=GO$annotCols,
             mapVar=GO$mapVar, objId=GO$objId)

}


padMissingValues <- function(popTable){
  populations <- unique(as.character(popTable[["Population"]]))
  samples <- unique(as.character(popTable[["notation"]]))
  expand.grid(populations, samples)

}


#' Output module for popHeatmapGG
#'
#' @param input - Shiny input object
#' @param output - Shiny
#' @param session - Shiny
#' @param imageDir - image directory for gating images
#' @param popTable - population table
#' @param displayNodes - populations to show in shiny UI. Derived from `gatingObj`
#' @param annotation - annotation. Usually derived from `gatingObj`
#' @param annotCols - column names in annotation to expose
#' @param plotObj - reactive data object that contains the gating graph to display
#' (generated by `gatingModuleOutputGGFromGO`)
#' @param popSubsets - named list of population subsets. Each slot should contain
#' a vector of populations in displayNodes
#' @param mapVar - single named character that maps popTable into annotation.
#'
#' @return shiny output module
#' @export
#'
#' @examples
gatingModuleGGOutput <- function(input, output, session,
                               imageDir, popTable, displayNodes,
                               annotation, annotCols, plotObj,
                               popSubsets, objId,
                               mapVar){

  pngGraph <- reactive({
    #print(plotObj2[["gating"]])
    print(plotObj[["gating"]])
    return(plotObj[["gating"]])
  })

  output$gating <- renderImage({
    list(src = pngGraph(),
         contentType = "image/png"
    )
  },deleteFile=FALSE)

  popSubset <- reactive({
    popSubset <- popSubsets[[1]]

    if(!is.null(input$ps)){
      popSubset <- popSubsets[[input$ps]]
    }
    popSubset
  })


  outDat <- reactive({
    #if(is.null(input$ps)){return(NULL)}
    if(is.null(input$ps))
      {popSubset <- "all"}
    else{
      popSubset <- input$ps
      }
    ##need to add sort by levels
    ##popsubset is affecting the xcols here
    outDat <- popTable[annotation(), on=mapVar]#[!is.na(percentPop)]

    #if(!is.null(popSubset)){
      outDat <- outDat[Population %in% popSubset()]
    #}
    outDat
  })

  outDataXColNames <- reactive({
    as.character(unique(outDat()$name))
  })

  outDataXColsNum <- reactive({
    length(unique(outDat()$name))
  })

  outDataYColNames <- reactive({
    as.character(unique(outDat()$Population))
  })

  output$popHeatmap <- renderPlot({
      popHeatmapGG(outDat())
  })


  output$popHeatmap2 <- renderPlotly({
    l <- ggplotly(popHeatmapGG(outDat(),text = TRUE),
                  source="popHeatmap2", tooltip=c("text"))
    l$x$layout$width <- NULL
    l$x$layout$height <- NULL
    l$width <- NULL
    l$height <- NULL
    l
  })


  # output$clickTipG <- renderUI({
  #   click <- input$clickGate
  #
  #   if(is.null(click$x)){
  #     return(NULL)
  #   }
  #
  #   point <- findPointsGeomTile(click, data=outDat(), xcol = outDataXColNames(),
  #                               ycol=outDataYColNames(), ps=popSubset())
  #
  #   outClick <- paste0(imageDir, point$idVar, ".png")
  #   plotObj[["gating"]] <- outClick
  #   #print(outClick)
  #   return(NULL)
  # })

  output$clickTipG <- renderUI({
    click <- event_data("plotly_click", source="popHeatmap2")

    name_value <- levels(outDat()$name)[click[["x"]]]
    pop_value <- rev(outDat()$Population[outDat()$Population %in% popSubset()])[click[["y"]]]

    print(name_value)
    print(pop_value)

    idVar <- outDat() %>% filter(name == name_value & Population == pop_value) %>%
      pull(idVar)

#    if(is.null(click$x)){
#      return(NULL)
#    }
    print(idVar)

    outClick <- paste0(imageDir, idVar, ".png")
    plotObj[["gating"]] <- outClick
    #print(outClick)
    return(NULL)
  })



  ##need to add hovertips
  output$hoverTipG <- renderUI({

    hover <- input$hoverGate

    if(is.null(hover$x)){
      return(NULL)
    }

    #print(hover)

    point <- findPointsGeomTile(hover, data=outDat(), xcol = outDataXColNames(),
                                ycol=outDataYColNames(),ps=popSubset())

    outputString <- makeOutputString(point, annotCols)
    #print(outputString)

    left_pct <- (hover$x - hover$domain$left) / (hover$domain$right - hover$domain$left)
    top_pct <- (hover$domain$top - hover$y) / (hover$domain$top - hover$domain$bottom)

    # calculate distance from left and bottom side of the picture in pixels
    left_px <- hover$range$left + left_pct * (hover$range$right - hover$range$left)
    top_px <- hover$range$top + top_pct * (hover$range$bottom - hover$range$top)

    # create style property fot tooltip
    # background color is set so tooltip is a bit transparent
    # z-index is set so we are sure are tooltip will be on top
    style <- paste0("position:absolute; z-index:100; background-color: rgba(245, 245, 245, 0.85); ",
                    "left:", left_px + 2, "px; top:", top_px + 2, "px;")

    # actual tooltip created as wellPanel
    wellPanel(
      style = style,
      p(HTML(outputString))
    )

    #return(NULL)
  })



  }

#' Title
#'
#' @param data
#' @param annotation
#' @param mapVar
#'
#' @return
#' @export
#'
#' @examples
popHeatmap <- function(data, annotation, mapVar=c("name"="FCSFiles")){

  dataNew <- data[annotation, on=mapVar]
  dataNew <- data[!is.na(percentPop)]

  domY <- unique(as.character(data[["Population"]]))
  displayNodes <- domY
  noMarkers <- length(displayNodes)

  domX <- unique(as.character(data[["name"]]))
  noSamples <- length(domX)

  Green <- colorRampPalette(c("green","green4"))
  Red <- colorRampPalette(c("red4","red"))

  levs <- sort(unique(round(data$zscore)))

  #print(levs)

  belowAverage <- length(which(levs < 0))
  aboveAverage <- length(which(levs > 0))

  pal <- c(Green(belowAverage), "000000", Red(aboveAverage))

  #pal <- c(Blue(3), "#E5E5E5", Orange(6))

  dataNew[Population %in% displayNodes] %>%
    #mutate()
    #filter(as.character(Population) %in% displayNodes) %>%
    ggvis(x=~name,y= ~Population, fill=~factor(round(zscore))) %>%
    #ggvis(x=~name,y= ~Population, fill=~factor(round(Count))) %>%
    layer_rects(height = band(), width = band(), key:=~idVar) %>%
    scale_ordinal('fill',range = pal) %>%
    add_axis("x", properties = axis_props(labels = list(angle = 270)), orient="top",
             title_offset = 120, tick_padding=40, title="Sample") %>%
    add_axis("y", orient="left", title_offset = 100) %>%
    #add_tooltip(popTooltip,on="click") %>%
    #add_tooltip(popInfoTooltip, on="hover") %>%
    scale_nominal("y", padding = 0, points = FALSE, domain = displayNodes) %>%
    #scale_nominal("x", padding = 0, points = FALSE, domain = domX) %>%
    scale_nominal("x", padding = 0, points = FALSE) %>%
    layer_text(text:=~signif(percentPop,digits=2), stroke:="darkgrey", align:="left",
               baseline:="top", dx := 5, dy:=5) %>%
    set_options(width= max(c(60 * (noSamples), 600)), height= max(60 *(noMarkers), 700))

}




#' Title
#'
#' @param data
#' @param mapVar
#'
#' @return
#' @export
#'
#' @examples
popHeatmapGG <- function(data, text=TRUE, xVar=NULL, yVar=NULL, fillVar=NULL, idVar="idVar"){

  #dataNew <- data[annotation, on=mapVar]
  dataNew <- data#[!is.na(percentPop)]
  dataNew$Population <- fct_rev(factor(dataNew$Population,
                                       levels=unique(dataNew$Population)))

  domY <- unique(as.character(data[["Population"]]))
  displayNodes <- domY
  noMarkers <- length(displayNodes)

  domX <- unique(as.character(data[["name"]]))
  noSamples <- length(domX)

  Green <- colorRampPalette(c("green","green4"))
  Red <- colorRampPalette(c("red4","red"))

  levs <- sort(unique(round(data$zscore)))

  #print(levs)

  belowAverage <- length(which(levs < 0))
  aboveAverage <- length(which(levs > 0))

  pal <- c(Green(belowAverage), "000000", Red(aboveAverage))

  #pal <- c(Blue(3), "#E5E5E5", Orange(6))

  #outData <- dataNew[Population %in% displayNodes]

  outData <- dataNew

  if(is.null(xVar)){
    xVar <- "name"
  }

  if(is.null(yVar)){

    yVar <- "Population"
  }

  if(is.null(fillVar)){
    fillVar = "fillVals"
  }

  outPlot <- outData %>%
    mutate(fillVals = round(zscore)) %>%
    mutate(percentPop=signif(percentPop,digits = 2), text=paste0("<b>Population</b>: ",
                                                                 Population, "\n", "<b>Parent:</b> ", Parent, "\n",
                                                                 "<b>Percent Parent:</b> ", percentPop , "%\n",
                                                                 "<b>Count: </b>", Count, "\n",
                                                                 "<b>Parent Count: ", ParentCount)) %>%
    ggplot(aes_string(x=xVar, y=yVar, fill=fillVar, idVar=idVar, text="text")) +
    geom_tile(colour="black") +
    scale_fill_gradient2(low = "green", mid="Black", high = "red") +
    scale_y_discrete() + theme(axis.text.x = element_text(angle=90))

  if(text){
    outPlot <- outPlot +
      geom_text(aes(label=percentPop), color="white", size=3, label.padding=0.4)
  }
  outPlot
}