R/add_source.R

In crossmeta: Cross Platform Meta-Analysis of Microarray Data

#' Add sample source information for meta-analysis.
#'
#' User selects a tissue source for each contrast and indicates any sources that
#' should be paired. This step is required if you would like to perform source-specific
#' effect-size/pathway meta-analyses.
#'
#'
#' The \strong{Sources} tab is used to add a source for each contrast. To do so: click the
#' relevant contrast rows, search for a source in the \emph{Sample source} dropdown box,
#' and then click the \emph{Add} button.
#'
#' The \strong{Pairs} tab is used to indicate sources that should be paired
#' (treated as the same source for subsequent effect-size and pathway meta-analyses). To do
#' so: select at least two sources from the \emph{Paired sources} dropdown box,
#' and then click the \emph{Add} button.
#'
#' For each GSE, analysis results with added sources/pairs are saved in the corresponding GSE
#' folder (in \code{data_dir}) that was created by \code{\link{get_raw}}.
#'
#' @import shiny miniUI
#'
#' @param diff_exprs Previous result of \code{\link{diff_expr}}, which can
#'    be reloaded using \code{\link{load_diff}}.
#' @param data_dir String specifying directory of GSE folders.
#'
#' @return Same as \code{\link{diff_expr}} with added slots for each GSE in \code{diff_exprs}:
#'    \item{sources}{Named vector specifying selected sample source for each contrast.
#'       Vector names identify the contrast.}
#'    \item{pairs}{List of character vectors indicating tissue sources that should be
#'       treated as the same source for subsequent effect-size and pathway meta-analyses.}
#'
#' @export
#'
#' @examples
#' library(lydata)
#'
#' # load result of previous call to diff_expr:
#' data_dir  <- system.file("extdata", package = "lydata")
#' gse_names <- c("GSE9601", "GSE34817")
#' anals     <- load_diff(gse_names, data_dir)
#'
#' # run shiny GUI to add tissue sources
#' # anals <- add_sources(anals, data_dir)
#'
add_sources <- function(diff_exprs, data_dir = getwd(), postfix = NULL) {
  
  # get source info for each contrast
  srclist <- list('GSE' = character(0),
                  'Contrast' = character(0),
                  'Supplied' = character(0),
                  'Source'   = character(0))
  
  # pairs info
  added_prs <- lapply(diff_exprs, function(anal) anal$pairs)
  added_prs <- unique(unlist(added_prs, recursive = FALSE, use.names = FALSE))
  
  # setup inital source list
  for (i in seq_along(diff_exprs)) {
    
    gse_name  <- names(diff_exprs[i])
    supld_src <- c()
    anal      <- diff_exprs[[i]]
    pdata     <- anal$pdata
    
    # get contrast names
    contrasts <- colnames(anal$ebayes_sv$contrasts)
    
    # find tissue/cell type column
    samplecol <- as.character(t(pdata[1, ]))
    is_src    <- grepl("tissue:|cell type:", samplecol)
    
    # user added sources
    added_src <- unname(anal$source)
    if (is.null(added_src))
      added_src <- rep(NA, length(contrasts))
    
    # get submitter supplied sources
    # if available and not Illumina (can only guarantee pdata$title)
    if (sum(is_src) == 1 & !'illum' %in% colnames(pdata)) {
      for (con in contrasts) {
        # contrast levels
        groups <- c(gsub('^.+?-', '', con),
                    gsub('-.+?$', '', con))
        
        # supplied sources
        con_src <- unique(as.character(pdata[pdata$group %in% groups, is_src]))
        con_src <- gsub("tissue: |cell type: ", "", con_src)
        con_src <- paste(con_src, collapse = ', ')
        
        supld_src <- c(supld_src, con_src)
        
      }
    } else {
      supld_src <- rep("N/A", length(contrasts))
    }
    
    # add info to srclist
    srclist$GSE <- c(srclist$GSE, rep(gse_name, length(contrasts)))
    srclist$Contrast <- c(srclist$Contrast, contrasts)
    srclist$Supplied <- c(srclist$Supplied, supld_src)
    srclist$Source   <- c(srclist$Source,   added_src)
  }
  
  # get sources/pairs info from user
  srcdf  <- as.data.frame(srclist, stringsAsFactors = FALSE)
  selres <- select_sources(srcdf, added_prs)
  
  srcdf     <- selres$srcdf
  added_prs <- selres$added_prs
  
  # add to diff_exprs
  for (i in seq_along(diff_exprs)) {
    
    # get sources
    gse_name <- names(diff_exprs[i])
    gse_rows <- srcdf$GSE == gse_name
    
    anal_srcs <- srcdf$Source[gse_rows]
    names(anal_srcs) <- paste(gse_name, srcdf$Contrast[gse_rows], sep='_')
    
    # check if sources have any paired
    have_prd <- sapply(added_prs, function(pairs) any(anal_srcs %in% pairs))
    
    # add info to diff_exprs
    diff_exprs[[i]]$sources <- anal_srcs
    diff_exprs[[i]]$pairs   <- added_prs[have_prd]
    
    # save diff_exprs
    gse_folder <- strsplit(gse_name, "\\.")[[1]][1]  # name can be "GSE.GPL"
    gse_dir <- file.path(data_dir, gse_folder)
    
    save_name <- paste(gse_name, "diff_expr", tolower(diff_exprs[[i]]$annot), sep = "_")
    if (!is.null(postfix)) save_name <- paste(save_name, postfix, sep = "_")
    save_name <- paste0(save_name, ".rds")
    
    saveRDS(diff_exprs[[i]], file.path(gse_dir, save_name))
  }
  return(diff_exprs)
}



