R/matrixData.R

In jdrudolph/PerseusR: Perseus R Interop

#' Check perseus compatibility of an object
#'
#' @rdname MatrixDataCheck
#'
#' @title MatrixDataCheck: a function to check the validity of an object as a perseus data frame
#'
#' @param object object to check consistency with perseus data frames
#' @param ... additional arguments passed to the respective method
#' @param main Main Data frame
#' @param annotationRows Rows containing annotation information
#' @param annotationCols Columns containing annotation information
#' @param descriptions Descriptions of all the columns
#' @param imputeData Is imputed or not
#' @param qualityData quality number
#' @param all_colnames The colnames to be used
#'
#' @return a logical indicating the validity of the object
#' (or series of objects) as a perseus DF or the string of errors
#'
#' @export
#'
#' @examples
#'
#' require(PerseusR)
#'
#' mat <- matrixData(
#'     main=data.frame(a=1:3, b=6:8),
#'     annotCols=data.frame(c=c('a','b','c')),
#'     annotRows=data.frame(x=factor(c('1','1'))))
#'
#' MatrixDataCheck(mat)
#'
MatrixDataCheck <- function(object, ...) {
  UseMethod("MatrixDataCheck", object)
}


#' @rdname MatrixDataCheck
#' @method MatrixDataCheck default
#'
#' @export
MatrixDataCheck.default <- function(object = NULL,  main,
                                    annotationRows, annotationCols,
                                    descriptions, imputeData, qualityData,
                                    all_colnames, ...) {
  errors <- character()

  # We could consider using a numeric matrix instead of
  # a df as the main matrix (since by default is a single
  # class )

  numCols <- sapply(main, is.numeric)
  if (!all(numCols)) {
    msg <- paste('Main columns should be numeric: Columns',
                 paste(names(which(!numCols)), sep = ','),
                 'are not numeric')
    errors <- c(errors, msg)
  }

  if (ncol(annotationRows) > 0) {
    catAnnotRows <- sapply(annotationRows, is.factor)
    numAnnotRows <- sapply(annotationRows, is.numeric)
    if (!all(catAnnotRows | numAnnotRows)) {
      msg <- paste('Annotation rows should be factors or numeric: Rows',
                   paste(names(which(!(catAnnotRows | numAnnotRows))), sep = ','),
                   'are not factors')
      errors <- c(errors, msg)
    }

    nColMain <- ncol(main)
    nColAnnotRows <- nrow(annotationRows)
    if (nColMain != nColAnnotRows) {
      msg <- paste('Size of annotation rows not matching:',
                   nColMain, 'main columns, but',
                   nColAnnotRows, 'annotations')
      errors <- c(errors, msg)
    }
  }

  nMain <- nrow(main)
  nAnnot <- nrow(annotationCols)

  if (nAnnot > 0 && nMain > 0 && nMain != nAnnot) {
    msg <- paste('Number of rows not matching:',
                 nMain, 'rows in main data, but',
                 nAnnot, 'rows in annotation columns.')
    errors <- c(errors, msg)
  }

  nDescr <- length(descriptions)
  if (nDescr > 0 && nDescr != length(all_colnames)) {
    msg <- paste('Descriptions do not fit columns, found',
                 nDescr, 'expected', length(all_colnames))
    errors <- c(errors, msg)
  }

  if (length(errors) == 0) TRUE else stop(errors)
}

#' @return \code{NULL}
#'
#' @inheritParams MatrixDataCheck.default
#'
#' @rdname MatrixDataCheck
#' @method MatrixDataCheck matrixData
#'
#' @export
MatrixDataCheck.matrixData <- function(object, ...) {
  mainDF <- object@main
  annotationRows <- object@annotRows
  annotationCols <- object@annotCols
  descriptions <- object@description
  imputeData <- object@imputeData
  qualityData <- object@qualityData
  all_colnames <- c(colnames(mainDF), colnames(annotationCols))

  ret <- MatrixDataCheck.default(main = mainDF,
                         annotationRows = annotationRows,
                         annotationCols = annotationCols,
                         descriptions = descriptions,
                         imputeData = imputeData,
                         qualityData = qualityData,
                         all_colnames = all_colnames)
  return(ret)
}


