Педагогический способ программирования иерархического алгоритма кластеризации в R

Question

Я готовлю лекцию о механическом обучении в R, и я хочу взять hierarchical clustering в качестве примера. Я нашел это очень поучительную страницу здесь: http://home.deib.polimi.it/matteucc/Clustering/tutorial_html/hierarchical.html

Он начинается с таблицей следующих расстояний (виду NA как столбец/имя строки при чтении данных, см также ниже):

кратчайшее расстояние - 138 между MI и TO, поэтому мы хотим объединить эти столбцы и строки в новый столбец/строку MI/TO. Расстояние этого нового составного объекта MI/TO от всех остальных городов равно кратчайшему расстоянию от одного из первоначальных городов MI или TO, т.е. MI/TO - RM - 564 (от MI), потому что это меньше, чем 669 (от TO). (Этот способ выполнения агрегации называется single-linkage clustering). Таким образом, мы имеем новую таблицу:

Мой вопрос
Я начал программировать это в R, и вскоре обнаружил, что код становится все более и более грязным - далеко от чего-то, что может быть легко понято программистов. Вы знаете подход или пакет, с помощью которого вы можете делать такие манипуляции с данными естественным и интуитивным способом?

---

Так вот исходная таблица в R:

D <- matrix(c(0,662,877,255,412,996, 
       662,0,295,468,268,400, 
       877,295,0,754,564,138, 
       255,468,754,0,219,869, 
       412,268,564,219,0,669, 
       996,400,138,869,669,0), ncol=6, byrow=T) 

rownames(D) <- colnames(D) <- c("BA","FI","MI","Na","RM","TO") 

D 
##  BA FI MI Na RM TO 
## BA 0 662 877 255 412 996 
## FI 662 0 295 468 268 400 
## MI 877 295 0 754 564 138 
## Na 255 468 754 0 219 869 
## RM 412 268 564 219 0 669 
## TO 996 400 138 869 669 0 

Answer 1

Встроенная функция «hclust» уже хорошая функция для работы с.

hc1 = hclust(as.dist(D), method = "single") 
hc1$merge 
plot(hc1) 

Подробно я могу описать, если вы хотите уточнить.

Следуя логике hclust, вы можете попробовать:

savemat = list() 
D1 = D; diag(D1) = Inf # a trick to make zero a infinity 
m = 1 
while(dim(D1)[1] > 2) { 
    # get the location of minimum distance 
    minloc = which(D1 == min(D1), arr.ind = T)[1,] 
    # make a two-column matrix then find out the minimum value of each row 
    u = apply(cbind(D1[minloc[2],],D1[minloc[1],]),1,min) 
    # updating the matrix 
    D1[minloc[2],] = u 
    D1[,minloc[2]] = u 
    u = paste0(rownames(D1)[minloc[2]],'/',rownames(D1)[minloc[1]]) 
    rownames(D1)[minloc[2]] = u 
    colnames(D1)[minloc[2]] = u 
    # deleting the merged column/row 
    D1 = D1[-minloc[1],-minloc[1]] 
    diag(D1) = Inf 
    # save the steps into a list element mth 
    savemat[[m]] = D1 
    m = m + 1 
} 
savemat 

Answer 2

Обновленный код в рекурсивной функции и отдельная функция печати, чтобы обеспечить лучшее следующее, что происходит. Используйте с hcl(<data.frame>,<log_level>). Вход уровня может быть 0 для только конечного результата, 1 для печати промежуточных наборов данных и 2 для печати каждого шаги

# To be allowed to add column later, don't know a better way than coercing to data.frame 
d <- data.frame(D,stringsAsFactors=F) 

myprt <- function(message,var) { 
    print(message) 
    print(var) 
} 

hcl <- function(d,prt=0) { 
    if (prt) myprt("Starting dataset:",d) 

    # 1) Get the shortest distance informations: 
    Ref <- which(d==min(d[d>0]), useNames=T, arr.ind=T) 
    if (prt>1) myprt("Ref is:",Ref) 
    # 2) Subset the original entry to remove thoose towns: 
    res <- d[-Ref[,1],-Ref[,1]] 
    if (prt>1) myprt("Res is:", res) 

    # 3) Get the subset for the two nearest towns: 
    tmp <- d[-Ref[,1],Ref[,1]] 
    if (prt>1) myprt("Tmp is:",tmp) 

    # 4) Get the vector of minimal distance from original dataset with the two town (row by row on t) 
    dists <- apply(tmp, 1, function(x) { x[x==min(x)] }) 
    #dists <- tmp[ tmp == pmin(tmp[,1], tmp[,2]) ] 
    if (prt>1) myprt("Dists is:",dists) 

    # 5) Let's build the resulting matrix: 
    tnames <- paste(rownames(Ref),collapse="/") # Get the names of town to the new name 
    if (length(res) == 1) { 

    # Nothing left in the original dataset just concat the names and return 
    tnames <- paste(c(tnames,names(dists)),collapse="/") 
    Finalres <- data.frame(tnames = dists) # build the df 
    names(Finalres) <- rownames(Finalres) <- tnames # Name it 

    if (prt>0) myprt("Final result:",Finalres) 
    return(Finalres) # Last iteration 

    } else { 

    Finalres <- res 
    Finalres[tnames,tnames] <- 0 # Set the diagonal to 0 
    Finalres[is.na(Finalres)] <- dists # the previous assignment has set NAs, replae them by the dists values 

    if (prt>0) myprt("Dataset before recursive call:",Finalres) 
    return(hcl(Finalres,prt)) # we're not at end, recall ourselves with actual result 

    } 
} 

---

Еще одна идеи по шагам:

# To be allowed to add column later, don't know a better way than coercing to data.frame 
d <- data.frame(D,stringsAsFactors=F) 

# 1) Get the shortest distance informations: 
Ref <- which(d==min(d[d>0]), useNames=T, arr.ind=T) 

# 2) Subset the original entry to remove thoose towns: 
res <-d[-Ref[,1],-Ref[,1]] 

# 3) Get the subset for the two nearest towns: 
tmp <- d[-Ref[,1],Ref[,1]] 

# 4) Get the vector of minimal distance from original dataset with the two town (row by row on tpm), didn't find a proper way to avoid apply 
dists <- apply(tmp, 1, function(x) { x[x==min(x)] }) 

dists <- dists <- tmp[ tmp == pmin(tmp[,1], tmp[,2]) ] 

# 5) Let's build the resulting matrix: 
tnames <- paste(rownames(Ref),collapse="/") # Get the names of town to the new name 
Finalres <- res 
Finalres[tnames,tnames] <- 0 # Set the diagonal to 0 
Finalres[is.na(Finalres)] <- dists # the previous assignment has set NAs, replae them by the dists values 

Выход:

> Finalres 
     BA FI Na RM TO/MI 
BA  0 662 255 412 877 
FI 662 0 468 268 295 
Na 255 468 0 219 754 
RM 412 268 219 0 564 
TO/MI 877 295 754 564  0 

И выход каждого этапа:

> #Steps: 
> 
> Ref 
    row col 
TO 6 3 
MI 3 6 
> res 
    BA FI Na RM 
BA 0 662 255 412 
FI 662 0 468 268 
Na 255 468 0 219 
RM 412 268 219 0 
> tmp 
    TO MI 
BA 996 877 
FI 400 295 
Na 869 754 
RM 669 564 
> dists 
[1] 877 295 754 564 

Здесь очень много копий объектов, которых можно избежать, чтобы сохранить производительность, и я сделал это для лучшего пошагового обзора.