R/methods-IcaSet.R

In MineICA: Analysis of an ICA decomposition obtained on genomics data

setMethod("initialize",
          signature="IcaSet",
          definition = function(.Object,
                   annotation      = character(),
                   assayData       = assayDataNew(dat=dat, ...),
                   experimentData  = new("MIAME"),
                   featureData     = annotatedDataFrameFrom(assayData, byrow=TRUE),
                   phenoData       = annotatedDataFrameFrom(assayData, byrow=FALSE),
                   A=new("data.frame"),
                   S=new("data.frame"),
                   dat=new("matrix"),   
                   SByGene=new("data.frame"),
                   datByGene=new("data.frame"),
                   compNames=character(), 
                   indComp=numeric(), 
                   witGenes=character(),
                   refSamples=character(),
                   chipManu=character(),
                   chipVersion=character(),
                   typeID=character(),
                   organism=character(),
                   mart=useMart("ensembl"),...){

              .Object@A <- A
              .Object@S <- S

              .Object@SByGene <- SByGene
              if (length(compNames)==0 & ncol(A)>0) 
                  compNames <- paste("Component",as.character(c(1:ncol(A))))
              if (length(indComp)==0 & ncol(A)>0)
                  indComp <- 1:ncol(A)

              colnames(.Object@A) <- colnames(.Object@S) <-indComp

              .Object@compNames <- compNames
              .Object@indComp <- indComp
              .Object@refSamples <- refSamples
              .Object@witGenes <- witGenes
              

              .Object@datByGene <- datByGene
              .Object@chipManu <- chipManu
              .Object@chipVersion <- chipVersion

              .Object@typeID <- typeID

              .Object@organism <- organism


              if (length(annotation)>0)
                  library(annotation,character.only=TRUE)
              
              .Object@mart <- mart
              
              callNextMethod(.Object,
                             assayData       = assayData,
                             phenoData       = phenoData,
                             featureData     = featureData,
                             experimentData  = experimentData,
                             annotation      = annotation,
                             organism = organism)

              
          })


validIcaSet <- function(object) {
    msg <- NULL
    msg <- Biobase:::validMsg(msg, Biobase:::isValidVersion(object, "IcaSet"))

    if (dim(assayDataElement(object,"dat"))[[1]] != dim(S(object))[[1]])
        msg <- paste(msg, "Assay data and matrix S must have the same number of rows (i.e the same number of genes or probe sets)", sep="\n")
    if (dim(datByGene(object))[[2]] != dim(assayDataElement(object,"dat"))[[2]])
        msg <- paste(msg, "expression data by gene (datByGene) and assayData must have the same number of columns", sep="\n")
    if (dim(assayDataElement(object,"dat"))[[2]] != dim(A(object))[[1]])
        msg <- paste(msg, "Assay data and matrix A must include the same number of samples",sep = "\n")
    if (dim(A(object))[[2]] != dim(S(object))[[2]])
        msg <- paste(msg, "Matrix A and S must include the same number of components", sep = "\n")
    if (!all(rownames(A(object)) == sampleNames(assayData(object))))
        msg <- paste(msg, "Row names of A must match the sampleNames of assayData", sep = "\n")
    if (!all(rownames(S(object)) == featureNames(object)))
        msg <- paste(msg, "Rownames of S must match the rownames of assayData.", sep = "\n")
    if (nrow(SByGene(object))>0 & nrow(datByGene(object))>0) {
        if (!all(rownames(SByGene(object)) == rownames(datByGene(object))))
            msg <- paste(msg, "Names of each SByGene element must match the rownames of datByGene.", sep = "\n")
        if (ncol(SByGene(object)) != nbComp(object))
            msg <- paste(msg, "The number of elements in SByGene must match the number of components", sep = "\n")
 
    }
    if (length(compNames(object)) != nbComp(object))
        msg <- paste(msg, "The number of labels must match the number of components", sep = "\n")
    if (length(indComp(object)) != nbComp(object))
        msg <- paste(msg, "The number of indices must match the number of components", sep = "\n")
    if (length(witGenes(object))>0) {
        if (length(witGenes(object)) != nbComp(object))
            msg <- paste(msg, "The number of 'witness' genes must match the number of components", sep = "\n")
        if (length(setdiff(witGenes(object),rownames(assayDataElement(object,"dat"))))>0) {
            if (length(setdiff(witGenes(object),geneNames(object)))>0)
                msg <- paste(msg, "The 'witness' genes must be included in the rownames of the assay data.", sep = "\n")
        }
    }
   if (length(refSamples(object))>0)
        if (length(setdiff(refSamples(object),sampleNames(object)))>1)
            msg <- paste(msg, "All the reference samples are not included within the sample names.")       


    if (is.null(msg))
        TRUE
    else 
        msg
    
}

