R/beidsModule.R

In patzaw/BED: Biological Entity Dictionary (BED)

###############################################################################@
## Helpers (not exported) ----

#' @importFrom shiny callModule
moduleServer <- function(id, module){
   shiny::callModule(module, id)
}

highlightText <- function(
   text, value,
   style = "background-color:yellow; font-weight:bold;",
   class = "bed-search"
){
   style <- paste(c(style, ";"), collapse = "; ")
   style <- gsub(";[[:blank:]]*;", ";", style)
   if(!grepl("padding", style)){
      style <- paste(style, "padding:0;")
   }
   value <- sub('^"', '', sub('"$', '', value))
   value <- gsub("[[:punct:]]", ".?", value)
   return(unlist(lapply(
      text,
      function(x){
         if(is.na(x)){
            return(x)
         }
         p <- gregexpr(value, x, ignore.case=TRUE)[[1]]
         if(p[1]>0){
            toRet <- c(substr(x, 0, p[1]-1))
            for(i in 1:length(p)){
               toRet <- c(
                  toRet,
                  sprintf(
                     '<mark class="%s" style="%s">',
                     class, style
                  ),
                  substr(x, p[i], p[i]+attr(p, "match.length")[i]-1),
                  '</mark>',
                  substr(
                     x,
                     p[i]+attr(p, "match.length")[i],
                     min(
                        p[i+1]-1,
                        nchar(x)+1,
                        na.rm=TRUE
                     )
                  )
               )
            }
            toRet <- paste(toRet, collapse="")
         }else{
            toRet <- x
         }
         return(toRet)
      }
   )))
}

###############################################################################@
## Module ----

