R/ChromosomalModel.R

In aroma.core: Core Methods and Classes Used by 'aroma.*' Packages Part of the Aroma Framework

###########################################################################/**
# @RdocClass ChromosomalModel
#
# @title "The ChromosomalModel class"
#
# \description{
#  @classhierarchy
#
#  This \emph{abstract} class represents a chromosomal model.
# }
#
# @synopsis
#
# \arguments{
#   \item{cesTuple}{A @see "AromaMicroarrayDataSetTuple".}
#   \item{tags}{A @character @vector of tags.}
#   \item{genome}{A @character string specifying what genome is process.}
#   \item{chromosomes}{(optional) A @vector specifying which chromosomes
#    to process.}
#   \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
#  @allmethods "public"
# }
#
# \section{Requirements}{
#   This class requires genome information annotation files for
#   every chip type.
# }
#
# @author
#*/###########################################################################
setConstructorS3("ChromosomalModel", function(cesTuple=NULL, tags="*", genome="Human", chromosomes=NULL, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'cesTuple':
  if (!is.null(cesTuple)) {
    # Coerce, if needed
    if (!inherits(cesTuple, "AromaMicroarrayDataSetTuple")) {
      cesTuple <- as.AromaMicroarrayDataSetTuple(cesTuple)
    }
  }

  # Argument 'tags':
  tags <- Arguments$getTags(tags, collapse=NULL)

  this <- extend(Object(), "ChromosomalModel",
    .alias = NULL,
    .cesTuple = cesTuple,
    .chromosomes = NULL,
    .tags = tags,
    .genome = genome
  )

  # Validate?
  if (!is.null(this$.cesTuple)) {
    # Assert that a genome annotation file exists
    gf <- getGenomeFile(this)
    this <- setChromosomes(this, chromosomes)
  }

  this
}, abstract=TRUE)


setMethodS3("as.character", "ChromosomalModel", function(x, ...) {
  # To please R CMD check
  this <- x

  s <- sprintf("%s:", class(this)[1])
  s <- c(s, paste("Name:", getName(this)))
  s <- c(s, paste("Tags:", getTags(this, collapse=",")))
  s <- c(s, paste("Chip type (virtual):", getChipType(this)))
  s <- c(s, sprintf("Path: %s", getPath(this)))
  tuple <- getSetTuple(this)
  chipTypes <- getChipTypes(tuple)
  nbrOfChipTypes <- length(chipTypes)
  s <- c(s, sprintf("Number of chip types: %d", nbrOfChipTypes))
  s <- c(s, sprintf("Chip types: %d", paste(chipTypes, collapse=", ")))

  s <- c(s, "List of data sets:")
  s <- c(s, as.character(tuple))

  GenericSummary(s)
}, protected=TRUE)


setMethodS3("getRootPath", "ChromosomalModel", function(this, ...) {
  tag <- getAsteriskTags(this)[1]
  sprintf("%sData", tolower(tag))
}, protected=TRUE)


setMethodS3("getParentPath", "ChromosomalModel", function(this, ...) {
  # Root path
  rootPath <- getRootPath(this)

  # Full name
  fullname <- getFullName(this)

  # The full path
  path <- filePath(rootPath, fullname)
  path <- Arguments$getWritablePath(path)

  path
}, protected=TRUE)


setMethodS3("getPath", "ChromosomalModel", function(this, ...) {
  path <- getParentPath(this, ...)

  # Chip type
  chipType <- getChipType(this)

  # The full path
  path <- filePath(path, chipType)
  path <- Arguments$getWritablePath(path)

  path
})

setMethodS3("getReportPath", "ChromosomalModel", function(this, ...) {
  rootPath <- "reports"

  # Data set name
  name <- getName(this)

  # Data set tags
  tags <- getTags(this, collapse=",")

  # Get chip type
  chipType <- getChipType(this)

  # Image set
  set <- getSetTag(this)

  # The report path
  path <- filePath(rootPath, name, tags, chipType, set)
  path <- Arguments$getWritablePath(path)

  path
}, protected=TRUE)



setMethodS3("getSetTuple", "ChromosomalModel", function(this, ...) {
  this$.cesTuple
}, protected=TRUE)