#' @return \code{NULL}
#'
#' @inheritParams MatrixDataCheck.default
#'
#' @rdname MatrixDataCheck
#' @method MatrixDataCheck list
#'
#' @export
MatrixDataCheck.list <- function(object, ...) {
  stopifnot(is.list(object))
  stopifnot(sum(c('main', 'annotCols') %in% names(object)) > 0)

  slots <- c('main', 'annotRows',
             'annotCols', 'descriptions', 'imputeData',
             'qualityData')
  defaults <- c(
    replicate(3, quote(data.frame())),
    quote(character(
      length = ncol(object$main) + ncol(object$annotationCols))))

  for (element in seq_along(slots)) {
    object[[slots[element]]] <- tryCatch(
      object[[slots[element]]],
      error = function(...) eval(defaults[[element]]) )
  }
  all_colnames <- c(colnames(object$main), colnames(object$annotationCols))
  ret <- MatrixDataCheck.default(main = object$main,
                                 annotationRows = object$annotRows,
                                 annotationCols = object$annotCols,
                                 descriptions = object$descriptions,
                                 imputeData = object$imputeData,
                                 qualityData = object$qualityData,
                                 all_colnames = all_colnames)
  if (is.logical(ret) & ret) {
    return(ret)
  } else {
    stop(ret)
  }
}


#' @return \code{NULL}
#'
#' @inheritParams MatrixDataCheck.default
#'
#' @rdname MatrixDataCheck
#' @method MatrixDataCheck ExpressionSet
#'
#' @export
MatrixDataCheck.ExpressionSet <- function(object, ...) {
  if (!requireNamespace("Biobase", quietly = TRUE)) {
    stop('This function requires the Biobase package, please install it in the bioconductor repository')
  }

  mainDF <- data.frame(Biobase::exprs(object))
  annotationRows <- methods::as(object@phenoData, 'data.frame')
  descriptions <- Biobase::annotation(object)
  annotationCols <- methods::as(object@featureData, 'data.frame')
  all_colnames <- c(colnames(mainDF), colnames(annotationCols))

  ret <- MatrixDataCheck.default(main=mainDF,
                                 annotationRows=annotationRows,
                                 annotationCols=annotationCols,
                                 descriptions=descriptions,
                                 all_colnames=all_colnames)
  if (is.logical(ret) & ret) {
    return(ret)
  } else {
    stop(ret)
  }
}


#' MatrixData
#' @slot main Main expression \code{data.frame}.
#' @slot annotCols Annotation Columns \code{data.frame}.
#' @slot annotRows Annotation Rows \code{data.frame}.
#' @slot description Column descriptions.
#' @slot imputeData Imputation \code{data.frame}.
#' @slot qualityData Quality values \code{data.frame}.
#'
#' @name matrixData-class
#' @rdname matrixData-class
#' @family matrixData basic functions
#'
#' @export
setClass("matrixData",
         slots = c(main = "data.frame",
                   annotCols = "data.frame",
                   annotRows = "data.frame",
                   description = "character",
                   imputeData = "data.frame",
                   qualityData = "data.frame"),
         validity = function(object) {MatrixDataCheck.matrixData(object)})

#' matrixData constructor
#' @param ... \code{main}, \code{annotCols}, \code{annotRows}, \code{description}, \code{imputeData}, \code{qualityData}
#' @inherit matrixData-class
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' description=c('aaa', 'bbb', 'ccc'),
#' imputeData=data.frame(impute=c('False', 'True', 'False')),
#' qualityData=data.frame(quality=c('0', '1', '0')))
#' @export
matrixData <- function(...) {
  methods::new("matrixData", ...)
}

#' matrixData initializer
#' @param .Object Initialized object
#' @param ... Additional arguments
#' @description Initializes the annotCols data frame to have the
#' same number of rows as the main data. This might not be the
#' cleanest solution.
#' @importFrom methods callNextMethod
setMethod(initialize, "matrixData", function(.Object, ...) {
  args <- list(...)
  if ("main" %in% names(args) && !("annotCols" %in% names(args))) {
    main <- args[['main']]
    args[["annotCols"]] <- data.frame(matrix(nrow=nrow(main), ncol=0))
  }

  args[['.Object']] <- .Object
  do.call(callNextMethod, args)
})


getNames <- function(x) {c(colnames(x@main), colnames(x@annotCols))}
#TODO: check if it would be better to have a list returned with one element
#having the col names and the other the row names


