Nothing
###################################################################################
## MultinomialModel.R ##
###################################################################################
#' @include global.R
#' @include Model.R
NULL
#' MultinomialModel
#'
#' Constructor of [\code{\linkS4class{MultinomialModel}}] class
#'
#' This class defines a multinomial Model. Inherits the [\code{\linkS4class{Model}}] class.
#'
#' \describe{
#' \item{variable.independency}{logical}
#' \item{component.independency}{logical}
#' }
#'
#' @examples
#' new("MultinomialModel")
#' new("MultinomialModel", listModels = c("Binary_pk_E", "Binary_p_E"))
#' new("MultinomialModel", free.proportions = FALSE, variable.independency = TRUE)
#'
#' getSlots("MultinomialModel")
#' @name MultinomialModel-class
#' @rdname MultinomialModel-class
#' @exportClass MultinomialModel
#'
setClass(
Class = "MultinomialModel",
representation = representation(
variable.independency = "logical",
component.independency = "logical"
),
contains = c("Model"),
prototype = prototype(
variable.independency = logical(0),
component.independency = logical(0)
),
validity = function(object) {
# define list of models
vcf <- "Binary_pk_E"
vce <- "Binary_p_E"
f <- c("Binary_pk_Ekj", "Binary_pk_Ekjh")
e <- c("Binary_p_Ekj", "Binary_p_Ekjh")
cf <- "Binary_pk_Ej"
ce <- "Binary_p_Ej"
vf <- "Binary_pk_Ek"
ve <- "Binary_p_Ek"
all.free <- c(vcf, f, cf, vf)
all.equal <- c(vce, e, ce, ve)
variable.free <- c(vcf, vf)
variable.equal <- c(vce, ve)
variable <- c(variable.free, variable.equal)
component.free <- c(vcf, cf)
component.equal <- c(vce, ce)
component <- c(component.free, component.equal)
# all models
all <- c(all.free, all.equal)
# check listModels validity
if (sum(object@listModels %in% all) != length(object@listModels)) {
stop("At least one model is not a valid model. See ?mixmodMultinomialModel for the list of all multinomial models.")
}
# check proportions parameters validity
if (!object@equal.proportions & !object@free.proportions) {
stop("equal.proportions and free.porportions cannot be both as FALSE !")
}
if (!object@free.proportions & (sum(object@listModels %in% all.free) > 0)) {
stop(paste(
"At least one model has a free proportions but free.proportions is set as FALSE.",
"See ?mixmodMultinomialModel for the list of models with equal proportions."
))
}
if (!object@equal.proportions & (sum(object@listModels %in% all.equal) > 0)) {
stop(paste(
"At least one model has an equal proportions but equal.proportions is set as FALSE.",
"See ?mixmodMultinomialModel for the list of models with free proportions."
))
}
# check independencies parameters
# for variable
if (length(object@variable.independency)) {
if (object@variable.independency & sum(object@listModels %in% variable) != length(object@listModels)) {
stop(paste(
"At least one model is not independent of the variable j.",
"See ?mixmodMultinomialModel for the list of all multinomial models."
))
}
}
# for component
if (length(object@component.independency)) {
if (object@component.independency & sum(object@listModels %in% component) != length(object@listModels)) {
stop(paste(
"At least one model is not independent of the variable j.",
"See ?mixmodMultinomialModel for the list of all multinomial models."
))
}
}
}
)
#' Create an instance of the [\code{\linkS4class{MultinomialModel}}] class using new/initialize.
#'
#' Initialization method. Used internally in the `Rmixmod' package.
#'
#' @seealso \code{\link{initialize}}
#'
#' @keywords internal
#'
#' @rdname initialize-methods
#'
setMethod(
f = "initialize",
signature = c("MultinomialModel"),
definition = function(.Object, listModels, free.proportions, equal.proportions, variable.independency,
component.independency) {
# define list of models
vcf <- "Binary_pk_E"
vce <- "Binary_p_E"
f <- c("Binary_pk_Ekj", "Binary_pk_Ekjh")
e <- c("Binary_p_Ekj", "Binary_p_Ekjh")
cf <- "Binary_pk_Ej"
ce <- "Binary_p_Ej"
vf <- "Binary_pk_Ek"
ve <- "Binary_p_Ek"
all.free <- c(vcf, f, cf, vf)
all.equal <- c(vce, e, ce, ve)
variable.free <- c(vcf, vf)
variable.equal <- c(vce, ve)
variable <- c(variable.free, variable.equal)
component.free <- c(vcf, cf)
component.equal <- c(vce, ce)
component <- c(component.free, component.equal)
if (!missing(listModels)) {
# save the list of models
.Object@listModels <- listModels
# set free.proportions
if (missing(free.proportions)) {
if (sum(listModels %in% all.free)) {
.Object@free.proportions <- TRUE
} else {
.Object@free.proportions <- FALSE
}
} else {
.Object@free.proportions <- free.proportions
}
# set equal.proportions
if (missing(equal.proportions)) {
if (sum(listModels %in% all.equal)) {
.Object@equal.proportions <- TRUE
} else {
.Object@equal.proportions <- FALSE
}
} else {
.Object@equal.proportions <- equal.proportions
}
# set variable.independency
if (missing(variable.independency)) {
if (sum(listModels %in% variable) == length(listModels)) {
.Object@variable.independency <- TRUE
}
} else {
.Object@variable.independency <- variable.independency
}
# set component.independency
if (missing(component.independency)) {
if (sum(listModels %in% component) == length(listModels)) {
.Object@component.independency <- TRUE
}
} else {
.Object@component.independency <- component.independency
}
} else {
# check free.proportions option
if (missing(free.proportions)) {
.Object@free.proportions <- TRUE
} else {
.Object@free.proportions <- free.proportions
}
# check equal.proportions option
if (missing(equal.proportions)) {
.Object@equal.proportions <- TRUE
} else {
.Object@equal.proportions <- equal.proportions
}
# define an empty list of models
list <- character(0)
if (!missing(variable.independency) & !missing(component.independency)) {
if (variable.independency & component.independency) {
if (.Object@free.proportions) {
list <- c(list, vcf)
}
if (.Object@equal.proportions) {
list <- c(list, vce)
}
} else if (!variable.independency & !component.independency) {
if (.Object@free.proportions) {
list <- c(list, f)
}
if (.Object@equal.proportions) {
list <- c(list, e)
}
} else if (!variable.independency & component.independency) {
if (.Object@free.proportions) {
list <- c(list, cf)
}
if (.Object@equal.proportions) {
list <- c(list, ce)
}
} else if (variable.independency & !component.independency) {
if (.Object@free.proportions) {
list <- c(list, vf)
}
if (.Object@equal.proportions) {
list <- c(list, ve)
}
}
.Object@component.independency <- component.independency
.Object@variable.independency <- variable.independency
} else if (!missing(component.independency)) {
if (component.independency) {
if (.Object@free.proportions) {
list <- c(list, component.free)
}
if (.Object@equal.proportions) {
list <- c(list, component.equal)
}
} else {
if (.Object@free.proportions) {
list <- c(list, f, vf)
}
if (.Object@equal.proportions) {
list <- c(list, e, ve)
}
}
.Object@component.independency <- component.independency
.Object@variable.independency <- logical(0)
} else if (!missing(variable.independency)) {
if (variable.independency) {
if (.Object@free.proportions) {
list <- c(list, variable.free)
}
if (.Object@equal.proportions) {
list <- c(list, variable.equal)
}
} else {
if (.Object@free.proportions) {
list <- c(list, f, cf)
}
if (.Object@equal.proportions) {
list <- c(list, e, ce)
}
}
.Object@component.independency <- logical(0)
.Object@variable.independency <- variable.independency
} else {
# all multinomial models with free proportions
if (.Object@free.proportions) {
list <- c(list, all.free)
}
# all multinomial models with equal proportions
if (.Object@equal.proportions) {
list <- c(list, all.equal)
}
.Object@component.independency <- logical(0)
.Object@variable.independency <- logical(0)
}
# create the list of models depending on the proportions option
.Object@listModels <- list
}
validObject(.Object)
return(.Object)
}
)
#' Create an instance of the [\code{\linkS4class{MultinomialModel}}] class
#'
#' Define a list of multinomial model to test in MIXMOD.
#'
#' In the multinomial mixture model, the multinomial distribution is associated to the \eqn{j}th variable of the
#' \eqn{k}th component is reparameterized by a center \eqn{a_k^j} and the dispersion \eqn{\varepsilon_k^j} around this center.
#' Thus, it allows us to give an interpretation similar to the center and the variance matrix used for continuous data in the
#' Gaussian mixture context. In the following, this model will be denoted by \eqn{[\varepsilon_k^j]}. In this context, three
#' other models can be easily deduced. We note \eqn{[\varepsilon_k]} the model where \eqn{\varepsilon_k^j} is independent of
#' the variable \eqn{j}, \eqn{[\varepsilon^j]} the model where \eqn{\varepsilon_k^j} is independent of the component \eqn{k}
#' and, finally, \eqn{[\varepsilon]} the model where \eqn{\varepsilon_k^j} is independent of both the variable $j$ and the
#' component \eqn{k}. In order to maintain some unity in the notation, we will denote also \eqn{[\varepsilon_k^{jh}]} the most
#' general model introduced at the previous section.
#'
#' @param listModels a list of characters containing a list of models. It is optional.
#' @param free.proportions logical to include models with free proportions. Default is TRUE.
#' @param equal.proportions logical to include models with equal proportions. Default is FALSE.
#' @param variable.independency logical to include models where \eqn{[\varepsilon_k^j]} is independent of the variable \eqn{j}.
#' optional.
#' @param component.independency logical to include models where \eqn{[\varepsilon_k^j]} is independent of the component
#' \eqn{k}. optional.
#'
#' @return an object of [\code{\linkS4class{MultinomialModel}}] containing some of the 10 Binary Models:
#' \tabular{rlll}{
#' Model \tab Prop. \tab Var. \tab Comp. \cr
#' Binary_p_E \tab Equal \tab TRUE \tab TRUE \cr
#' Binary_p_Ej \tab \tab FALSE \tab TRUE \cr
#' Binary_p_Ek \tab \tab TRUE \tab FALSE \cr
#' Binary_p_Ekj \tab \tab FALSE \tab FALSE \cr
#' Binary_p_Ekjh \tab \tab FALSE \tab FALSE \cr
#' Binary_pk_E \tab Free \tab TRUE \tab TRUE \cr
#' Binary_pk_Ej \tab \tab FALSE \tab TRUE \cr
#' Binary_pk_Ek \tab \tab TRUE \tab FALSE \cr
#' Binary_pk_Ekj \tab \tab FALSE \tab FALSE \cr
#' Binary_pk_Ekjh \tab \tab FALSE \tab FALSE \cr
#' }
#'
#' @references C. Biernacki, G. Celeux, G. Govaert, F. Langrognet. "Model-Based Cluster and Discriminant Analysis with the
#' MIXMOD Software". Computational Statistics and Data Analysis, vol. 51/2, pp. 587-600. (2006)
#' @examples
#' mixmodMultinomialModel()
#' # multinomial models with equal proportions
#' mixmodMultinomialModel(equal.proportions = TRUE, free.proportions = FALSE)
#' # multinomial models with a pre-defined list
#' mixmodMultinomialModel(listModels = c("Binary_pk_E", "Binary_p_E"))
#' # multinomial models with equal proportions and independent of the variable
#' mixmodMultinomialModel(free.proportions = FALSE, variable.independency = TRUE)
#' @author Florent Langrognet and Remi Lebret and Christian Poli ans Serge Iovleff, with contributions from C. Biernacki and
#' G. Celeux and G. Govaert \email{contact@@mixmod.org}
#' @export
#'
mixmodMultinomialModel <- function(listModels = NULL, free.proportions = TRUE, equal.proportions = TRUE,
variable.independency = NULL, component.independency = NULL) {
if (!is.null(listModels)) {
new("MultinomialModel", listModels = listModels)
} else {
if (!is.null(variable.independency) && !is.null(component.independency)) {
new("MultinomialModel",
free.proportions = free.proportions, equal.proportions = equal.proportions,
variable.independency = variable.independency, component.independency = component.independency
)
} else if (!is.null(variable.independency) && is.null(component.independency)) {
new("MultinomialModel",
free.proportions = free.proportions, equal.proportions = equal.proportions,
variable.independency = variable.independency
)
} else if (is.null(variable.independency) && !is.null(component.independency)) {
new("MultinomialModel",
free.proportions = free.proportions, equal.proportions = equal.proportions,
component.independency = component.independency
)
} else {
new("MultinomialModel", free.proportions = free.proportions, equal.proportions = equal.proportions)
}
}
}
#' @rdname extract-methods
#' @aliases [,MultinomialModel-method
#'
setMethod(
f = "[",
signature(x = "MultinomialModel"),
definition = function(x, i, j, drop) {
if (missing(j)) {
switch(EXPR = i,
"listModels" = {
return(x@listModels)
},
"free.proportions" = {
return(x@free.proportions)
},
"equal.proportions" = {
return(x@equal.proportions)
},
"variable.independency" = {
return(x@variable.independency)
},
"component.independency" = {
return(x@component.independency)
},
stop("This attribute doesn't exist !")
)
} else {
switch(EXPR = i,
"listModels" = {
return(x@listModels[j])
},
stop("This attribute doesn't exist !")
)
}
}
)
# ' @name [
#' @rdname extract-methods
#' @aliases [<-,MultinomialModel-method
#'
setReplaceMethod(
f = "[",
signature(x = "MultinomialModel"),
definition = function(x, i, j, value) {
if (missing(j)) {
switch(EXPR = i,
"listModels" = {
x@listModels <- value
},
"free.proportions" = {
x@free.proportions <- value
},
"equal.proportions" = {
x@equal.proportions <- value
},
"variable.independency" = {
x@variable.independency <- value
},
"component.independency" = {
x@component.independency <- value
},
stop("This attribute doesn't exist !")
)
} else {
switch(EXPR = i,
"listModels" = {
x@listModels[j] <- value
},
stop("This attribute doesn't exist !")
)
}
validObject(x)
return(x)
}
)
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.