基于R语言的k-prototypes聚类算法.zip

########################################################################################## ## ## ## Ana Flávia Delbem Vidigal Nazareth ## ## ## ## ALGORITMO DE AGRUPAMENTOS ## ## *** K-PROTÓTIPOS *** ## ## Funções modificadas a partir dos pacotes ade4, clustMixType e FactoExtra ## ## ## ########################################################################################## ########################################################################################## ## FUNÇÕES E PACOTES A SEREM UTILIZADOS ## ########################################################################################## ##Download dos códigos fontes utilizados: ##Modificar o diretório de destino desejado: destdir="C:/" #download.packages("clustMixType", destdir= "C:/Users/anafl/Desktop", type="source") #download.packages("ade4", destdir= "C:/Users/anafl/Desktop", type="source") #download.packages("factoextra", destdir= "C:/Users/anafl/Desktop", type="source") #download.packages("cluster", destdir= "C:/Users/anafl/Desktop", type="source") #download.packages("NbClust", destdir= "C:/Users/anafl/Desktop", type="source") # Criação da função para o cálculo da distância euclidiana cppFunction('NumericMatrix weighted_distance (NumericMatrix x, NumericMatrix y, NumericVector lambda){ int n_x = x.nrow(); int n_y = y.nrow(); NumericMatrix out(n_x, n_y); //begin the loop for (int i = 0 ; i < n_x; i++){ for (int j = 0 ; j < n_y ; j ++) { double d = sum(pow(x.row(i) - y.row(j), 2)*lambda); out(i,j) = d; } } return (out) ; }') ########################################################################################## ## FUNÇÃO Kproto() MODIFICADA: kproto.modif() ## ########################################################################################## ##TESTE #x <- dados1 #Data frame com ambas variáveis quantitativas e fatoriais. #k = K #Pode ser um número de grupos, um vetor especificando índices de protótipos iniciais ou um data frame de protótipos com as mesmas colunas que x. #lambda = LAMB #Parâmetro > 0 para ponderar entre a distância euclidiana de variáveis quantitativas e a distância escolhida entre variáveis categóricas. Também é possível ser um vetor de pesos específicos para as variáveis onde o primeiro termo deve ser o peso dado às variáveis qualitativas e os demais termos correspondem à ordem das variáveis quantitativas nos dados. Nesse caso, cada distância entre cada variável quantitativa será multiplicada pelo valor lambda correspondente àquela variável e a distância entre as variáveis qualitativas será multiplicada pelo lambda das variáveis qualitativas único. Deste modo, deve ser um vetor de dimensão igual ao número de variáveis quantitativas mais um. #iter.max = 100 #Número máximo de iterações, se não houver convergência antes. #nstart = 1 #Se > 1 cálculos repetitivos com inicializações aleatórias são calculados e o resultado com um mínimo de tot.dist é retornado. #na.rm = TRUE #Um valor lógico que indica se os valores ausentes (NAs) devem ser removidos antes que a computação prossiga. #keep.data = FALSE #Um valor lógico que indica se o banco de dados original deve ser incluído no objeto retornado. #verbose = TRUE #Um valor lógico que indica se as informações sobre o procedimento de agrupamentos devem ser dadas. Cuidado: Se verbose = FALSE, a redução do número de grupos não é mencionada. kproto.modif <- function( x, k, lambda = NULL, iter.max = 100, nstart = 1, na.rm = TRUE, keep.data = TRUE, verbose = TRUE, ...) { # Checagem de erros inicial if (!is.data.frame(x)) stop("x deve ser um data frame!") if (ncol(x) < 2) stop("Para agrupamentos x deve conter pelo menos duas variaveis!") if (iter.max < 1 | nstart < 1) stop("iter.max e nstart nao devem ser especificados como < 1!") if (!is.null(lambda)) { if (any(lambda < 0)) stop("lambda deve ser especificado como >= 0!") if (!any(lambda > 0)) stop("lambda deve ser especificado como > 0 para pelo menos uma variavel!")} # Verificação para variáveis quantitativas e fatoriais numvars <- sapply(x, is.numeric) anynum <- any(numvars) catvars <- sapply(x, is.factor) anyfact <- any(catvars) if (!anynum) stop("\n Nao ha variaveis quantitativas em x! Tente usar o metodo kmodes() do pacote klaR...\n\n") if (!anyfact) stop("\n Nao ha variaveis fatoriais em x! Tente usar o metodo kmeans()...\n\n") # Tratamento de valores ausentes NAcount <- apply(x, 2, function(z) sum(is.na(z))) if (verbose) { cat("# NAs nas variaveis:\n") print(NAcount) } if (any(NAcount == nrow(x))) stop(paste("Variavel(is) possuem apenas NAs, favor remove-las:", names(NAcount)[NAcount == nrow(x)], "!")) if (na.rm) { miss <- apply(x, 1, function(z) any(is.na(z))) if (verbose) { cat(sum(miss), "Observacao(es) com NAs.\n") if (sum(miss) > 0) message("Observacoes com NAs sao removidas.\n") cat("\n")} x <- x[!miss,]} # Remoção de observações com valores ausentes if (!na.rm) { allNAs <- apply(x, 1, function(z) all(is.na(z))) if (sum(allNAs) > 0) { if (verbose) cat(sum(allNAs), "Observacao(es) onde todas as variaveis nao estao presentes.\n") warning("Nenhuma atribuicao de grupos significativa e possivel para observacoes onde todas as variaveis nao estao presentes.\n") if (verbose) cat("\n")}} if (nrow(x) == 1) stop("Apenas o agrupamento de uma observacao nao e significativo.") k_input <- k # Armazena o valor de k para nstart > 1 uma vez que os grupos podem ser fundidos # Inicialização dos protótipos if (!is.data.frame(k)) { if (length(k) == 1) { if (as.integer(k) != k) { k <- as.integer(k) warning(paste("k foi modificado para", k, "!"))} if (nrow(x) < k) stop("O data frame tem um numero de observacoes menor que o de grupos!") ids <- sample(nrow(x), k) protos <- x[ids,]} if (length(k) > 1) { if (nrow(x) < length(k)) stop("O data frame tem um numero de observacoes menor que o de grupos!") ids <- k k <- length(ids) if (length(unique(ids)) != length(ids)) stop("Se k e especificado como um vetor ele deve conter diferentes indices!") if (any(ids < 1) | any(ids > nrow(x))) stop("Se k e especificado como um vetor todos os elementos devem ser indices validos de x!") #Verificação de inteiros protos <- x[ids,]} rm(ids)} if (is.data.frame(k)) { if (nrow(x) < nrow(k)) stop("O data frame tem um numero de observacoes menor que o de grupos!") if (length(names(k)) != length(names(x))) stop("k e x possuem um numero diferente de colunas!") if (any(name