setValidity("IcaSet", function(object) {
     validIcaSet(object)
 })

     setMethod(
      f ="[",
      signature(x = "IcaSet", "ANY","ANY","ANY"),
      definition = function (x, i, j, k, ..., drop=FALSE){

      if (!missing(i)) {    
          if (is.character(i)) {
              ifeatures <- intersect(i,featureNames(x))
              if (length(intersect(i,featureNames(x)))>0) {
                  x@S <- x@S[ifeatures,,drop=FALSE]
                  ff <- matrix(nrow=length(ifeatures),ncol=0)
                  rownames(ff) <- ifeatures
                  x@featureData <- annotatedDataFrameFrom(ff, byrow=TRUE)
                  dat(x) <- dat(x)[ifeatures,,drop=FALSE]
              }
              else {
                  if (length(intersect(i,geneNames(x)))>0) {
                      igenes <- intersect(i,geneNames(x))
                      x@SByGene <- x@S[igenes,,drop=FALSE]
                      datByGene(x) <- datByGene(x)[igenes,,drop=FALSE]
                  }
                  else {
                      switch (EXPR =i ,
                              "dat" ={ return ( assayDataElement(x,"dat") )} ,
                              "datByGene" ={ if (nrow(x@datByGene)!=0) return ( x@datByGene ) else return(assayDataElement(x,"dat"))} ,
                              "pData" ={ return ( pData(x) )} ,
                              "featureData" ={ return ( featureData(x) )} ,
                              "annotation" ={ return ( annotation(x) )} ,
                              "package" ={ return ( annotation(x) )} ,
                              "A" ={ return ( x@A )} ,
                              "S" ={ return ( x@S )} ,                   
                              "SByGene" ={ return ( x@SByGene )} ,
                              "compNames" ={ return ( x@compNames )} ,
                              "indComp" ={ return ( x@indComp )} ,
                              "witGenes" ={ return ( x@witGenes )} ,
                              "refSamples" ={ return ( x@refSamples)} ,
                              "typeID" ={ return ( x@typeID)} ,
                              "organism" ={ return ( x@organism)} ,
                              "mart" ={ return ( x@mart)} ,
                              stop ( "This attribute is not valid! " )
                              )
                  }
              }
          }
      }

          if (!missing(j)) {

              if (is.numeric(j))
                  j <- sampleNames(x)[j]
          
                  keepSamples <- j
                  diffSamples <- setdiff(keepSamples,sampleNames(x))
                  if (length(diffSamples) == length(keepSamples))
                      stop("The sample ids are not available in the object.")
                  else if (length(diffSamples) > 0)
                      warning(paste("The samples:",paste(diffSamples,collapse=", "),"are not available in the object."))
                  keepSamples <- intersect(keepSamples,sampleNames(x)) 
                  
                  x@A <- A(x)[keepSamples,,drop=FALSE]
                  varLabelsor <- varLabels(x)
                  pData(x) <- pData(x)[keepSamples,,drop=FALSE]
                  varLabels(x) <-  varLabelsor
                  pData(protocolData(x))<- pData(protocolData(x))[keepSamples,,drop=FALSE]
                  assayDataElement(x,"dat") <- assayDataElement(x,"dat")[,keepSamples,drop=FALSE]
                  x@datByGene <- datByGene(x)[,keepSamples, drop=FALSE]
                  refSamples(x) <- intersect(refSamples(x),keepSamples)
                  

          }

          if (!missing(k)) {
              keepComp <- k
              
              if (is.character(keepComp)) {
                  diffComp <- setdiff(keepComp,compNames(x))
                  if (length(diffComp) == length(keepComp))
                      stop("The component ids are not available in the object.")
                  else if (length(diffComp) > 0)
                      warning(paste("The components:",paste(diffComp,collapse=", "),"are not available in the object."))
                  keepComp <- match(keepComp,compNames(x))
              }

              keepComp <- intersect(keepComp,1:nbComp(x))
            
              diffcomp <- setdiff(keepComp,indComp(x))
              if (length(diffcomp) == length(keepComp))
                  stop("The component numbers provided in 'keepComp' are not included in 'indComp(x)'.")
              else if (length(diffcomp) > 0)
                  warning(paste("The component(s):",paste(diffcomp,collapse=", ",sep=""),"are not available in 'x'."))
              
              keepComp <- intersect(keepComp,indComp(x))
              keepCompor <- keepComp
              keepComp <- match(keepComp, indComp(x))
              
              x@compNames <- compNames(x)[keepComp]
              
              if (length(witGenes(x))>0)
                  x@witGenes <- witGenes(x)[keepComp]
              
              x@A <- A(x)[,keepComp, drop=FALSE]
              x@S <- S(x)[,keepComp, drop=FALSE]
              x@SByGene <- SByGene(x)[,keepComp, drop=FALSE]
                
              indComp(x) <- keepCompor
          }
          
          return(x)
              
     }
)



