Nothing
##################################################################################
# global.R ##
##################################################################################
#' Define function to check an integer
#'
#' @param x a numeric
#' @param tol a real which defines the tolerance
#'
#' @return a logical. TRUE if \code{x} is an integer, FALSE otherwise.
#'
#' @keywords internal
#'
is.wholenumber <- function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol
#' Define function to transform a vector of modalities into matrix of binary data
#'
#' @param x a numeric
#'
#' @return a matrix of binary data.
#'
#' @keywords internal
#'
vector2binary <- function(x) {
x <- as.factor(x)
y <- matrix(0, nrow = length(x), ncol = length(levels(x)))
for (i in seq_along(x)) {
y[i, as.numeric(x[i])] <- 1
}
return(y)
}
#' Define function to transform a matrix of modalities into matrix of binary data
#'
#' @param x a matrix
#'
#' @return a matrix of binary data.
#'
#' @keywords internal
#'
matrix2binary <- function(x) {
if (is.vector(x)) {
y <- vector2binary(x)
} else {
y <- NULL
y.names <- NULL
for (i in seq_along(names(x))) {
y <- cbind(y, vector2binary(x[, i]))
y.names <- c(y.names, paste(names(x)[i], levels(as.factor(x[, i])), sep = ""))
}
}
colnames(y) <- y.names
return(y)
}
#' Say if a data frame is quantitative, qualitative or composite
#'
#' @param x a vector, a factor or a data frame
#'
#' @return a string with the data type
#'
#' @export
#'
is.dataType <- function(x) {
# look after missing values
if (sum(is.na(x))) stop("data set contains missing values")
if (is.vector(x) || is.factor(x)) {
if (is.double(x)) {
return("quantitative")
}
if (nlevels(as.factor(x)) / length(x) > .25) {
warning("more than 25% of the observations have different modalities")
}
return("qualitative")
} else {
if (sum(sapply(x, is.numeric)) == ncol(x)) {
return("quantitative")
}
if (sum(sapply(x, is.factor)) == ncol(x)) {
return("qualitative")
} else {
return("composite")
}
}
}
#' Say if a data frame contains only qualitative variables.
#'
#' @param x a vector or a matrix or a data frame
#'
#' @return a boolean
#'
#' @export
#'
isQualitative <- function(x) {
# look after missing values
if (sum(is.na(x))) stop("data set contains missing values")
if (is.vector(x) || is.factor(x)) {
if (is.double(x)) {
return(FALSE)
}
if (nlevels(as.factor(x)) / length(x) > .25) {
warning("more than 25% of the observations have different modalities")
}
return(TRUE)
} else {
# loop over columns to check whether type is factor
for (j in seq_len(ncol(x))) {
if (is.double(x[, j])) {
return(FALSE)
}
if (nlevels(as.factor(x[, j])) / length(x[, j]) > .25) {
warning(paste("more than 25% of the observations have different modalities for variable named", names(x)[j]))
}
}
}
return(TRUE)
}
#' Convert a data frame containing integers to a qualitative data set with factors.
#'
#' @param x a vector or a matrix or a data frame
#'
#' @return a qualitative data set with factors
#'
#' @export
#'
asQualitative <- function(x) {
if (isQualitative(x)) {
if (is.vector(x)) {
x <- as.factor(x)
} else if (is.data.frame(x) || is.matrix(x)) {
# loop over columns to check whether type is factor
for (j in seq_len(ncol(x))) {
x[, j] <- as.factor(x[, j])
}
}
}
return(x)
}
#' Get the number of modalities for each column of a categorical data set
#'
#' @param x a vector or a matrix or a data frame containing factors
#'
#' @return a vector containing the number of modalities for each column
#'
#' @export
#'
nbFactorFromData <- function(x) {
# set x as a qualitative data set
x <- asQualitative(x)
if (is.vector(x) || is.factor(x)) {
return(nlevels(x))
} else {
return(sapply(x, nlevels))
}
}
#' Sorting results of a [\code{\linkS4class{Mixmod}}] object by a given criterion
#'
#' After calling the mixmodCluster() or mixmodLearn() method, results will be sorted
#' into ascending order according to the first given criterion (descending order for CV criterion).
#' This method is able to reorder the list of results according to a given criterion.
#'
#' @param object a [\code{\linkS4class{Mixmod}}] object
#' @param criterion a string containing the criterion name
#'
#' @return a modified [\code{\linkS4class{Mixmod}}] object
#'
#' @exportMethod sortByCriterion
#' @docType methods
#' @rdname sortByCriterion-methods
#' @examples
#' x <- mixmodCluster(iris[1:4], 2:10, criterion = c("BIC", "ICL"))
#' icl <- sortByCriterion(x, "ICL")
#' icl["results"]
setGeneric(
name = "sortByCriterion",
def = function(object, criterion) {
standardGeneric("sortByCriterion")
}
)
.is_dtype_alike <- function(x, y, dt, t_func) {
if (x@dataType == dt) {
return(TRUE)
}
if (x@dataType != "composite") {
return(FALSE)
}
# here x@dataType == "composite"
if (is.null(y)) {
return(TRUE)
}
if (is.numeric(y)) {
num_y <- y
} else {
num_y <- c()
for (i in seq_along(y)) {
num_y[i] <- which(colnames(x@data) == y[i])
}
}
factor <- x@bestResult@parameters@factor # TODO: was out@..., but who was 'out' ?!
for (i in num_y) {
# if(factor[i] != 0) return (FALSE);
if (t_func(factor[i])) {
return(FALSE)
}
}
return(TRUE)
}
.test_nz <- function(t) {
return(t != 0)
}
.test_z <- function(t) {
return(t == 0)
}
.is_quantitative_alike <- function(x, y, showOnly) {
if (!is.null(showOnly) && showOnly != "quantitative") {
return(FALSE)
}
return(.is_dtype_alike(x, y, "quantitative", .test_nz))
}
.is_qualitative_alike <- function(x, y, showOnly) {
if (!is.null(showOnly) && showOnly != "qualitative") {
return(FALSE)
}
if (!is.null(y)) {
stop("y parameter is not relevant in plot() when data are qualitative")
}
return(.is_dtype_alike(x, y, "qualitative", .test_z))
}
.is_quantitative_alike2 <- function(x, data, vars) {
if (is(x@parameters, "GaussianParameter")) {
return(TRUE)
}
if (!is(x@parameters, "CompositeParameter")) {
return(FALSE)
}
# here x@dataType == "composite"
if (is.null(vars)) {
return(FALSE)
}
if (is.numeric(vars)) {
num_var <- vars
} else {
num_var <- c()
for (i in seq_along(vars)) {
num_var[i] <- which(colnames(data) == vars[i])
}
}
factor <- x@parameters@factor
for (i in num_var) {
if (factor[i] != 0) {
return(FALSE)
}
}
return(TRUE)
}
#' Print a Rmixmod class to standard output.
#'
#' @param x a Rmixmod object: a \code{\linkS4class{Strategy}}, a \code{\linkS4class{Model}}, a
#' \code{\linkS4class{GaussianParameter}}, a \code{\linkS4class{MultinomialParameter}}, a \code{\linkS4class{MixmodResults}},
#' a \code{\linkS4class{MixmodCluster}}, a \code{\linkS4class{MixmodLearn}} or a \code{\linkS4class{MixmodPredict}}.
#' @param ... further arguments passed to or from other methods
#'
#' @return NULL. Prints to standard out.
#'
#' @name print
#' @rdname print-methods
#' @docType methods
#' @exportMethod print
#'
#' @seealso \code{\link{print}}
#' @examples
#' ## for strategy
#' strategy <- mixmodStrategy()
#' print(strategy)
#'
#' ## for Gaussian models
#' gmodel <- mixmodGaussianModel()
#' print(gmodel)
#' ## for multinomial models
#' mmodel <- mixmodMultinomialModel()
#' print(mmodel)
#'
#' ## for clustering
#' data(geyser)
#' xem <- mixmodCluster(geyser, 3)
#' print(xem)
#' ## for Gaussian parameters
#' print(xem["bestResult"]["parameters"])
#'
#' ## for discriminant analysis
#' # start by extract 10 observations from iris data set
#' iris.partition <- sample(1:nrow(iris), 10)
#' # then run a mixmodLearn() analysis without those 10 observations
#' learn <- mixmodLearn(iris[-iris.partition, 1:4], iris$Species[-iris.partition])
#' # print learn results
#' print(learn)
#' # create a MixmodPredict to predict those 10 observations
#' prediction <- mixmodPredict(
#' data = iris[iris.partition, 1:4],
#' classificationRule = learn["bestResult"]
#' )
#' # print prediction results
#' print(prediction)
NULL
#' Show description of a Rmixmod class to standard output.
#'
#' @param object a Rmixmod object: a \code{\linkS4class{Strategy}}, a \code{\linkS4class{Model}},
#' a \code{\linkS4class{GaussianParameter}}, a \code{\linkS4class{MultinomialParameter}}, a \code{\linkS4class{MixmodResults}},
#' a \code{\linkS4class{MixmodCluster}}, a \code{\linkS4class{MixmodLearn}} or a \code{\linkS4class{MixmodPredict}}.
#'
#' @return NULL. Prints to standard out.
#'
#' @importFrom methods show
#' @name show
#' @docType methods
#' @rdname show-methods
#' @exportMethod show
#'
#' @seealso \code{\link{show}}
#' @examples
#' ## for strategy
#' strategy <- mixmodStrategy()
#' show(strategy)
#'
#' ## for Gaussian models
#' gmodel <- mixmodGaussianModel()
#' show(gmodel)
#' ## for multinomial models
#' mmodel <- mixmodMultinomialModel()
#' show(mmodel)
#'
#' ## for clustering
#' data(geyser)
#' xem <- mixmodCluster(geyser, 3)
#' show(xem)
#' ## for Gaussian parameters
#' show(xem["bestResult"]["parameters"])
#'
#' ## for discriminant analysis
#' # start by extract 10 observations from iris data set
#' iris.partition <- sample(1:nrow(iris), 10)
#' # then run a mixmodLearn() analysis without those 10 observations
#' learn <- mixmodLearn(iris[-iris.partition, 1:4], iris$Species[-iris.partition])
#' # create a MixmodPredict to predict those 10 observations
#' prediction <- mixmodPredict(
#' data = iris[iris.partition, 1:4],
#' classificationRule = learn["bestResult"]
#' )
#' # show results
#' show(prediction)
NULL
#' Produce result summaries of a Rmixmod class
#'
#' @param ... further arguments passed to or from other methods
#'
#' @return NULL. Summaries to standard out.
#'
#' @name summary
#' @docType methods
#' @rdname summary-methods
#' @exportMethod summary
#'
#' @seealso \code{\link{summary}}
#' @examples
#' data(geyser)
#' xem <- mixmodCluster(geyser, 3)
#' summary(xem)
#' summary(xem["bestResult"])
#' summary(xem["bestResult"]["parameters"])
NULL
#' Extract parts of a Rmixmod class
#'
#' @param x object from which to extract element(s) or in which to replace element(s).
#' @param i the name of the element we want to extract or replace.
#' @param j if the element designing by i is complex, j specifying elements to extract or replace.
#' @param drop For matrices and arrays. If TRUE the result is coerced to the lowest possible dimension (see the examples).
#' This only works for extracting elements, not for the replacement. See drop for further details.
#' @param value TODO...
#'
#' @name [
#' @docType methods
#' @rdname extract-methods
#'
NULL
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.