R/MultinomialModel.R

In Rmixmod: Classification with Mixture Modelling

###################################################################################
##                             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)
  }
)