Nothing
#
# Copyright (C) 2011-2015 Christina Yassouridis
#
#
funcit <- function(data, k,
methods=c("fitfclust", "distclust", "iterSubspace", "funclust",
"funHDDC", "fscm", "waveclust"),
seed=NULL,
regTime=NULL, clusters=NULL,
funcyCtrl=NULL, fpcCtrl=NULL,
parallel=FALSE, save.data=TRUE, ...){
##Check for missing arguments
if(missing(methods))
stop("Please select one method or methods='ALL'.")
else if(length(methods)==1)
if(methods=="ALL")
methods <- 1:7
##Method names
allMethods <- c("fitfclust", "distclust", "iterSubspace", "funclust",
"funHDDC", "fscm", "waveclust")
if(is.numeric(methods))
usedMethods <- allMethods[methods]
else
usedMethods <- match.arg(methods, allMethods, several.ok=TRUE)
nrMethods <- length(usedMethods)
if(missing(k))
stop(paste(k, "is missing"))
if(!(class(data) %in% c("matrix", "data.frame")))
stop(paste(data,
"must be given in matrix or data.frame format."))
##Check if data is in the right format
chf <- checkFormat(data)
data <- chf$data
reg <- chf$reg
##Check if funcyCtrl class is given
if(is.null(funcyCtrl))
funcyCtrl <- new("funcyCtrl")
funcyCtrl@seed <- seed
##Convert funcyCtrl automatically to funcyCtrl if model based cluster
##algorithm but fpcCtrl was chosen
if(sum(usedMethods%in%allMethods[c(1,3,4,5,6,7)])>0 & class(funcyCtrl)=="funcyCtrl")
funcyCtrl <- as(funcyCtrl, "funcyCtrlMbc")
##Check if fpcCtrl object if defined for eigenbasis
if(funcyCtrl@baseType!="eigenbasis" & !is.null(fpcCtrl))
warning("fpcCtrl is ignored since it controls only eigenbasis.")
else if(funcyCtrl@baseType=="eigenbasis")
fpcCtrl <- fpcCtrlCheck(fpcCtrl=fpcCtrl, data=data, reg=reg)
##Check if correct method for the given dataset was chosen.
if(reg==0 & sum(usedMethods%in%c("fscm", "funclust", "funHDDC"))>0){
notWork <- usedMethods[which(usedMethods%in%allMethods[-c(1:3)])]
stop(paste("Algorithm", notWork,
"works only on regular data!\n Please choose one of fitfclust, distclust or iterSubspace."))}
# check if parallel computing is needed
if(nrMethods == 1) parallel <- FALSE
# check if parallel computing is available
if(.Platform$OS.type!="unix" & parallel) {
warning("Parallel computing is only supported on Unix platforms.")
parallel <- FALSE
}
if(parallel) {
parallelFct <- parallel::mcparallel
coresNr <- detectCores()-1
options("cores"=coresNr)
} else {
parallelFct <- identity
}
RES <- list()
##Method1--------------------
if("fitfclust" %in% usedMethods){
indx <- match("fitfclust",usedMethods)
RES[[indx]] <-
parallelFct(fitfclustWrapper(data=data, k=k,
reg=reg, regTime=regTime, fpcCtrl=fpcCtrl,
funcyCtrlMbc=funcyCtrl,
...))
}
##Method2----------------------
if("distclust" %in% usedMethods){
indx <- match("distclust", usedMethods)
RES[[indx]] <-
parallelFct(distclustWrapper(data=data, k=k,
reg=reg, regTime=regTime, fpcCtrl=fpcCtrl,
funcyCtrl=funcyCtrl, ...))
}
##Method 3----------------------
if("iterSubspace" %in% usedMethods){
indx <- match("iterSubspace",usedMethods)
RES[[indx]] <-
parallelFct(iterSubspaceWrapper(data=data, k=k, reg=reg, regTime=regTime,
fpcCtrl=fpcCtrl,
funcyCtrlMbc=funcyCtrl, ...))
}
##Method 4-----------
if("funclust" %in% usedMethods){
.warn_once <- local({
not.warned.yet <- TRUE
function(x){
if(not.warned.yet){
warning("Funclustering is currently not available on CRAN.")
not.warned.yet <<- FALSE
}
}
})
# if(!requireNamespace("Funclustering"))
# stop("Please install package 'Funclustering' to use method 'funclust'.")
#
# indx <- match("funclust",usedMethods)
# RES[[indx]] <-
# parallelFct(funclustWrapper(data=data, k=k,
# reg=reg, regTime=regTime,
# funcyCtrlMbc=funcyCtrl,
# ...))
}
##Method 5-----------
if("funHDDC" %in% usedMethods){
if(!requireNamespace("funHDDC"))
stop("Please install package 'funHDDC' to use method 'funHDDC'.")
indx <- match("funHDDC", usedMethods)
RES[[indx]] <-
parallelFct(funHDDCWrapper(data=data, k=k,
reg=reg, regTime=regTime,
funcyCtrlMbc=funcyCtrl, ...))
}
##Method 6-----------
if("fscm" %in% usedMethods){
indx <- match("fscm", usedMethods)
RES[[indx]] <-
parallelFct(fscmWrapper(data=data, k=k, reg=reg,
regTime=regTime,
funcyCtrlMbc=funcyCtrl, ...))
}
##Method 7-----------
if("waveclust" %in% usedMethods){
indx <- match("waveclust", usedMethods)
RES[[indx]] <-
parallelFct(waveclustWrapper(data=data, k=k, reg=reg,
regTime=regTime,
funcyCtrlMbc=funcyCtrl, ...))
}
FRES <- new("funcyOutList")
FRES@call <- match.call()
if(parallel)
FRES@models <- parallel::mccollect(RES)
else
FRES@models <- RES
names(FRES@models) <- usedMethods
##Check if error appeard (only for parallel computing)----
error <- which(sapply(FRES@models, class) == "try-error")
if(sum(error)!=0)
stop(paste("Method", usedMethods[error[1]], ":",
attributes(FRES@models[[error[1]]])$condition$message))
allClusters <- sapply(FRES@models, function(x) x@cluster)
allCenters <- lapply(FRES@models, function(x) x@centers)
names(allCenters) <- colnames(allClusters) <- usedMethods
rI <- rIMethods(methodNames=usedMethods, cls=allClusters, trueCluster=clusters)
##Relabel cluster output for better comparability in plots
if(nrMethods>1){
rel <- relabelMethods(methodNames=usedMethods, cls=allClusters,
ctrs=allCenters)
allClusters <- rel$allClusters
allCenters <- rel$allCenters
for(i in 1:nrMethods){
FRES@models[[i]]@cluster <- allClusters[,i]
FRES@models[[i]]@centers <- allCenters[[i]]
FRES@models[[i]]@correctCl <- rI[i,i]
}
}
##Warning if cluster size is smaller than 3
smallCl <- which(apply(allClusters, 2, function(x)
min(table(x)))<2)
if(length(smallCl)!=0){
warning(paste("Method", usedMethods[smallCl],
"has clusters with less than 3 obervations!\n"), immediate.=TRUE)
}
accord <- accordance(cls=allClusters, relabel=FALSE)
if(save.data)
FRES@data <- data
else
FRES@data <- as.matrix(NULL)
FRES@timeNr <- calcTimeNr(data, reg)
FRES@reg <- reg
FRES@k <- k
FRES@methodName <- usedMethods
FRES@allClusters <- allClusters
FRES@randIndex <- rI
FRES@votedCluster <- accord$votedCluster
FRES@accordance <- accord$accordance
return(FRES)
}
fpcCtrlCheck <- function(fpcCtrl=NULL, data, reg){
if(is.null(fpcCtrl))
fpcCtrl <- new("fpcCtrl")
fct.exist1 <- try(match.fun(fpcCtrl@sm1Dim),silent=TRUE)
fct.exist2 <- try(match.fun(fpcCtrl@sm2Dim),silent=TRUE)
if(class(fct.exist1)=="try-error" |
class(fct.exist2)=="try-error")
stop("sm1Dim and/or sm2Dim are no valid function names.")
if(fpcCtrl@select=="automatic")
{
res <- selBw(data=data, reg=reg)
fpcCtrl@h1Dim <- res$h1Dim
fpcCtrl@h2Dim <- res$h2Dim
}
return(fpcCtrl)
}
setMethod("[[", signature(x="funcyOutList", i="ANY", j="missing"),
function(x, i, j) x@models[[i]])
setGeneric("calcTime",
function(object) standardGeneric("calcTime"))
setMethod("calcTime", "funcyOutList",
function(object){
cat("\nSummary of the Calculation Time:\n")
calcTime <- t(sapply(object@models, function(x) x@calcTime))
rownames(calcTime) <- object@methodName
print(calcTime)
})
setMethod("Cluster", "funcyOutList",
function(object){
n <- length(object@models)
allClusters <- sapply(object@models,function(x)
x@cluster)
colnames(allClusters) <- object@methodName
if(n==1)
allClusters <- as.numeric(allClusters)
allClusters
}
)
setGeneric("Center",
function(object) standardGeneric("Center"))
setMethod("Center", "funcyOutList",
function(object){
n <- length(object@models)
allCenters <- lapply(object@models,function(x)
x@centers)
names(allCenters) <- object@methodName
if(n==1)
allCenters <- allCenters[[1]]
allCenters
}
)
setGeneric("props",
function(object) standardGeneric("props"))
setMethod("props", "funcyOutList",
function(object){
a <- lapply(object@models, function(x) as.data.frame(t(x@props)))
props <- data.frame(matrix(nrow=length(object@models),ncol=object@k))
colnames(props) <- paste("cl", 1:object@k)
props <- rbind.fill(a, props)
rownames(props) <- object@methodName
cat("\nSummary of the Cluster Proportions:\n")
print(props)
})
setGeneric("randIndex")
setMethod("randIndex", signature(x="funcyOutList"),
function(x){
cat("\nSummary of the Rand Indices:\n")
print(x@randIndex)
})
setMethod("summary", "funcyOutList",
function(object)
{
outlines <- paste0(sQuote(class(object)),
"\nobject with called algorithm(s):\n\n",
paste(object@methodName,
collapse=" "))
cat(writeLines(strwrap(outlines,
width=0.75*getOption("width"))))
cat("\n")
cat("call:", deparse(object@call,0.75*getOption("width")),
sep="\n")
props(object)
randIndex(object)
calcTime(object)
}
)
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.