Nothing
##################################################################################
# MixmodLearn.R ##
##################################################################################
#' @include global.R
#' @include Mixmod.R
#' @include MixmodDAResults.R
#' @include GaussianParameter.R
#' @include MultinomialParameter.R
#' @include GaussianModel.R
#' @include MultinomialModel.R
NULL
#' Constructor of [\code{\linkS4class{MixmodLearn}}] class
#'
#' This is a class to run discriminant analysis with mixmod. Inherits the [\code{\linkS4class{Mixmod}}] class.
#'
#' \describe{
#' \item{bestResult}{a S4 [\code{\linkS4class{MixmodDAResults}}] object containing the best model results.}
#' \item{nbCVBlocks}{integer which defines the number of block to perform the Cross Validation.}
#' }
#' @examples
#' ## A quantitative example with the famous iris data set
#' new("MixmodLearn", data = iris[1:4], knownLabels = iris$Species)
#'
#' getSlots("MixmodLearn")
#' @name MixmodLearn-class
#' @rdname MixmodLearn-class
#' @exportClass MixmodLearn
#'
setClass(
Class = "MixmodLearn",
representation = representation(
nbCVBlocks = "numeric",
bestResult = "MixmodDAResults"
),
contains = c("Mixmod"),
prototype = prototype(
nbCVBlocks = 10
),
# define validity function
validity = function(object) {
# check whether the knownLabels is missing
if (length(object@knownLabels) == 0) {
stop("labels are missing!")
}
# check the number of cluster
if ((min(as.integer(object@knownLabels)) <= 0)) {
stop("Each observation in knownLabels must have a valid cluster affectation !")
}
# check criterion parameter
if (sum(object@criterion %in% c("BIC", "CV")) != length(object@criterion)) {
stop(cat(object@criterion[which(!(object@criterion %in% c("BIC", "CV")))], "is not a valid criterion name !\n"))
}
# check number of CV blocks
if (!is.wholenumber(object@nbCVBlocks) | (object@nbCVBlocks < 1)) {
stop("the number of CV blocks is not valid!")
}
return(TRUE)
}
)
#' Create an instance of the [\code{\linkS4class{MixmodLearn}}] 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("MixmodLearn"),
# mixmodLearn <- function(data, knownLabels, dataType=NULL, models=NULL, criterion="CV", nbCVBlocks=10, weight=NULL) {
definition = function(.Object, data = NULL, knownLabels = NULL, dataType = NULL, models = NULL, criterion = "CV",
nbCVBlocks = 10, weight = NULL, seed = -1, xmlIn = NULL, xmlOut = NULL, trace = 0, massiccc = 0) {
if (!missing(xmlIn)) {
if (!missing(criterion) || !missing(nbCVBlocks)) {
stop("xmlIn argument is mutually exclusive with all other arguments but xmlOut, seed and trace")
}
} else { # i.e without xmlIn
if (missing(knownLabels)) {
stop("knownLabels is missing !")
}
if (!is.vector(knownLabels) & !is.factor(knownLabels)) {
stop("knownLabels must be a vector or a factor")
}
.Object@knownLabels <- knownLabels
}
# call initialize method of abstract class Mixmod
# .Object<-callNextMethod(.Object, data, ...)
.Object <- callNextMethod(.Object,
data = data, dataType = dataType, models = models, weight = weight,
knownLabels = knownLabels, xmlIn = xmlIn, xmlOut = xmlOut, seed = seed, trace = trace, massiccc = massiccc
)
if (length(.Object@data)) {
# create MixmodDAResults object
if (.Object@dataType == "quantitative") {
.Object@bestResult <- new("MixmodDAResults")
.Object@bestResult@parameters <- new("GaussianParameter")
} else if (.Object@dataType == "qualitative") {
.Object@bestResult <- new("MixmodDAResults")
.Object@bestResult@parameters <- new("MultinomialParameter")
} else if (.Object@dataType == "composite") {
.Object@bestResult <- new("MixmodDAResults")
.Object@bestResult@parameters <- new("CompositeParameter")
.Object@bestResult@parameters@factor <- .Object@factor
}
# create nbCluster
if (length(.Object@knownLabels)) {
.Object@nbCluster <- max(as.integer(.Object@knownLabels))
}
.Object@criterion <- criterion
.Object@nbCVBlocks <- nbCVBlocks
# if (is.na(criterion)) {
# .Object@criterion <- "CV"
# }else{
# .Object@criterion <- criterion
# }
# if (is.na(nbCVBlocks)) {
# .Object@nbCVBlocks <- 10
# } else {
# .Object@nbCVBlocks <- nbCVBlocks
# }
validObject(.Object)
} else if (!missing(xmlIn)) {
.Object@bestResult@parameters <- new("CompositeParameter")
}
return(.Object)
}
)
#' mixmodLearn
#'
#' TODO: describe...
#'
#' @param ... ...
#'
#' @export
#'
mixmodLearn <- function(...) {
# create Mixmod object
xem <- new("MixmodLearn", ...)
# call learnMain
.Call("learnMain", xem, PACKAGE = "Rmixmod")
# mixmod error?
if (xem@error) warning("All models got errors!")
# return MixmodLearn object
return(xem)
}
#' Create an instance of the [\code{\linkS4class{MixmodLearn}}] class
#'
#' This function computes the first step of a discriminant analysis. It will find the best classification rule by running an
#' M step from the training observations.
#'
#' @param data frame containing quantitative,qualitative or heterogeneous data. Rows correspond to observations and columns
#' correspond to variables.
#' @param knownLabels an integer vector or a factor of size number of observations. Each cell corresponds to a cluster
#' affectation. So the maximum value is the number of clusters.
#' @param dataType character. Type of data is "quantitative", "qualitative" or "composite". Set as NULL by default, type will
#' be guessed depending on variables type (in case of homogeneous data). 'composite' type must be specified explicitly.
#' @param models a [\code{\linkS4class{Model}}] object defining the list of models to run. For quantitative data, the model
#' "Gaussian_pk_Lk_C" is called (see mixmodGaussianModel() to specify other models). For qualitative data, the model
#' "Binary_pk_Ekjh" is called (see mixmodMultinomialModel() to specify other models).
#' @param criterion list of character defining the criterion to select the best model. Possible values: "BIC", "CV" or
#' c("CV","BIC"). Default is "CV".
#' @param nbCVBlocks integer which defines the number of block to perform the Cross Validation. This value will be ignored if
#' the CV criterion is not chosen. Default value is 10.
#' @param weight numeric vector with n (number of individuals) rows. Weight is optional. This option is to be used when weight
#' is associated to the data.
#'
#' @examples
#' ## A quantitative example with the famous iris data set
#' learn.iris <- mixmodLearn(iris[1:4], iris$Species)
#' ## get summary
#' summary(learn.iris)
#'
#' ## A qualitative example with the famous birds data set
#' data(birds)
#' birds.partition <- as.integer(c(rep(1, 34), rep(2, 35)))
#' learn.birds <- mixmodLearn(data = birds, knownLabels = birds.partition)
#' ## get summary
#' summary(learn.birds)
#'
#' ## A composite example with a heterogeneous data set
#' data(heterodatatrain)
#' learn.hetero <- mixmodLearn(heterodatatrain[-1], knownLabels = heterodatatrain$V1)
#' ## get summary
#' summary(learn.hetero)
#' @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}
#' @return Returns an instance of the [\code{\linkS4class{MixmodLearn}}] class. Those two attributes will contain all outputs:
#' \describe{
#' \item{results}{a list of [\code{\linkS4class{MixmodResults}}] object containing all the results sorted in ascending order
#' according to the given criterion.}
#' \item{bestResult}{a S4 [\code{\linkS4class{MixmodResults}}] object containing the best model results.}
#' }
mixmodLearn.default <- function(data, knownLabels, dataType = NULL, models = NULL, criterion = "CV", nbCVBlocks = 10,
weight = NULL) {
stop("mixmodLearn.default: not implemented\n")
}
# old_mixmodLearn <- function(data, knownLabels, dataType=NULL, models=NULL, criterion="CV", nbCVBlocks=10, weight=NULL) {
# # check options
# if (missing(data)) {
# stop("data is missing !")
# }
# if ( missing(knownLabels)) {
# stop("knownLabels is missing !")
# }
# if (!is.data.frame(data) & !is.vector(data) & !is.vector(data)) {
# stop("data must be a data.frame or a vector or a factor")
# }
#
# if (!is.vector(knownLabels) & !is.factor(knownLabels)) {
# stop("knownLabels must be a vector or a factor")
# }
#
# # create Mixmod object
# xem <- new( "MixmodLearn", data=data, knownLabels=knownLabels, dataType=dataType, models=models, criterion=criterion,
# nbCVBlocks=nbCVBlocks, weight=weight )
# # call learnMain
# .Call("learnMain", xem, PACKAGE="Rmixmod")
# # mixmod error?
# if ( xem@error ) warning( "All models got errors!")
#
# # return MixmodLearn object
# return(xem)
# }
#' @rdname print-methods
#' @aliases print print,MixmodLearn-method
#'
setMethod(
f = "print",
signature = c("MixmodLearn"),
function(x, ...) {
cat("****************************************\n")
cat("*** INPUT:\n")
cat("****************************************\n")
callNextMethod()
if (!x@error) {
cat("\n\n")
cat("****************************************\n")
cat("*** BEST MODEL OUTPUT:\n")
cat(paste("*** According to the", x@criterion[1], "criterion\n"))
cat("****************************************\n")
print(x@bestResult)
} else {
cat("\n\n")
cat("****************************************\n")
cat("*** NO OUTPUT - All models got errors !\n")
cat("****************************************\n")
}
return(invisible())
}
)
#' @rdname show-methods
#' @aliases show show,MixmodLearn-method
#'
setMethod(
f = "show",
signature = c("MixmodLearn"),
function(object) {
cat("****************************************\n")
cat("*** INPUT:\n")
cat("****************************************\n")
callNextMethod()
if (!object@error) {
cat("\n\n")
cat("****************************************\n")
cat("*** BEST MODEL OUTPUT:\n")
cat(paste("*** According to the", object@criterion[1], "criterion\n"))
cat("****************************************\n")
show(object@bestResult)
} else {
cat("\n\n")
cat("****************************************\n")
cat("*** NO OUTPUT - All models got errors !\n")
cat("****************************************\n")
}
return(invisible())
}
)
#' @rdname extract-methods
#' @aliases [,MixmodLearn-method
#'
setMethod(
f = "[",
signature(x = "MixmodLearn"),
definition = function(x, i, j, drop) {
if (missing(j)) {
switch(EXPR = i,
"data" = {
return(x@data)
},
"dataType" = {
return(x@dataType)
},
"nbCluster" = {
return(x@nbCluster)
},
"criterion" = {
return(x@criterion)
},
"models" = {
return(x@models)
},
"knownLabels" = {
return(x@knownLabels)
},
"weight" = {
return(x@weight)
},
"bestResult" = {
return(x@bestResult)
},
"results" = {
return(x@results)
},
"error" = {
return(x@error)
},
stop("This attribute doesn't exist !")
)
} else {
switch(EXPR = i,
"nbCluster" = {
return(x@nbCluster[j])
},
"criterion" = {
return(x@criterion[j])
},
"data" = {
return(x@data[, j])
},
"knownLabels" = {
return(x@knownLabels[, j])
},
"weight" = {
return(x@weight[j])
},
"results" = {
return(x@results[[j]])
},
stop("This attribute doesn't exist !")
)
}
}
)
# ' @name [
#' @rdname extract-methods
#' @aliases [<-,MixmodLearn-method
#'
setReplaceMethod(
f = "[",
signature(x = "MixmodLearn"),
definition = function(x, i, j, value) {
if (missing(j)) {
switch(EXPR = i,
"data" = {
x@data <- value
},
"dataType" = {
x@dataType <- value
},
"criterion" = {
x@criterion <- value
},
"models" = {
x@models <- value
},
"knownLabels" = {
x@knownLabels <- value
},
"weight" = {
x@weight <- value
},
stop("This attribute doesn't exist !")
)
} else {
switch(EXPR = i,
"data" = {
x@data[, j] <- value
},
"criterion" = {
x@criterion[j] <- value
},
"knownLabels" = {
x@knownLabels[j] <- value
},
"weight" = {
x@weight[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.