setMethod( "show" ,"IcaSet" ,
       function (object){
           cat("Number of components:",nbComp(object),"\n")
           cat("Component labels:",compNames(object),"\n")
           callNextMethod()
           
      }
)




setMethod( "selectContrib" ,signature("IcaSet", "numeric", "character") ,
       function (object, cutoff=3, level=c("features","genes")){

           
           level <- level[1]
           level <- match.arg(level)
           switch(level,
                  features={Sl=Slist(object)},
                  genes={Sl=SlistByGene(object)}
                  )

           if (length(cutoff)==1)
               cutoff <- rep(cutoff[1],nbComp(object))
           else
               if ((length(cutoff)>1) & (length(cutoff)<nbComp(object))) {
                   cutoff <- rep(cutoff[1],nbComp(object))
                   warning("The length of arg 'cutoff' or 'selCutoff' must be either 1 or equal to the number of components")    
               }

           
           sel <- foreach (comp.proj=Sl, cutt=cutoff) %do% {
               sources.zval <- (comp.proj-mean(comp.proj))/sd(comp.proj)
               sources.keep <- sources.zval[abs(sources.zval) >= cutt]
               return(sources.keep)
           }

           names(sel) <- compNames(object)

           return(sel)
       }
          )


setMethod( "selectContrib" ,signature("list", "numeric") ,
       function (object, cutoff=3, ...){

           if (is.numeric(object))
           {
               comp <- object
               sel <- (comp-mean(comp))/sd(comp)
               sel <- sel[abs(sel) >= cutoff[1]]
               
           }
           else {

           if (length(cutoff)==1)
               cutoff <- rep(cutoff[1],length(object))
           else
               if ((length(cutoff)>1) & (length(cutoff)<length(object))) {
                   cutoff <- rep(cutoff[1],length(object))
                   warning("The length of arg 'cutoff' or 'selCutoff' must be either 1 or equal to the number of components")    
               }
                   

               comp.proj <- cutt <- NULL
               sel <- foreach (comp.proj=object, cutt=cutoff) %do% {
                   sources.zval <- (comp.proj-mean(comp.proj))/sd(comp.proj)
                   sources.keep <- sources.zval[abs(sources.zval) >= cutt]
                   return(sources.keep)
               }
               names(sel) <- names(object)
           }
           

           return(sel)
       }
          )


setMethod( "getComp" ,signature("IcaSet","character","numeric") ,
       function (object, level=c("features","genes"), ind){
           ac <- Alist(object)
           level <- level[1]
           callf <- c("features"="Slist","genes"="SlistByGene")[level]
           sc <- do.call(callf,list(object))
           
           if (length(ind)==1) {
               sc <- sc[[ind]]
               ac <- ac[[ind]]
           }
           else {
               sc <- sc[ind]
               ac <- ac[ind]
           }
           
           return (list(contrib=ac,proj=sc))
      }
)




