R/example_objects.R

In gCMAPWeb: A web interface for gene-set enrichment analyses

##' This function generates NChannelSets from randomly selected gene idenfiers and scores.
##' Scores of the first (simulated) sample will be shifted up by the amount specified by the 'add' parameter for the first 50 genes and down by the same amount for genes 51-100.
##'
##' This function is mainly intented for testing purposes.
##' @title Generate example NChannelSets
##' @param universe character, the name of an available annotation package. Default=org.Hs.eg.db
##' @param idType character, a valid identifier type supported by the selected annotation package. Default=ENTREZID
##' @param rows integer, the number of genes to sample. Default=1000
##' @param cols integer, the number of samples to generate. Default=20
##' @param seed numeric, seed for the random number generator. Default=123
##' @param add numeric, score shift for scores in the first sample column. Scores for genes 1-50 will be shifted up, those for genes 51-100 down.
##' @return NChannelSet with simulated scores.
##' @export
##' @author Thomas Sandmann
##' @importMethodsFrom AnnotationDbi keys
##' @examples
##' ## generate example NChannelSet with 100 features and 10 columns
##' ## for human EntrezIds
##' if( require( "org.Hs.eg.db", character.only=TRUE)){
##'   e <- exampleCMAP( universe="org.Hs.eg.db", rows=100, cols=10)
##'   dim( e )
##'   head( featureNames( e ))
##'   assayDataElementNames( e )
##'   ## or gene symbols
##'   s <- exampleCMAP( universe="org.Hs.eg.db", idType="SYMBOL")
##'   head( featureNames( s ))
##'   }
exampleCMAP <- function(
  universe="org.Hs.eg.db",
  idType="ENTREZID",
  rows=1000,
  cols=20,
  seed=123,
  add=3
  ){
  ## check parameters
  universe <- ifelse( grepl(".db$", universe), universe, paste(universe, "db", sep="."))
  annotation.loaded <- try( get( universe ))
  if( inherits( annotation.loaded, "try-error")){
    stop( paste("AnnotationDbi", universe, "could not be found. Is the annotation package loaded ?"))
  }
  
  if( attr( class( get( universe ) ), "package") != "AnnotationDbi" ) {
    stop( paste("AnnotationDbi", universe, "could not be found. Is the annotation package loaded ?"))
  }
  
  ## retrieve annotation ids
  if( !is.null( idType ) ){
    identifiers <- keys( get( universe ), keytype=idType)
  } else {
    identifiers <- keys( get( universe ) )
  }
  
  set.seed( seed )
  channels <- c("z", "log_fc")
  g.ids <- sample( identifiers, rows, replace=FALSE)
  dat <- lapply(
    channels,
    function(x){
    s <- matrix(
      rnorm( rows * cols),
      nrow=rows,
      ncol=cols,
      dimnames=list(
        g.ids,
        paste("Exp",
              1:cols,
              sep=""
              )
        )
      )
    s[1:50, 1] <- s[1:50, 1] + add
    s[51:100, 1] <- s[51:100, 1] - add
    s
  })
  names( dat ) <- channels
  
  obj <- new("NChannelSet",
             log_fc=dat$log_fc, z=dat$z
  )
  
  annotation( obj) <- sub( ".db$", "", universe)
  pData( obj ) <- data.frame(
    Name=sampleNames(obj),
    row.names=sampleNames(obj)
    )
  return( obj )
}

##' This function returns a simulated POST request, similar to those generated from user-input into the web interface.
##'
##' This function is mainly intented for testing purposes.
##' @title Simulate POST request 
##' @param cmap NChannelSet object, e.g. generated by the exampleCMAP function
##' @param inputType character, one of directional, non-directional, profile
##' @param species character, should match a species supported by the loaded gCMAPWeb configuration file
##' @param array.platform character,  should match an array platform supported by the loaded gCMAPWeb configuration file
##' @param idType character, one of entrez, symbol or probe
##' @param rows integer, number of genes to include in a 'profile' query.
##' @param add numeric, score shift for scores in the first sample column. Scores for genes 1-50 will be shifted up, those for genes 51-100 down. Only used to simulate 'profile' queries.
##' @param seed numeric, seed for the random number generator. Default=123
##' @return list, containg the same elements as a gCMAPWeb POST request
##' @export
##' @author Thomas Sandmann
##' @examples
##' if( require( "org.Hs.eg.db", character.only=TRUE)){
##'   ## generate an example NChannelSet for human EntrezIds
##'   e <- exampleCMAP( universe="org.Hs.eg", rows=1000, cols=10)
##'   ## generate a matching example Post, simulating a non-directional query
##'   examplePost( cmap=e )
##'   ## or a directional query
##'   examplePost( cmap=e, inputType="directional")
##' }
examplePost <- function( cmap, inputType="non-directional", species="human", array.platform=NULL, idType="entrez", rows=1000, add=3, seed=123) {
  set.seed( seed ) 
  cmap.name <- deparse(substitute(cmap))
  
  ## check parameters
  stopifnot( inputType %in% c("non-directional", "directional", "profile") )
  ids <- featureNames( cmap )[1:100]
  signs <- c( rep("up", 50), rep("down", 50))
  signed.ids <- split( ids, factor( signs ) )
  
  if( inputType == "directional" ){
    post <- list(
      inputType=inputType,
      dataType="SignedGeneSet",
      species = species,
      platform = array.platform,
      idType = idType,
      selected_cmaps = cmap.name,
      query_data_up = signed.ids[["up"]],
      query_data_down = signed.ids[["down"]]
    )
  } else if( inputType == "non-directional") {
    post <- list(
      inputType=inputType,
      dataType="SignedGeneSet",
      species = species,
      platform = array.platform,
      idType = idType,
      selected_cmaps = cmap.name,
      query_data = ids
    )
  } else if( inputType == "profile") {
    dat <- data.frame( Id=featureNames( cmap ), Profile=rnorm( rows ) )
    dat[ 1:50, "Profile"]  <- dat[ 1:50,"Profile"] + add
    dat[ 51:100, "Profile"] <- dat[ 51:100,"Profile"] - add
    post <- list(
      inputType=inputType,
      dataType="Profile",
      species = species,
      platform = array.platform,
      idType = idType,
      selected_cmaps = cmap.name,
      query_data = dat
    )
  } 
  post <- post[!sapply( post, function(x) is.null(x))]
  return( post )
}