setMethodS3("getSets", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getSets(tuple)
})


###########################################################################/**
# @RdocMethod nbrOfChipTypes
#
# @title "Gets the number of chip types"
#
# \description{
#  @get "title" used in the model.
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns an @integer.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("nbrOfChipTypes", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  nbrOfChipTypes(tuple, ...)
})



setMethodS3("getListOfUnitNamesFiles", "ChromosomalModel", function(this, ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }

  verbose && enter(verbose, "Retrieving unit names files")

  tuple <- getSetTuple(this)

  tryCatch({
    unfList <- getListOfUnitNamesFiles(tuple, ...)
  }, error = function(ex) {
    msg <- sprintf("Failed to located unit-names files for one of the chip types (%s). The error message was: %s", paste(getChipTypes(this), collapse=", "), ex$message)
    throw(msg)
  })

  verbose && exit(verbose)

  unfList
}, private=TRUE)


setMethodS3("getListOfAromaUgpFiles", "ChromosomalModel", function(this, ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }

  verbose && enter(verbose, "Retrieving list of UGP files")

  tuple <- getSetTuple(this)
#  unfList <- getListOfUnitNamesFiles(this)

  ugpList <- NULL
  tryCatch({
    verbose && enter(verbose, "Retrieving UGP files from unit names files")
#    ugpList <- lapply(unfList, FUN=getAromaUgpFile, verbose=less(verbose))
#   TODO: Why not do this?  /HB 2010-01-12
    ugpList <- lapply(tuple, FUN=getAromaUgpFile, verbose=less(verbose))
    verbose && exit(verbose)
  }, error = function(ex) {
    msg <- sprintf("Failed to located UGP files for one of the chip types (%s). Please note that DChip GenomeInformation files are no longer supported.  The error message was: %s", paste(getChipTypes(this), collapse=", "), ex$message)
    throw(msg)
  })

  verbose && exit(verbose)

  ugpList
}, protected=TRUE)


setMethodS3("getListOfUnitTypesFiles", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getListOfUnitTypesFiles(tuple, ...)
}, private=TRUE)



setMethodS3("getChipTypes", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getChipTypes(tuple, ...)
})


###########################################################################/**
# @RdocMethod getChipType
#
# @title "Gets a label for all chip types merged"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("getChipType", "ChromosomalModel", function(this, ...) {
  getChipTypes(this, merge=TRUE, ...)
})



###########################################################################/**
# @RdocMethod getNames
#
# @title "Gets the names of the arrays"
#
# \description{
#  @get "title" available to the model.
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("getNames", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getNames(tuple, ...)
})


setMethodS3("getFullNames", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getFullNames(tuple, ...)
})





###########################################################################/**
# @RdocMethod getTableOfArrays
#
# @title "Gets a table of arrays"
#
# \description{
#  @get "title" showing their availability across chip types.
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a \eqn{NxK} @matrix of @integers where \eqn{N} is the total number
#  of arrays and \eqn{K} is the number of chip types in the model.  The row
#  names are the names of the arrays, and the column names are the chip types.
#  If data is available for array \eqn{n} and chip type \eqn{k}, cell
#  \eqn{(n,k)} has value \eqn{n}, otherwise @NA.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("getTableOfArrays", "ChromosomalModel", function(this, ...) {
  tuple <- getSetTuple(this)
  getTableOfArrays(tuple, ...)
}, protected=TRUE, deprecated=TRUE)


setMethodS3("indexOf", "ChromosomalModel", function(this, patterns=NULL, ..., onMissing=c("error", "NA")) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'onMissing':
  onMissing <- match.arg(onMissing)


  # If 'patterns' is numeric, then...
  if (is.numeric(patterns)) {
    names <- getNames(this)
    n <- length(names)
    res <- Arguments$getIndices(patterns, max=n)
    names(res) <- names[res]
    return(res)
  }

  # ...otherwise, reuse indexOf() for GenericDataFileSet in R.filesets.
  indexOf.GenericDataFileSet(this, patterns=patterns, ...,
                                                         onMissing=onMissing)
})