setMethod( "geneNames" ,"IcaSet" ,
       function (object){
               return(rownames(datByGene(object)))
      }
)

setMethod( "nbComp" ,"IcaSet" ,
       function (object){
               return(ncol(A(object)))
      }
)


setMethod( "datByGene" ,"IcaSet" ,
          function (object){
           if (nrow(object@datByGene)>0)
               return ( object@datByGene)
           else
               return(object@assayData[["dat"]])

          }

)


setMethod(f = "A",
          signature = "IcaSet" ,
          definition = function (object){
              return (object@A)
          }
          )

setMethod(f = "dat",
          signature = "IcaSet" ,
          definition = function (object){
              return (assayDataElement(object,"dat") )
          }
          )


setMethod( "getA" ,"IcaSet" ,
       function (object){
           return (object@A)
      }
)


setMethod( "getS" ,"IcaSet" ,
       function (object){
           return (object@S)
      }
)

setMethod( "S" ,"IcaSet" ,
       function (object){
           return (object@S)
      }
)


setMethod( "Slist" ,"IcaSet" ,
       function (object){
           S <- S(object)
           Slist <- lapply(as.list(S),
                           function(x,n) {
                               names(x) <- n
                               return(x)
                           },
                           n = rownames(S)
                           )
           return(Slist)

      }
)

setMethod( "Alist" ,"IcaSet" ,
       function (object){
           A <- A(object)
           Alist <- lapply(as.list(A),
                           function(x,n) {
                               names(x) <- n
                               return(x)
                           },
                           n = rownames(A)
                           )
           return(Alist)

      }
)



setMethod( "getSByGene" ,"IcaSet" ,
       function (object){
           return(object@SByGene)
      }
)
setMethod( "SByGene" ,"IcaSet" ,
       function (object){
           return(object@SByGene)
      }
)

setMethod( "SlistByGene" ,"IcaSet" ,
       function (object){
           S <- SByGene(object)
           Slist <- lapply(as.list(S),
                           function(x,n) {
                               names(x) <- n
                               return(x)
                           },
                           n = rownames(S)
                           )
           return(Slist)
      }
)

setMethod( "compNames" ,"IcaSet" ,
       function (object){
           return (object@compNames)
      }
)

setMethod( "getLabelsComp" ,"IcaSet" ,
       function (object){
           return (object@compNames)
      }
)

setMethod( "indComp" ,"IcaSet" ,
       function (object){
           return (object@indComp)
      }
)

setMethod( "getIndComp" ,"IcaSet" ,
       function (object){
           return (object@indComp)
      }
)
        
 setMethod( "witGenes" ,"IcaSet" ,
       function (object){
           return (object@witGenes)
      }
)

 setMethod( "getWitGenes" ,"IcaSet" ,
       function (object){
           return (object@witGenes)
      }
)
        

setMethod( "getPackage" ,"IcaSet" ,
       function (object){
           return (object@annotation)
      }
)

setMethod( "package" ,"IcaSet" ,
       function (object){
           return (object@annotation)
      }
)


setMethod( "getChipVersion" ,"IcaSet" ,
       function (object){
           return (object@chipVersion)
      }
)

setMethod( "chipVersion" ,"IcaSet" ,
       function (object){
           return (object@chipVersion)
      }
)

setMethod( "getChipManu" ,"IcaSet" ,
       function (object){
           return (object@chipManu)
      }
)

setMethod( "chipManu" ,"IcaSet" ,
       function (object){
           return (object@chipManu)
      }
)

setMethod( "refSamples" ,"IcaSet" ,
       function (object){
           return (object@refSamples)
      }
)

setMethod( "getRefSamples" ,"IcaSet" ,
       function (object){
           return (object@refSamples)
      }
)

setMethod( "typeID" ,"IcaSet" ,
       function (object){
           return (object@typeID)
      }
)

setMethod( "getTypeID" ,"IcaSet" ,
       function (object){
           return (object@typeID)
      }
)
setMethod( "organism" ,"IcaSet" ,
       function (object){
           return (object@organism)
      }
)

