Nothing
#
# Copyright (C) 2006 Friedrich Leisch
# $Id: grouping.R 248 2018-04-30 09:36:44Z gruen $
#
## Assign each observation to the cluster minimizing the sum
## of distances to all group members.
minSumClusters <- function(cluster, group, distmat)
{
G <- levels(group)
x <- matrix(0, ncol=ncol(distmat), nrow=length(G))
for(n in 1:length(G)){
x[n,] <- colSums(distmat[group==G[n],,drop=FALSE])
}
m <- max.col(-x)
names(m) <- G
z <- m[group]
names(z) <- NULL
if(is.list(cluster))
{
## get second best
x[cbind(1:nrow(x), m)] <- Inf
m <- max.col(-x)
names(m) <- G
z1 <- m[group]
names(z1) <- NULL
z <- list(z, z1)
}
z
}
## Assign each observation to the cluster where the majority from its
## group belongs to
majorityClusters <- function(cluster, group, distmat)
{
if(is.list(cluster))
{
K <- max(unlist(cluster))
## use factors to make sure all possible clusters appear in
## both tables
x <- 2*table(group, factor(cluster[[1]], levels=1:K)) +
table(group, factor(cluster[[2]], levels=1:K))
}
else{
x <- table(group, cluster)
}
m <- max.col(x)
names(m) <- row.names(x)
z <- m[group]
names(z) <- NULL
if(is.list(cluster))
{
## get second best
x[cbind(1:nrow(x), m)] <- 0
m <- max.col(x)
names(m) <- row.names(x)
z1 <- m[group]
names(z1) <- NULL
z <- list(z, z1)
}
z
}
## Assign each observation to a cluster where no other member from its
## group belongs to
differentClusters <- function(cluster, group, distmat)
{
if(max(table(group)) > ncol(distmat))
stop("Number of group members must be smaller or equal as number of clusters")
INF <- 2*sum(distmat, na.rm=TRUE)
distmat[is.na(distmat)] <- INF
if(is.list(cluster)){
z <- getDifferentCluster(cluster[[1]], group, distmat)
distmat[cbind(1:nrow(distmat), z)] <- INF
cluster <- list(z,
getDifferentCluster(cluster[[2]], group, distmat))
}
else{
cluster <- getDifferentCluster(cluster, group, distmat)
}
cluster
}
getDifferentCluster <- function(cluster, group, distmat)
{
x <- table(group, cluster)
ok <- (apply(x, 1, max)==1)
nok.names <- unique(row.names(x[!ok,,drop=FALSE]))
for(n in nok.names){
ok <- group==n
if(sum(ok)>1)
cluster[ok] <- clue::solve_LSAP(distmat[ok,])
}
cluster
}
## solve_LSAP1 <- function (x, maximum = FALSE)
## {
## require("clue")
## if (!is.matrix(x) || any(x < 0))
## stop("x must be a matrix with nonnegative entries.")
## if(nrow(x)>ncol(x))
## stop("x must have less or equal rows than columns")
## nr <- nrow(x)
## nc <- ncol(x)
## if(ncol(x) > nrow(x))
## x <- rbind(x, matrix(2*sum(x), nrow=(ncol(x)-nrow(x)), ncol=ncol(x)))
## if (maximum)
## x <- max(x) - x
## storage.mode(x) <- "double"
## out <- .C("solve_LSAP", x, nc, p = integer(nc), PACKAGE = "clue")$p + 1
## out <- out[1:nr]
## class(out) <- "solve_LSAP"
## out
## }
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.