#' Get names
#'
#' Get the column names of main and annotation columns.
#'
#' @param x matrixData
#' @family matrixData basic functions
#' @export
#' @docType methods
#' @rdname matrixData-methods
setMethod("names", "matrixData", getNames)

#' Column names of main and annotation columns
#' @param x matrixData
#' @export
names.matrixData <- getNames

#' Get main columns
#'
#' Gets the main columns (main matrix) of a \code{\link[PerseusR]{matrixData}}
#' object as a data.frame object
#'
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' main(mdata)
#' @export
main <- function(mdata) {
  mdata@main
}

#' Set main columns
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' value<-data.frame(c=c(0,0,0), d=c(1,1,1))
#' main(mdata) <- value
#' @export
`main<-` <- function(mdata, value) {
  mdata@main <- value
  methods::validObject(mdata)
  return(mdata)
}

#' Get annotation columns
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' annotCols(mdata)
#' @export
annotCols <- function(mdata) {
  mdata@annotCols
}

#' Set annotation columns
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' value <- data.frame(d=c('d', 'e', 'f'))
#' annotCols(mdata) <- value
#' @export
`annotCols<-` <- function(mdata, value) {
  mdata@annotCols <- value
  methods::validObject(mdata)
  return(mdata)
}

#' Get annotation rows
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' annotRows(mdata)
#' @export
annotRows <- function(mdata) {
  mdata@annotRows
}

#' Set annotation rows
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' value <- data.frame(y=factor(c('2','2')))
#' annotRows(mdata) <- value
#' @export
`annotRows<-` <- function(mdata, value) {
  mdata@annotRows <- value
  methods::validObject(mdata)
  return(mdata)
}

#' Get column description
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' description=c('aaa', 'bbb', 'ccc'))
#' description(mdata)
#' @export
description <- function(mdata) {
  mdata@description
}

#' Set column description
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))))
#' value <- c('aaa', 'bbb', 'ccc')
#' description(mdata) <- value
#' @export
`description<-` <- function(mdata, value) {
  mdata@description <- value
  methods::validObject(mdata)
  return(mdata)
}

#' Get imputation of main data frame
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' imputeData=data.frame(impute=c('False', 'True', 'False')))
#' imputeData(mdata)
#' @export
imputeData <- function(mdata) {
  mdata@imputeData
}

#' Set imputation of main data frame
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' imputeData=data.frame(impute=c('False', 'True', 'False')))
#' value <- data.frame(impute=c('True', 'True', 'True'))
#' imputeData(mdata) <- value
#' @export
`imputeData<-` <- function(mdata, value) {
  mdata@imputeData <- value
  methods::validObject(mdata)
  return(mdata)
}

#' Get quality values of main data frame
#' @param mdata matrixData
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' qualityData=data.frame(quality=c('1', '1', '1')))
#' qualityData(mdata)
#' @export
qualityData <- function(mdata) {
  mdata@qualityData
}

#' Set quality values of main data frame
#' @param mdata matrixData
#' @param value value
#' @family matrixData basic functions
#' @examples
#' mdata <- matrixData(main=data.frame(a=1:3, b=6:8),
#' annotCols=data.frame(c=c('a','b','c')),
#' annotRows=data.frame(x=factor(c('1','1'))),
#' qualityData=data.frame(quality=c('1', '1', '1')))
#' value <- data.frame(quality=c('0', '0', '0'))
#' qualityData(mdata) <- value
#' @export
`qualityData<-` <- function(mdata, value) {
  mdata@qualityData <- value
  methods::validObject(mdata)
  return(mdata)
}

setMethod("Ops", signature(e1 = "matrixData", e2 = "matrixData"),
          function(e1, e2) {
            e1@main <- methods::callGeneric(main(e1), main(e2))
            methods::validObject(e1)
            return(e1)
          }
)
setMethod("Ops", signature(e1 = "matrixData", e2 = "numeric"),
          function(e1, e2) {
            e1@main <- methods::callGeneric(main(e1), e2)
            methods::validObject(e1)
            return(e1)
          }
)
setMethod("Ops", signature(e1 = "numeric", e2 = "matrixData"),
          function(e1, e2) {
            e1@main <- methods::callGeneric(e1, main(e2))
            methods::validObject(e1)
            return(e1)
          }
)