setMethod( "mart" ,"IcaSet" ,
       function (object){
           return (object@mart)
      }
)

setMethod( "getMart" ,"IcaSet" ,
       function (object){
           return (object@mart)
      }
)


setReplaceMethod(f ="[",
                 signature = signature(x="IcaSet", i="ANY", j="ANY", value="ANY"),
                 definition = function (x, i, j, value ){
                     switch ( EXPR =i ,
                             "dat" ={ assayDataElement(x,"dat") <- value} ,
                             "datByGene" ={ x@datByGene <- value} ,
                             "pData" ={pData(x) <- value} ,
                             "featureData" ={ fData(x) <- value} ,
                             "fData" ={ fData(x) <- value} ,
                             "annotation" ={ x@annotation <- value} ,
                             "package" ={ x@annotation <- value} ,
                             "A" ={ x@A <- value} ,
                             "S" ={ x@S <- value} ,                             
                             "SByGene" = {x@SByGene <- value},
                             "compNames" = {x@compNames <- value},
                             "indComp" = {x@indComp <- value},
                             "witGenes" ={ x@witGenes <- value} ,
                             "chipManu" ={ x@chipManu <- value} ,
                             "chipVersion" ={ x@chipVersion <- value} ,
                             "refSamples" ={ x@refSamples <- value} ,
                             "typeID" ={ x@typeID <- value} ,
                             "organism" ={ x@organism <- value} ,
                             "mart" ={ x@mart <- value} ,
                             stop ( " This attribute doesn't exist " )
                             )
                     validObject ( x )
                     return ( x )
                 }
                 )



setReplaceMethod(
      f = "datByGene" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@datByGene <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(f = "sampleNames" ,
                 signature = "IcaSet" ,
                 definition = function (object, value){
                     if (nrow(A(object))>0 & ncol(A(object))>0) {
                         newA <- A(object)
                         rownames(newA) <- value
                         object@A <- newA
                     }
                     if (nrow(datByGene(object))>0 & ncol(datByGene(object))>0){
                         newd <- datByGene(object)
                         colnames(newd) <- value
                         object@datByGene <- newd
                     }
                    callNextMethod()

                      
                 }
)


setReplaceMethod(
      f = "setA" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@A <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "A" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@A <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "dat" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        assayDataElement(object,"dat") <- value
        validObject(object)
        return (object)
     }
)


setReplaceMethod(
      f = "setS" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@S <- value
        return (object)
     }
)

setReplaceMethod(
      f = "S" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@S <- value
        validObject(object)
        return (object)
     }
)


setReplaceMethod(
      f = "setSByGene" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@SByGene <- value
        validObject(object)
        return (object)
     }
)



setReplaceMethod(
      f = "SByGene" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@SByGene <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "setLabelsComp" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@compNames <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "compNames" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@compNames <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "setIndComp" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@indComp <- value
        validObject(object)
        return (object)
     }
)

setReplaceMethod(
      f = "indComp" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@indComp <- value
        validObject(object)
        return (object)
     }
)


setReplaceMethod(
      f = "setWitGenes" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@witGenes <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "witGenes" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@witGenes <- value
        validObject (object)
        return (object)
     }
)


setReplaceMethod(
      f = "chipVersion" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@chipVersion <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "setChipVersion" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@chipVersion <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "chipManu" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@chipManu <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "setChipManu" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@chipManu <- value
        validObject (object)
        return (object)
     }
)


setReplaceMethod( f="refSamples",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@refSamples <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="setRefSamples",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@refSamples <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="typeID",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@typeID <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="setTypeID",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@typeID <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="organism",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@organism <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="setMart",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@mart <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod( f="mart",
      signature = "IcaSet" ,
       definition = function (object, value){
           object@mart <- value
           validObject (object)
           return (object)
      }
)

setReplaceMethod(
      f = "package" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@annotation <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "setPackage" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@annotation <- value
        validObject (object)
        return (object)
     }
)

setReplaceMethod(
      f = "setAnnotation" ,
      signature = "IcaSet" ,
      definition = function (object, value){
        object@annotation <- value
        validObject (object)
        return (object)
     }
)