# Shiny GUI used by add_sources
#
# @param srcdf
# @param added_prs
#
# @return
#
# @examples
select_sources <- function(srcdf, added_prs) {
  
  # ------------------- Setup
  
  # setup
  added_src <- setdiff(srcdf$Source, NA)
  
  prsht  <- paste0(nrow(srcdf) * 21.32, 'px')
  srcht  <- paste0(nrow(srcdf) * 42.63, 'px')
  
  if (is.null(added_prs)) {
    prsdf  <- data.frame(Pairs = character(0), stringsAsFactors = FALSE)
    
  } else {
    prsvec <- sapply(added_prs, paste, collapse = ', ')
    prsdf  <- data.frame(Pairs = prsvec, stringsAsFactors = FALSE)
  }
  
  
  # link for GSE
  orig_names <- srcdf$GSE
  gse_names  <- sapply(strsplit(srcdf$GSE, ".", fixed = TRUE), `[`, 1)
  srcdf$GSE  <- paste0('<a href="https://www.ncbi.nlm.nih.gov/geo/query/acc.cgi?acc=',
                       gse_names, '">', gse_names, '</a>')
  
  
  
  # ------------------- user interface
  
  
  ui <- miniPage(
    # title bar
    gadgetTitleBar("Select Sources"),
    miniTabstripPanel(
      miniTabPanel("Sources", icon = icon("table"),
                   miniContentPanel(
                     fillCol(flex = NA,
                             fillRow(flex = c(NA, .025, NA, NA),
                                     textInput(
                                       "source",
                                       label = "Sample source:",
                                       width = "300px"
                                     ),
                                     tags$style(type='text/css', ".selectize-dropdown-content {max-height: 500px; }")
                             ),
                             hr(),
                             DT::dataTableOutput("srcdf", height = "100%")
                     )
                   ),
                   miniButtonBlock(
                     actionButton("add_source", "Add"),
                     actionButton("del_source", "Delete")
                   )
                   
      ),
      
      miniTabPanel("Pairs", icon = icon("list-ol"),
                   miniContentPanel(
                     fillCol(flex = NA,
                             fillRow(flex = c(NA, .025, NA, NA),
                                     selectizeInput(
                                       "paired",
                                       label = "Paired sources:",
                                       multiple = TRUE,
                                       choices = added_src,
                                       width = "300px"
                                     )
                             ),
                             hr(),
                             DT::dataTableOutput("prsdf", height = prsht)
                     )
                   ),
                   miniButtonBlock(
                     actionButton("add_pair", "Add"),
                     actionButton("del_pair", "Delete")
                   )
      )
    )
  )
  
  
  
  # ------------------------- server
  
  
  server <- function(input, output, session) {
    
    
    output$prsdf <- DT::renderDataTable({
      
      DT::datatable(
        prsdf,
        # rownames = FALSE,
        options = list(
          scrollY = FALSE,
          paging = FALSE,
          searching = FALSE,
          bInfo = 0
        )
      )
    })
    
    
    # show source data
    output$srcdf <- DT::renderDataTable({
      
      DT::datatable(
        srcdf,
        # rownames = FALSE,
        options = list(
          scrollY = FALSE,
          paging = FALSE,
          bInfo = 0
        ),
        escape = FALSE # need for HTML links
      )
    })
    
    
    src_proxy = DT::dataTableProxy('srcdf')
    prs_proxy = DT::dataTableProxy('prsdf')
    
    
    # clicked 'Add Source'
    observeEvent(input$add_source, {
      
      rows  <- input$srcdf_rows_selected
      nrow  <- length(row)
      src   <- input$source
      
      
      if (is.null(rows) & src != "") {
        message('Select contrast(s) to add source.')
        
      } else if (!is.null(rows) & src == "") {
        message('Select a sample source.')
        
      } else if (!is.null(rows) & src != "") {
        srcdf[rows, 'Source'] <<- input$source
        DT::replaceData(src_proxy, srcdf, resetPaging = FALSE)
        
        # update added sources
        added_src <<- setdiff(srcdf$Source, NA)
        updateSelectizeInput(session, 'paired', choices = added_src)
        updateTextInput(session, 'source', value = "")
      }
      
    })
    
    # clicked 'Delete Source'
    observeEvent(input$del_source, {
      
      rows  <- input$srcdf_rows_selected
      
      if (length(row) == 0) {
        message('Select contrast(s) to delete source.')
        
      } else {
        srcdf[rows, 'Source'] <<- NA
        DT::replaceData(src_proxy, srcdf, resetPaging = FALSE)
        
        # update added sources
        added_src <<- setdiff(srcdf$Source, NA)
        updateSelectizeInput(session, 'paired', choices = added_src)
      }
      
    })
    
    # clicked 'Add Pair'
    observeEvent(input$add_pair, {
      
      prd  <- input$paired
      
      if (length(prd) < 2) {
        message('Select two or more sources to pair.')
        
      } else {
        
        # first pairing
        if (length(added_prs) == 0) {
          added_prs[[length(added_prs)+1]] <<- prd
          
        } else {
          
          # determine if previously paired contain just paired sources
          have_prd <- sapply(added_prs, function(added_pr) any(prd %in% added_pr))
          
          # merge if any
          if (any(have_prd)) {
            mrg_prd <- unique(c(prd, unlist(added_prs[have_prd])))
            added_prs[have_prd] <<- NULL
            added_prs[[length(added_prs)+1]] <<- mrg_prd
            
          } else {
            # add new otherwise
            added_prs[[length(added_prs)+1]] <<- prd
          }
        }
        
        # update pairs data.frame
        prsvec <- sapply(added_prs, paste, collapse = ', ')
        prsdf <<- data.frame(Pairs = prsvec, stringsAsFactors = FALSE)
        
        DT::replaceData(prs_proxy, prsdf)
        
        # unselect paired
        updateSelectizeInput(session, 'paired', selected = "")
      }
    })
    
    
    # clicked 'Delete Pair'
    observeEvent(input$del_pair, {
      
      
      rows  <- input$prsdf_rows_selected
      
      if (length(rows) == 0) {
        message('Select row(s) to delete pairs.')
        
      } else {
        added_prs[[rows]] <<- NULL
        
        # update pairs data.frame
        if (length(added_prs) == 0) {
          prsdf <<- data.frame(Pairs = character(0), stringsAsFactors = FALSE)
          
        } else {
          prsvec <- sapply(added_prs, paste, collapse = ', ')
          prsdf <<- data.frame(Pairs = prsvec, stringsAsFactors = FALSE)
          
        }
        
        DT::replaceData(prs_proxy, prsdf,  resetPaging = FALSE)
      }
    })
    
    
    # clicked 'Done'
    observeEvent(input$done, {
      if (anyNA(srcdf$Source)) {
        message("Contrast(s) without source.")
        
      }  else {
        srcdf$GSE <- orig_names
        stopApp(list(srcdf = srcdf, added_prs = added_prs))
      }
    })
  }
  
  runGadget(shinyApp(ui, server), viewer = paneViewer())
}