#' Shiny module for searching BEIDs
#'
#' @param id an identifier for the module instance
#' @param toGene focus on gene entities (default=TRUE): matches from other
#' BE are converted to genes.
#' @param excludeTechID do not display BED technical BEIDs
#' @param multiple allow multiple selections (default=FALSE)
#' @param beOfInt if toGene == FALSE, BE to consider (default=NULL ==> all)
#' @param selectBe if toGene == FALSE, display an interface for selecting BE
#' @param orgOfInt organism to consider (default=NULL ==> all)
#' @param selectOrg display an interface for selecting organisms
#' @param groupBySymbol if TRUE also use gene symbols to aggregate results with
#' more granularity (taken into account only when toGene == TRUE)
#' @param searchLabel display label for the search field or NULL for no label
#' @param matchColname display name of the match column
#' @param selectFirst if TRUE the first row is selected by default
#' @param oneColumn if TRUE the hits are displayed in only one column
#' @param withId if FALSE and one column, the BEIDs are not shown
#' @param maxHits maximum number of raw hits to return
#' @param compact compact display (default: FALSE)
#' @param tableHeight height of the result table (default: 150)
#' @param highlightStyle style to apply to the text to highlight
#' @param highlightClass class to apply to the text to highlight
#'
#' @return A reactive data.frame with the following columns:
#' - **beid**: the BE identifier
#' - **preferred**: preferred identifier for the same BE in the same scope
#' - **be**: the type of biological entity
#' - **source**: the source of the identifier
#' - **organism**: the BE organism
#' - **entity**:  internal identifier of the BE
#' - **match**: the matching character string
#'
#' @examples \dontrun{
#' library(shiny)
#' library(BED)
#' library(DT)
#'
#' ui <- fluidPage(
#'    beidsUI("be"),
#'    fluidRow(
#'       column(
#'          12,
#'          tags$br(),
#'          h3("Selected gene entities"),
#'          DTOutput("result")
#'       )
#'    )
#' )
#'
#' server <- function(input, output){
#'    found <- beidsServer("be", toGene=TRUE, multiple=TRUE, tableHeight=250)
#'    output$result <- renderDT({
#'       req(found())
#'       toRet <- found()
#'       datatable(toRet, rownames=FALSE)
#'    })
#' }
#'
#' shinyApp(ui = ui, server = server)
#' }
#'
#' @importFrom shiny reactive renderUI observe fluidRow column textInput NS selectizeInput reactiveValues withProgress req
#' @importFrom DT datatable DTOutput renderDT formatStyle styleEqual
#' @importFrom htmltools tagQuery
#' @importFrom stats setNames
#' @export
#'
beidsServer <- function(
   id,
   toGene=TRUE,
   excludeTechID=FALSE,
   multiple=FALSE,
   beOfInt=NULL, selectBe=TRUE,
   orgOfInt=NULL, selectOrg=TRUE,
   groupBySymbol = FALSE,
   searchLabel = "Search a gene",
   matchColname = "Match",
   selectFirst = FALSE,
   oneColumn = FALSE,
   withId = FALSE,
   maxHits = 75,
   compact = FALSE,
   tableHeight=150,
   highlightStyle = "", # "background-color:yellow; font-weight:bold;",
   highlightClass = "bed-search"
){
   symbolStyle <- paste(
      "text-decoration: underline;",
      "font-weight:bold;",
      "background-color:transparent"
   )
   if(toGene){
      selectBe <- FALSE
      beOfInt <- c(listBe(), "Probe")
   }
   moduleServer(id, function(input, output, session) {

      ## Main UI ----
      allOrg <- sort(listOrganisms())
      allBe <- c(listBe(), "Probe")
      ni <- 1
      if(selectOrg){
         ni <- ni+1
      }
      if(selectBe){
         ni <- ni+1
      }
      cw <- 12 %/% ni
      output$mainUI <- shiny::renderUI({
         shiny::fluidRow(shiny::column(12,
            shiny::fluidRow(
               shiny::column(
                  cw,
                  htmltools::tagQuery(
                     shiny::textInput(
                        inputId=shiny::NS(id, "beSearchTerm"),
                        label=searchLabel,
                        placeholder=
                           'e.g. snca, ENSG00000186868, "M-CSF receptor"',
                        width="100%"
                     )
                  )$find("input")$addAttrs("autocomplete" = "off")$allTags()
               ),
               if(selectBe){
                  shiny::column(
                     cw,
                     shiny::selectizeInput(
                        inputId=shiny::NS(id, "beFocus"),
                        label="Focus on BE",
                        choices=allBe,
                        selected=beOfInt,
                        multiple=TRUE,
                        width="100%"
                     )
                  )
               },
               if(selectOrg){
                  shiny::column(
                     cw,
                     shiny::selectizeInput(
                        inputId=shiny::NS(id, "beOrganisms"),
                        label="Focus on organisms",
                        choices=allOrg,
                        selected=orgOfInt,
                        multiple=TRUE,
                        width="100%"
                     )
                  )
               }
            ),
            shiny::fluidRow(
               shiny::column(
                  12,
                  DT::DTOutput(
                     shiny::NS(id, "searchRes")
                  )
               )
            )
         ))
      })

      ## Application state ----
      appState <- shiny::reactiveValues(
         ## User choices
         orgOfInt=orgOfInt,
         beOfInt=beOfInt,
         ## Matches
         matches=NULL,
         genes=NULL,
         ## Filtered matches
         fmatches=NULL,
         fgense=NULL,
         geneEntity=NULL,
         ## Selection
         sel=NULL
      )

      ## Select organisms ----
      if(selectOrg){
         shiny::observe({
            selOrg <- input$beOrganisms
            if(length(selOrg)==0){
               appState$orgOfInt <- allOrg
            }else{
               appState$orgOfInt <- selOrg
            }
            appState$sel <- NULL
         })
      }

      ## Select BE ----
      if(selectBe){
         shiny::observe({
            selBe <- input$beFocus
            if(length(selBe)==0){
               appState$beOfInt <- allBe
            }else{
               appState$beOfInt <- selBe
            }
            appState$sel <- NULL
         })
      }

      ## Search a given term ----
      shiny::observe({
         v <- input$beSearchTerm
         if(is.null(v)){
            m <- g <- NULL
         }else{
            shiny::withProgress(
               message="Searching genes",
               value=0,
               style="notification",
               expr={
                  suppressMessages({
                     m <- tryCatch(
                        searchBeid(v, maxHits=maxHits),
                        error = function(e) NULL
                     )
                  })
               }
            )
            if(is.null(m) || nrow(m)==0){
               m <- g <- NULL
            }else{
               if(excludeTechID){
                  m <- dplyr::filter(
                     m,
                     !stringr::str_detect(.data$source, "^BEDTech_")
                  )
               }
               .data <- NULL
               g <- dplyr::mutate(m, order=1:nrow(m))
               if(excludeTechID){
                  g <- dplyr::filter(
                     g,
                     !stringr::str_detect(.data$Gene_source, "^BEDTech_")
                  )
               }
               g <- dplyr::mutate(
                  g, url=getBeIdURL(.data$GeneID, .data$Gene_source)
               )
               if(groupBySymbol){
                  g <- dplyr::group_by(
                     g, .data$Gene_entity, .data$organism, .data$Gene_symbol
                  )
               }else{
                  g <- dplyr::group_by(
                     g, .data$Gene_entity, .data$organism
                  )
               }
               g <- dplyr::summarise(
                  g,
                  order=min(.data$order),
                  # value=ifelse(
                  #    length(unique(.data$value)) <= 1,
                  #    paste(unique(.data$value), collapse=", "),
                  #    paste(
                  #       c(head(unique(.data$value), 1), "..."),
                  #       collapse=", "
                  #    )
                  # ),
                  value = .data$value[1],
                  from=paste(unique(ifelse(
                     .data$from %in% c("BESymbol", "BEName"),
                     stringr::str_replace(
                        .data$from, "^BE", paste(.data$be, " ")
                     ),
                     sprintf(
                        '%s%s',
                        .data$from,
                        ifelse(
                           !is.na(.data$symbol),
                           ifelse(
                              !is.na(.data$name),
                              sprintf(': %s (%s)', .data$symbol, .data$name),
                              sprintf(': %s', .data$symbol)
                           ),
                           ifelse(
                              !is.na(.data$name),
                              sprintf(' (%s)', .data$name),
                              ''
                           )
                        )
                     )
                  )), collapse=", "),
                  symbol=paste(setdiff(.data$symbol, NA), collapse=" / "),
                  name=paste(setdiff(.data$name, NA), collapse=" / "),
                  GeneIDs=paste(unique(sprintf(
                     '<a href="%s" target="_blank">%s</a>',
                     url,
                     highlightText(
                        sprintf(
                           '%s%s%s',
                           ifelse(.data$preferred_gene, "<u><strong>", ""),
                           .data$GeneID,
                           ifelse(.data$preferred_gene, "</strong></u>", "")
                        ),
                        !!v,
                        style = highlightStyle, class = highlightClass
                     )
                  )[order(.data$preferred_gene, decreasing=T)]), collapse=","),
                  Gene_symbol=paste(
                     setdiff(.data$Gene_symbol, NA), collapse=" / "
                  ),
                  Gene_name=paste(
                     setdiff(.data$Gene_name, NA), collapse=" / "
                  ),
                  .groups = "drop"
               )
               g <- dplyr::arrange(g, .data$order)
               g <- dplyr::select(
                  g,
                  "value", "from",
                  "Gene_symbol", "Gene_name", "organism", "GeneIDs",
                  "Gene_entity"
               )
               g <- dplyr::ungroup(g)
            }
         }
         if(!is.null(m)){
            m <- dplyr::rename(m, "match"="value")
         }
         if(!is.null(g)){
            g <- dplyr::rename(g, "match"="value")
         }
         appState$matches <- m
         appState$genes <- g
         appState$sel <- NULL
      })

      ## Filter matches ----
      shiny::observe({
         fmatches <- appState$matches[
            which(
               appState$matches$organism %in% appState$orgOfInt &
                  appState$matches$be %in% appState$beOfInt
            ),
         ]
         if(!is.null(fmatches) && nrow(fmatches)==0){
            fmatches <- NULL
         }else{
            if(!toGene && !is.null(fmatches)){
               fmatches <- dplyr::distinct(dplyr::select(
                  fmatches,
                  "match", "from", "be", "beid", "source", "preferred",
                  "symbol", "name", "entity", "organism"
               ))
            }
         }
         fgenes <- appState$genes[
            which(
               appState$genes$organism %in% appState$orgOfInt
            ),
         ]
         if(!is.null(fgenes) && nrow(fgenes)==0){
            fgenes <- NULL
         }
         appState$fmatches <- fmatches
         appState$fgenes <- fgenes
         appState$sel <- NULL
      })

      ## Show the results ----
      output$searchRes <- DT::renderDataTable({
         v <- input$beSearchTerm
         if(toGene){
            toShow <- appState$fgenes
            shiny::req(toShow)
            toShow <- dplyr::select(
               dplyr::mutate(
                  toShow,
                  Match=highlightText(
                     .data$match, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  From=highlightText(
                     .data$from, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Symbol=highlightText(
                     .data$Gene_symbol, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Name=highlightText(
                     .data$Gene_name, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Organism=as.factor(.data$organism)
               ),
               "Match", # "From",
               "Symbol", "Name", "Organism", "GeneIDs",
            )
            if(oneColumn){
               if(withId){
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = ifelse(
                        stringr::str_detect(.data$Symbol, "</mark>") |
                           stringr::str_detect(.data$Name, "</mark>") |
                           stringr::str_detect(.data$GeneIDs, "</mark>"),
                        "",
                        .data$Match
                     ),
                     Symbol = paste0(
                        sprintf('<mark style="%s">', symbolStyle),
                        .data$Symbol, "</mark>"
                     )
                  )
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = paste(
                        .data$Match, .data$Symbol, .data$Name, .data$GeneIDs,
                        sep = " | "
                     )
                  )
               }else{
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = ifelse(
                        stringr::str_detect(.data$Symbol, "</mark>") |
                           stringr::str_detect(.data$Name, "</mark>"),
                        "",
                        .data$Match
                     ),
                     Symbol = paste0(
                        sprintf('<mark style="%s">', symbolStyle),
                        .data$Symbol, "</mark>"
                     )
                  )
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = paste(
                        .data$Match, .data$Symbol, .data$Name,
                        sep = " | "
                     )
                  )
               }
               toShow <- dplyr::select(
                  dplyr::mutate(
                     toShow,
                     Match = stringr::str_remove(
                        stringr::str_replace_all(
                           .data$Match,
                           "( [|] )+", " | "
                        ),
                        "^ [|] "
                     )
                  ),
                  "Match", "Organism"
               )
            }
         }else{
            toShow <- appState$fmatches
            shiny::req(toShow)
            toShow <- dplyr::select(
               dplyr::mutate(
                  toShow,
                  Match=highlightText(
                     .data$match, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  From=highlightText(
                     .data$from, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Symbol=highlightText(
                     .data$symbol, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Name=highlightText(
                     .data$name, !!v,
                     style = highlightStyle, class = highlightClass
                  ),
                  Organism=as.factor(.data$organism),
                  ID=sprintf(
                     '<a href="%s" target="_blank">%s</a>',
                     getBeIdURL(.data$beid, .data$source),
                     highlightText(
                        .data$beid, !!v,
                        style = highlightStyle, class = highlightClass
                     )
                  )
               ),
               "Match", # "From",
               "BE"="be", "Symbol", "Name", "Organism", "ID",
               "Source"="source", "Preferred"="preferred"
            )
            if(oneColumn){
               if(withId){
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = ifelse(
                        stringr::str_detect(.data$Symbol, "</mark>") |
                           stringr::str_detect(.data$Name, "</mark>") |
                           stringr::str_detect(.data$ID, "</mark>"),
                        "",
                        .data$Match
                     ),
                     Symbol = paste0(
                        sprintf('<mark style="%s">', symbolStyle),
                        .data$Symbol, "</mark>"
                     )
                  )
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = paste(
                        .data$Match,
                        .data$Symbol, .data$Name,
                        .data$ID,
                        sep = " | "
                     )
                  )
               }else{
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = ifelse(
                        stringr::str_detect(.data$Symbol, "</mark>") |
                           stringr::str_detect(.data$Name, "</mark>"),
                        "",
                        .data$Match
                     ),
                     Symbol = paste0(
                        sprintf('<mark style="%s">', symbolStyle),
                        .data$Symbol, "</mark>"
                     )
                  )
                  toShow <- dplyr::mutate(
                     toShow,
                     Match = paste(
                        .data$Match,
                        .data$Symbol, .data$Name,
                        sep = " | "
                     )
                  )
               }
               toShow <- dplyr::mutate(
                  toShow,
                  Match = stringr::str_remove(
                     stringr::str_replace_all(
                        .data$Match,
                        "( [|] )+", " | "
                     ),
                     "^ [|] "
                  )
               )
               toShow <- dplyr::select(
                  toShow,
                  "Match", "BE", "Organism", "Source", "Preferred"
               )
            }
         }
         if(!selectOrg && length(orgOfInt) == 1){
            toShow <- dplyr::select(toShow, -"Organism")
         }
         toShow <- DT::datatable(
            dplyr::rename(
               toShow, dplyr::all_of(stats::setNames("Match", matchColname))
            ),
            rownames=FALSE,
            escape=FALSE,
            class = ifelse(compact, "display compact", "display"),
            selection=list(
               mode=ifelse(multiple, "multiple",  "single"),
               selected = if(selectFirst) 1 else NULL,
               target="row"
            ),
            extensions = 'Scroller',
            options=list(
               dom="t",
               paging=TRUE,
               scrollResize=TRUE,
               scrollY=tableHeight,
               scroller = TRUE,
               scrollCollapse=TRUE
            )
         )
         if(!toGene){
            DT::formatStyle(
               toShow, "Preferred",
               backgroundColor=DT::styleEqual(
                  c(TRUE, FALSE), c('darkgreen', 'transparent')
               ),
               color=DT::styleEqual(
                  c(TRUE, FALSE), c('white', 'black')
               )
            )
         }else{
            toShow
         }
      })
      shiny::observe({
         appState$sel <- input$searchRes_rows_selected
      })

      ## Return the results ----
      return(shiny::reactive({
         sel <- appState$sel
         g <- appState$fgenes
         m <- appState$fmatches
         if(
            length(sel)==0 ||
            is.null(g) || nrow(g)==0 ||
            is.null(m) || nrow(m)==0
         ){
            return(NULL)
         }else{
            if(toGene){
               if(groupBySymbol){
                  ge <- dplyr::distinct(
                     g[sel, c("Gene_entity", "Gene_symbol")]
                  )
                  toRet <- dplyr::inner_join(
                     m[,c(
                        "GeneID", "preferred_gene", "Gene_source", "organism",
                        "Gene_entity", "Gene_symbol"
                     )],
                     ge,
                     by = c("Gene_entity", "Gene_symbol")
                  )
               }else{
                  ge <- unique(g$Gene_entity[sel])
                  toRet <- unique(m[
                     which(m$Gene_entity %in% ge),
                     c(
                        "GeneID", "preferred_gene", "Gene_source", "organism",
                        "Gene_entity", "Gene_symbol"
                     )
                  ])
               }
               colnames(toRet) <- c(
                  "beid", "preferred", "source", "organism", "entity", "symbol"
               )
               if(nrow(toRet)>0){
                  toRet$be <- "Gene"
                  if(groupBySymbol){
                     toRet <- dplyr::left_join(
                        toRet,
                        g[,c("Gene_entity", "Gene_symbol", "match")],
                        by=c(
                           "entity" = "Gene_entity",
                           "symbol" = "Gene_symbol"
                        )
                     )
                  }else{
                     toRet <- dplyr::left_join(
                        toRet,
                        g[,c("Gene_entity", "match")],
                        by=c("entity"="Gene_entity")
                     )
                  }
                  toRet <-  dplyr::distinct(toRet[, c(
                     "beid", "preferred", "be", "source", "organism",
                     "entity", "symbol", "match"
                  )])
               }
            }else{
               toRet <-  dplyr::distinct(m[
                  sel,
                  c(
                     "beid",  "preferred", "be", "source", "organism",
                     "entity", "match"
                  )
               ])
            }
            return(toRet)
         }
      }))
   })
}

###############################################################################@
#' @describeIn beidsServer
#'
#' @importFrom shiny uiOutput NS
#' @export
#'
beidsUI <- function(id) {
   shiny::tagList(
      shiny::tags$head(shiny::tags$style(shiny::HTML(
         'table.dataTable tr.selected td a {background-color: white !important;}'
      ))),
      shiny::uiOutput(outputId=NS(id, "mainUI"))
   )
}