###########################################################################/**
# @RdocMethod nbrOfArrays
#
# @title "Gets the number of arrays"
#
# \description{
#  @get "title" used in the model.
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns an @integer.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("nbrOfArrays", "ChromosomalModel", function(this, ...) {
  length(getNames(this, ...))
})


setMethodS3("getName", "ChromosomalModel", function(this, collapse="+", ...) {
  name <- getAlias(this)

  if (is.null(name)) {
    tuple <- getSetTuple(this)
    name <- getName(tuple, ...)
  }

  name
})


setMethodS3("getAsteriskTags", "ChromosomalModel", function(this, collapse=NULL, ...) {
  # Create a default asterisk tags for any class by extracting all
  # capital letters and pasting them together, e.g. AbcDefGhi => ADG.
  name <- class(this)[1]

  # Remove any 'Model' suffixes
  name <- gsub("Model$", "", name)

  name <- capitalize(name)

  # Vectorize
  name <- strsplit(name, split="")[[1]]

  # Identify upper case
  name <- name[(toupper(name) == name)]

  # Paste
  name <- paste(name, collapse="")

  tag <- name
}, protected=TRUE)




setMethodS3("getTags", "ChromosomalModel", function(this, collapse=NULL, ...) {
  tuple <- getSetTuple(this)
  tags <- getTags(tuple, collapse=collapse, ...)

  # Add model tags
  tags <- c(tags, this$.tags)

  # In case this$.tags is not already split
  tags <- strsplit(tags, split=",", fixed=TRUE)
  tags <- unlist(tags)

  # Update default tags
  asteriskTags <- getAsteriskTags(this, collapse=",")
  if (length(asteriskTags) == 0)
    asteriskTags <- ""
  tags[tags == "*"] <- asteriskTags

  tags <- Arguments$getTags(tags, collapse=NULL)

  # Get unique tags
  tags <- locallyUnique(tags)

  # Collapsed or split?
  tags <- Arguments$getTags(tags, collapse=collapse)

  tags
})


setMethodS3("getFullName", "ChromosomalModel", function(this, ...) {
  name <- getName(this)
  tags <- getTags(this)
  fullname <- paste(c(name, tags), collapse=",")
  fullname <- gsub("[,]$", "", fullname)
  fullname
})



###########################################################################/**
# @RdocMethod getChromosomes
# @alias setChromosomes.ChromosomalModel
#
# @title "Gets the chromosomes to be processed"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/###########################################################################
setMethodS3("getChromosomes", "ChromosomalModel", function(this, ...) {
  chromosomes <- this$.chromosomes
  if (!is.null(chromosomes)) {
    return(chromosomes)
  }

  # The default is to process all available chromosomes
  ugpList <- getListOfAromaUgpFiles(this)
  chromosomes <- lapply(ugpList, FUN=getChromosomes)
  chromosomes <- unlist(chromosomes, use.names=TRUE)
  chromosomes <- sort(unique(chromosomes))

  chromosomes
})

setMethodS3("setChromosomes", "ChromosomalModel", function(this, chromosomes=NULL, ...) {
  # Argument 'chromosomes':
  if (!is.null(chromosomes)) {
    chromosomes <- Arguments$getVector(chromosomes)
    chromosomes <- sort(unique(chromosomes))

    # All available chromosomes
    ugpList <- getListOfAromaUgpFiles(this)
    chromosomesA <- lapply(ugpList, FUN=getChromosomes)
    chromosomesA <- unlist(chromosomesA, use.names=TRUE)
    chromosomesA <- sort(unique(chromosomesA))

    unknown <- setdiff(chromosomes, chromosomesA)
    if (length(unknown) > 0L) {
      throw(sprintf("Unknown chromosomes detected: %s [%d]", hpaste(unknown), length(unknown)))
    }
  }

  this$.chromosomes <- chromosomes

  invisible(this)
})






setMethodS3("getGenome", "ChromosomalModel", function(this, ...) {
  this$.genome
})


setMethodS3("getGenomeFile", "ChromosomalModel", function(...) {
  getAromaGenomeTextFile(...)
}, protected=TRUE)


