R/methods.for.models.R

In MPTinR2: Analyze Multinomial Processing Tree Models

######################################################
## assignment/accessor functions for some slots.    ##
## (thanks to the kernlab package for the template) ##
######################################################

###### Overall ######


# Method to get the degrees of freedom from either a model objected or fitted model object
if(!isGeneric("model.df")){
	if (is.function("model.df"))
		fun <- model.df
	else fun <- function(object) standardGeneric("model.df")
	setGeneric("model.df", fun)
}
setMethod("model.df", "mpt.model", function(object) object@check[["df"]][["model"]])
setMethod("model.df", "mpt", function(object) object@model@check[["df"]][["model"]])
setGeneric("model.df<-", function(x, value) standardGeneric("model.df<-"))
setReplaceMethod("model.df", "mpt.model", function(x, value) {
	if (!is.numeric(value)) stop("the mdf for the model must be numeric")
	x@check[["df"]][["model"]] <- value
	x
})
setReplaceMethod("model.df", "mpt", function(x, value) {
	if (!is.numeric(value)) stop("the mdf for the model must be numeric")
	object@model@check[["df"]][["model"]] <- value
	x
})


########################
## Methods for Models ##
########################

##### MPT Model #####

if(!isGeneric("check")){
	if (is.function("check"))
		fun <- check
	else fun <- function(object) standardGeneric("check")
	setGeneric("check", fun)
}
setMethod("check", "mpt.model", function(object) object@check)
setGeneric("check<-", function(x, value) standardGeneric("check<-"))
setReplaceMethod("check", "mpt.model", function(x, value) {
	if (!is.list(value)) stop("the model check must be a list")
	x@check <- value
	x
})

if(!isGeneric("initial.model")){
	if (is.function("initial.model"))
		fun <- initial.model
	else fun <- function(object) standardGeneric("initial.model")
	setGeneric("initial.model", fun)
}
setMethod("initial.model", "mpt.model", function(object) object@initial.model)
setGeneric("initial.model<-", function(x, value) standardGeneric("initial.model<-"))
setReplaceMethod("initial.model", "mpt.model", function(x, value) {
	if (!is.list(value)) stop("the initial model must be a list")
	x@initial.model <- value
	x
})

if(!isGeneric("model.data.frame")){
	if (is.function("model.data.frame"))
		fun <- model.data.frame
	else fun <- function(object) standardGeneric("model.data.frame")
	setGeneric("model.data.frame", fun)
}
setMethod("model.data.frame", "mpt.model", function(object) object@model.data.frame)
setGeneric("model.data.frame<-", function(x, value) standardGeneric("model.data.frame<-"))
setReplaceMethod("model.data.frame", "mpt.model", function(x, value) {
	if (!is.data.frame(value)) stop("the model.data.frame must be a data.frame")
	x@model.data.frame <- value
	x
})

if(!isGeneric("model.list")){
	if (is.function("model.list"))
		fun <- model.list
	else fun <- function(object) standardGeneric("model.list")
	setGeneric("model.list", fun)
}
setMethod("model.list", "mpt.model", function(object) object@model.list)
setGeneric("model.list<-", function(x, value) standardGeneric("model.list<-"))
setReplaceMethod("model.list", "mpt.model", function(x, value) {
	if (!is.list(value)) stop("the model.list must be a list")
	x@model.list <- value
	x
})

if(!isGeneric("initial.model.data.frame")){
	if (is.function("initial.model.data.frame"))
		fun <- initial.model.data.frame
	else fun <- function(object) standardGeneric("initial.model.data.frame")
	setGeneric("initial.model.data.frame", fun)
}
setMethod("initial.model.data.frame", "mpt.model", function(object) object@initial.model.data.frame)
setGeneric("initial.model.data.frame<-", function(x, value) standardGeneric("initial.model.data.frame<-"))
setReplaceMethod("initial.model.data.frame", "mpt.model", function(x, value) {
	if (!is.data.frame(value)) stop("the initial.model.data.frame must be a data.frame")
	x@initial.model.data.frame <- value
	x
})

### BMPT model ###

if(!isGeneric("A")){
	if (is.function("A"))
		fun <- A
	else fun <- function(object) standardGeneric("A")
	setGeneric("A", fun)
}
setMethod("A", "bmpt.model", function(object) object@A)
setGeneric("A<-", function(x, value) standardGeneric("A<-"))
setReplaceMethod("A", "bmpt.model", function(x, value) {
	if (!is.array(value)) stop("A must be an array")
	x@A <- value
	x
})

if(!isGeneric("B")){
	if (is.function("B"))
		fun <- B
	else fun <- function(object) standardGeneric("B")
	setGeneric("B", fun)
}
setMethod("B", "bmpt.model", function(object) object@B)
setGeneric("B<-", function(x, value) standardGeneric("B<-"))
setReplaceMethod("B", "bmpt.model", function(x, value) {
	if (!is.array(value)) stop("B must be an array")
	x@B <- value
	x
})

if(!isGeneric("lbmpt")){
	if (is.function("lbmpt"))
		fun <- lbmpt
	else fun <- function(object) standardGeneric("lbmpt")
	setGeneric("lbmpt", fun)
}
setMethod("lbmpt", "bmpt.model", function(object) object@lbmpt)
setGeneric("lbmpt<-", function(x, value) standardGeneric("lbmpt<-"))
setReplaceMethod("lbmpt", "bmpt.model", function(x, value) {
	if (!is.character(value)) stop("lbmpt must be a character vector")
	x@lbmpt <- value
	x
})