R/ternaryFit-methods.R

In mccallm/ternarynet: Ternary Network Estimation

ternaryFit <- function(perturbationObj, steadyStateObj, geneNames, experimentNames, degreeObjMin, graphObjMin, tableObjMin, newScore, minScore, finalTemperature, traces, stageCount, xSeed, inputParams) {
  new("ternaryFit", perturbationObj = perturbationObj, steadyStateObj = steadyStateObj, geneNames = geneNames, experimentNames = experimentNames, degreeObjMin = degreeObjMin, graphObjMin = graphObjMin, tableObjMin = tableObjMin, newScore = newScore, minScore = minScore, finalTemperature = finalTemperature, traces = traces, stageCount = stageCount, xSeed = xSeed, inputParams = inputParams)
}

## dim method
setMethod("dim", "ternaryFit", function(x) dim(x@perturbationObj))

## slot getters
setMethod("perturbationObj", "ternaryFit", function(x) x@perturbationObj)
setMethod("steadyStateObj", "ternaryFit", function(x) x@steadyStateObj)
setMethod("geneNames", "ternaryFit", function(x) x@geneNames)
setMethod("experimentNames", "ternaryFit", function(x) x@experimentNames)
setMethod("degreeObjMin", "ternaryFit", function(x) x@degreeObjMin)
setMethod("graphObjMin", "ternaryFit", function(x) x@graphObjMin)
setMethod("tableObjMin", "ternaryFit", function(x) x@tableObjMin)
setMethod("newScore", "ternaryFit", function(x) x@newScore)
setMethod("minScore", "ternaryFit", function(x) x@minScore)
setMethod("finalTemperature", "ternaryFit", function(x) x@finalTemperature)
setMethod("xSeed", "ternaryFit", function(x) x@xSeed)
setMethod("inputParams", "ternaryFit", function(x) x@inputParams)
setMethod("traces", "ternaryFit", function(x) x@traces)
setMethod("stageCount", "ternaryFit", function(x) x@stageCount)

## show method
setMethod("show", "ternaryFit", function(object) {
  cat(class(object), "instance with", dim(object)[2], "perturbation experiments, measuring", dim(object)[2], "genes \n")
  cat("Gene names:", geneNames(object), "\n")
  cat("Experiment names:", experimentNames(object), "\n")
})

## validity method
setValidity("ternaryFit", function(object) {
  nGene <- nrow(perturbationObj(object))
  nExperiment <- ncol(perturbationObj(object))

  if (nrow(steadyStateObj(object)) != nGene || ncol(steadyStateObj(object)) != nExperiment) {
    return("'steadyStateObj' slot and 'pertubationObj' slot must have the same dimensions")
  }
  indp <- which(perturbationObj(object) != 0, arr.ind = TRUE)
  if (any(steadyStateObj(object)[indp] != perturbationObj(object)[indp])) {
    return("Non-zero elements of 'perturbationObj' slot must match corresponding elements of 'steadyStateObj'")
  }
  if (length(degreeObjMin(object)) != nGene) {
    return("'degreeObjMin' slot must have length equal to the number of rows of the 'perturbationObj' slot")
  }
  if (nrow(graphObjMin(object)) != nGene || ncol(graphObjMin(object)) != nGene) {
    return("'graphObjMin' slot must be a matrix with row and column lengths equal to the number of rows of the 'perturbationObj' slot")
  }
  if (ncol(tableObjMin(object)) != nGene) {
    return("'tableObjMin' slot must be a matrix with row length equal to the number of rows of the 'perturbationObj' slot")
  }
  if (!is.numeric(newScore(object)) || length(newScore(object)) != 1 || is.na(newScore(object))) {
    return("'newScore' slot must be a single numeric")
  }
  if (!is.numeric(minScore(object)) || length(minScore(object)) != 1 || is.na(minScore(object))) {
    return("'minScore' slot must be a single numeric")
  }
  if (!is.numeric(finalTemperature(object)) || length(finalTemperature(object)) != 1 || is.na(finalTemperature(object))) {
    return("'finalTemperature' slot must be a single numeric")
  }
  if (!is.integer(xSeed(object)) || length(xSeed(object)) != 1 || is.na(xSeed(object))) {
    return("'xSeed' slot must be a single integer")
  }
  if (!is(inputParams(object), "ternaryFitParameters")) {
    return("'inputParams' slot must be an object of class 'ternaryFitParameters")
  }
  TRUE
})

## slot setters
setReplaceMethod("perturbationObj", "ternaryFit", function(x, value) {
  x@perturbationObj <- value
  validObject(x)
  x
})
setReplaceMethod("steadyStateObj", "ternaryFit", function(x, value) {
  x@steadyStateObj <- value
  validObject(x)
  x
})
setReplaceMethod("geneNames", "ternaryFit", function(x, value) {
  x@geneNames <- value
  validObject(x)
  x
})
setReplaceMethod("experimentNames", "ternaryFit", function(x, value) {
  x@experimentNames <- value
  validObject(x)
  x
})
setReplaceMethod("degreeObjMin", "ternaryFit", function(x, value) {
  x@degreeObjMin <- value
  validObject(x)
  x
})
setReplaceMethod("graphObjMin", "ternaryFit", function(x, value) {
  x@graphObjMin <- value
  validObject(x)
  x
})
setReplaceMethod("tableObjMin", "ternaryFit", function(x, value) {
  x@tableObjMin <- value
  validObject(x)
  x
})
setReplaceMethod("newScore", "ternaryFit", function(x, value) {
  x@newScore <- value
  validObject(x)
  x
})
setReplaceMethod("minScore", "ternaryFit", function(x, value) {
  x@minScore <- value
  validObject(x)
  x
})
setReplaceMethod("finalTemperature", "ternaryFit", function(x, value) {
  x@finalTemperature <- value
  validObject(x)
  x
})
setReplaceMethod("xSeed", "ternaryFit", function(x, value) {
  x@xSeed <- value
  validObject(x)
  x
})
setReplaceMethod("inputParams", "ternaryFit", function(x, value) {
  x@inputParams <- value
  validObject(x)
  x
})
setReplaceMethod("traces", "ternaryFit", function(x, value) {
  x@traces <- value
  validObject(x)
  x
})
setReplaceMethod("stageCount", "ternaryFit", function(x, value) {
  x@stageCount <- value
  validObject(x)
  x
})