setMethodS3("getAromaGenomeTextFile", "ChromosomalModel", function(this, genome=getGenome(this), ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'genome':
  genome <- Arguments$getCharacter(genome)

  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }

  verbose && enter(verbose, "Locating genome annotation file")
  verbose && cat(verbose, "Genome name: ", genome)

  gf <- AromaGenomeTextFile$byGenome(genome, ..., verbose=verbose)
  verbose && print(verbose, gf)
  verbose && exit(verbose)

  gf
}, protected=TRUE)  # getAromaGenomeTextFile()


setMethodS3("setGenome", "ChromosomalModel", function(this, genome, tags=NULL, ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'genome':
  genome <- Arguments$getCharacter(genome, length=c(1,1))

  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }

  oldGenome <- this$.genome

  fullname <- paste(c(genome, tags), collapse=",")
  verbose && cat(verbose, "Fullname: ", fullname)

  # Verify that there is an existing genome file
  tryCatch({
    this$.genome <- fullname
    gf <- getGenomeFile(this, verbose=less(verbose, 10))
  }, error = function(ex) {
    this$.genome <- oldGenome
    throw(ex$message)
  })

  invisible(oldGenome)
})



setMethodS3("getGenomeData", "ChromosomalModel", function(this, ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }


  verbose && enter(verbose, "Reading genome chromosome annotation file")

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Get genome annotation data
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && enter(verbose, "Retrieving genome annotation file")
  gf <- getGenomeFile(this, verbose=less(verbose, 10))
  verbose && exit(verbose)

  verbose && enter(verbose, "Reading data file")
  pathname <- getPathname(gf)
  verbose && cat(verbose, "Pathname: ", pathname)
  data <- readTable(pathname, header=TRUE,
                            colClasses=c(nbrOfBases="integer"), row.names=1)
  verbose && exit(verbose)

  verbose && enter(verbose, "Translating chromosome names")
  chromosomes <- row.names(data)
  map <- c("X"=23, "Y"=24, "Z"=25)
  for (kk in seq_along(map)) {
    chromosomes <- gsub(names(map)[kk], map[kk], chromosomes, fixed=TRUE)
  }
  row.names(data) <- chromosomes
  verbose && exit(verbose)

  verbose && exit(verbose)

  data
}, protected=TRUE)


setMethodS3("fit", "ChromosomalModel", abstract=TRUE)


setMethodS3("getSetTag", "ChromosomalModel", function(this, ...) {
  tolower(getAsteriskTags(this)[1])
}, private=TRUE)


setMethodS3("getOutputSet", "ChromosomalModel", function(this, ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }

  verbose && enter(verbose, "Retrieving output set")

  verbose && enter(verbose, "Scanning output path")
  # Locate all
  path <- getPath(this)
  verbose && cat(verbose, "Path: ", path)
  fs <- GenericDataFileSet$byPath(path, ...)
  verbose && cat(verbose, "Number of matching files located: ", length(fs))
  verbose && exit(verbose)

  verbose && enter(verbose, "Keep those with fullnames matching the input data set")
  fullnames <- getFullNames(fs)
  verbose && cat(verbose, "Full names of *all* files found:")
  verbose && str(verbose, fullnames)

  # Drop extranous files
  keepFullnames <- getFullNames(this)
  verbose && cat(verbose, "Full names to be kept:")
  verbose && str(verbose, keepFullnames)

  patterns <- sprintf("^%s", fullnames)
  keep <- rep(FALSE, times=length(fullnames))
  for (pattern in patterns) {
    keep <- keep | (regexpr(pattern, fullnames) != -1)
  }

  if (any(!keep)) {
    verbose && enter(verbose, "Extract subset of files")
    keep <- which(keep)
    verbose && cat(verbose, "Keeping indices:")
    verbose && str(verbose, keep)
    fs <- extract(fs, keep)
    verbose && exit(verbose)
  }

  verbose && exit(verbose)

  verbose && print(verbose, fs)

  verbose && exit(verbose)

  fs
}, private=TRUE)


setMethodS3("getAlias", "ChromosomalModel", function(this, ...) {
  this$.alias
}, protected=TRUE)


setMethodS3("getArrays", "ChromosomalModel", function(this, ...) {
  getNames(this, ...)
}, protected=TRUE, deprecated=TRUE)