Confidence clustering

by Oskar Kosch | First published:

Archive URL: http://web.archive.org/web/20200301160639/http://oskarkosch.com/blog/confidence-clustering/

Clustering is usually done with the objective of modularity maximization (e.g., the so-called Louvain algorithm), sometimes with additional constraints (like the Leiden algorithm). But, what is somewhat bizarre, these algorithms are very broad in terms of what they aim to partition, and therefore, are superficial in their interpretation – if one tool is used to fit all needs… then it rather should be used on exploratory stage of research, when the nature of the network and possible insights are yet to be determined.

Here I propose an early version of clustering based on neutrality centrality and few assumptions. The implementation now is a little dirty and should get better with the next versions. Also, please note, that neutrality centrality here is calculated as standard deviation of population, not sample (that explains differences in values when compared to the previous post).

The assumption is that more confident nodes are convincing less confident ones. So this algorithm tries to create clusters based on structural bias. This approach might be especially useful in social network analysis of political sympathies, or separate areas of discrimination in localization of the public utility facilities. It should be noted that in terms of modularity, it will never achieve results the modularity-based algorithms do; on the other hand, it has the potential to become lightweight.

Few things are yet to be implemented:

  • the exclusion of extremists from the confidence network of mainstream nodes (probably this occurs), the extremists_populationvariable
  • the influence of the neighbors as a whole, rather than individuals

Also, this kind of clustering, by implementing assumptions, needs to be yet validated – and by this fact it is different from the other, more generic algorithms. While working on making this algorithm better, I will try to provide layout creating algorithm based on structural bias and rotation of nodes.

Confidence partitioning algorithm
library(igraph)
library(foreach)
library(doParallel)
from  <- rep(1,6)
to    <- c(2:7)
edgelist <- data.frame(form=from, to=to)
star <- graph_from_data_frame(edgelist, directed = F)
plot(star)

prob_bool <- function(t_prob) {
  sample(c(T,F),1,prob=c(t_prob,1-t_prob))
}

clean.g.attributes <- function(graph) {
  for(e in setdiff(vertex_attr_names(graph),'name')) {
    graph <- delete_vertex_attr(graph, e)
  }
  for(e in edge_attr_names(graph)) {
    graph <- delete_edge_attr(graph, e)
  }
  for(e in graph_attr_names(graph)) {
    graph <- delete_graph_attr(graph, e)
  }
  return(graph)
}

vertices_ids <- function(graph) {
  if(is.named(graph)) {
    names <- get.vertex.attribute(graph,'name')
  } else {
    names <- 1:vcount(graph)
  }
  return(names)
}

centr_neutr <- function(graph, moment=2) {
  graph <- clean.g.attributes(graph)
  names <- vertices_ids(graph)
  global.length <- length(names) - 1
  centralities <- foreach(e = names, .combine = 'c') %do% {
    to <- setdiff(names, e)
    dists <- distances(graph, e, to)
    mn <- mean(dists)
    res <- (sum((dists-mn)^moment)/(global.length))^(1/moment)
    # res <- sd(dists)
    return(res)
  }
  names(centralities) <- names
  return(centralities)
}

centr_neutr(star)
       1        2        3        4        5        6        7 
0.000000 0.372678 0.372678 0.372678 0.372678 0.372678 0.372678 
cluster_confidence <- function(graph, extremists_population=0, merge_same_level=.0, lonely_join_neighbours=.0, cent=NULL) {
  names <- vertices_ids(graph)
  if(is.null(cent)) {
    cent <- centr_neutr(graph) 
  }
  extremists <- cent %>% sort(T) %>% {.[0:extremists_population]} %>% names()
  memb <- vector('character', length(cent))
  names(memb) <- names
  from <- to <- c()
  comps <- graph.empty(n=0, directed=F)
  comps <- add_vertices(comps, length(names), name=names)
  for(i in 1:length(names)) {
    nm <- names[i]
    nei <- as.character(neighbors(graph, nm))
    nei_cent <- cent[nei]
    if(any(cent[nm]<nei_cent)) {
      comps <- add_edges(comps, c(nm, nei[which.max(nei_cent)]))
    } else if(merge_same_level>0&any(cent[nm]==nei_cent)&prob_bool(merge_same_level)) {
      comps <- add_edges(comps, c(nm, nei[which.max(nei_cent)]))
    } else if(lonely_join_neighbours>0&prob_bool(lonely_join_neighbours)) {
      comps <- add_edges(comps, c(nm, nei[which.max(nei_cent)]))
    }
  }
  cmps <- components(comps)
  return(cmps$membership)
}
sample_deg <- sample_degseq(sample(c(2,3,3,4),30,T)) %>% simplify()
par(mar=rep(0,4))
plot(sample_deg, vertex.color=cluster_confidence(sample_deg,0,1,1))

LS0tDQp0aXRsZTogIkNvbmZpZGVuY2UgcGFydGlvbmluZyBhbGdvcml0aG0iDQpvdXRwdXQ6IGh0bWxfbm90ZWJvb2sNCi0tLQ0KDQpUaGlzIGlzIGFuIFtSIE1hcmtkb3duXShodHRwOi8vcm1hcmtkb3duLnJzdHVkaW8uY29tKSBOb3RlYm9vay4gV2hlbiB5b3UgZXhlY3V0ZSBjb2RlIHdpdGhpbiB0aGUgbm90ZWJvb2ssIHRoZSByZXN1bHRzIGFwcGVhciBiZW5lYXRoIHRoZSBjb2RlLiANCg0KVHJ5IGV4ZWN1dGluZyB0aGlzIGNodW5rIGJ5IGNsaWNraW5nIHRoZSAqUnVuKiBidXR0b24gd2l0aGluIHRoZSBjaHVuayBvciBieSBwbGFjaW5nIHlvdXIgY3Vyc29yIGluc2lkZSBpdCBhbmQgcHJlc3NpbmcgKkN0cmwrU2hpZnQrRW50ZXIqLiANCg0KYGBge3IgbWVzc2FnZT1GQUxTRX0NCmxpYnJhcnkoaWdyYXBoKQ0KbGlicmFyeShmb3JlYWNoKQ0KbGlicmFyeShkb1BhcmFsbGVsKQ0KZnJvbSAgPC0gcmVwKDEsNikNCnRvICAgIDwtIGMoMjo3KQ0KZWRnZWxpc3QgPC0gZGF0YS5mcmFtZShmb3JtPWZyb20sIHRvPXRvKQ0Kc3RhciA8LSBncmFwaF9mcm9tX2RhdGFfZnJhbWUoZWRnZWxpc3QsIGRpcmVjdGVkID0gRikNCnBsb3Qoc3RhcikNCmBgYA0KDQpgYGB7cn0NCnByb2JfYm9vbCA8LSBmdW5jdGlvbih0X3Byb2IpIHsNCiAgc2FtcGxlKGMoVCxGKSwxLHByb2I9Yyh0X3Byb2IsMS10X3Byb2IpKQ0KfQ0KDQpjbGVhbi5nLmF0dHJpYnV0ZXMgPC0gZnVuY3Rpb24oZ3JhcGgpIHsNCiAgZm9yKGUgaW4gc2V0ZGlmZih2ZXJ0ZXhfYXR0cl9uYW1lcyhncmFwaCksJ25hbWUnKSkgew0KICAgIGdyYXBoIDwtIGRlbGV0ZV92ZXJ0ZXhfYXR0cihncmFwaCwgZSkNCiAgfQ0KICBmb3IoZSBpbiBlZGdlX2F0dHJfbmFtZXMoZ3JhcGgpKSB7DQogICAgZ3JhcGggPC0gZGVsZXRlX2VkZ2VfYXR0cihncmFwaCwgZSkNCiAgfQ0KICBmb3IoZSBpbiBncmFwaF9hdHRyX25hbWVzKGdyYXBoKSkgew0KICAgIGdyYXBoIDwtIGRlbGV0ZV9ncmFwaF9hdHRyKGdyYXBoLCBlKQ0KICB9DQogIHJldHVybihncmFwaCkNCn0NCg0KdmVydGljZXNfaWRzIDwtIGZ1bmN0aW9uKGdyYXBoKSB7DQogIGlmKGlzLm5hbWVkKGdyYXBoKSkgew0KICAgIG5hbWVzIDwtIGdldC52ZXJ0ZXguYXR0cmlidXRlKGdyYXBoLCduYW1lJykNCiAgfSBlbHNlIHsNCiAgICBuYW1lcyA8LSAxOnZjb3VudChncmFwaCkNCiAgfQ0KICByZXR1cm4obmFtZXMpDQp9DQoNCmNlbnRyX25ldXRyIDwtIGZ1bmN0aW9uKGdyYXBoLCBtb21lbnQ9Mikgew0KICBncmFwaCA8LSBjbGVhbi5nLmF0dHJpYnV0ZXMoZ3JhcGgpDQogIG5hbWVzIDwtIHZlcnRpY2VzX2lkcyhncmFwaCkNCiAgZ2xvYmFsLmxlbmd0aCA8LSBsZW5ndGgobmFtZXMpIC0gMQ0KICBjZW50cmFsaXRpZXMgPC0gZm9yZWFjaChlID0gbmFtZXMsIC5jb21iaW5lID0gJ2MnKSAlZG8lIHsNCiAgICB0byA8LSBzZXRkaWZmKG5hbWVzLCBlKQ0KICAgIGRpc3RzIDwtIGRpc3RhbmNlcyhncmFwaCwgZSwgdG8pDQogICAgbW4gPC0gbWVhbihkaXN0cykNCiAgICByZXMgPC0gKHN1bSgoZGlzdHMtbW4pXm1vbWVudCkvKGdsb2JhbC5sZW5ndGgpKV4oMS9tb21lbnQpDQogICAgIyByZXMgPC0gc2QoZGlzdHMpDQogICAgcmV0dXJuKHJlcykNCiAgfQ0KICBuYW1lcyhjZW50cmFsaXRpZXMpIDwtIG5hbWVzDQogIHJldHVybihjZW50cmFsaXRpZXMpDQp9DQoNCmNlbnRyX25ldXRyKHN0YXIpDQpgYGANCg0KDQpgYGB7cn0NCmNsdXN0ZXJfY29uZmlkZW5jZSA8LSBmdW5jdGlvbihncmFwaCwgZXh0cmVtaXN0c19wb3B1bGF0aW9uPTAsIG1lcmdlX3NhbWVfbGV2ZWw9LjAsIGxvbmVseV9qb2luX25laWdoYm91cnM9LjAsIGNlbnQ9TlVMTCkgew0KICBuYW1lcyA8LSB2ZXJ0aWNlc19pZHMoZ3JhcGgpDQogIGlmKGlzLm51bGwoY2VudCkpIHsNCiAgICBjZW50IDwtIGNlbnRyX25ldXRyKGdyYXBoKSANCiAgfQ0KICBleHRyZW1pc3RzIDwtIGNlbnQgJT4lIHNvcnQoVCkgJT4lIHsuWzA6ZXh0cmVtaXN0c19wb3B1bGF0aW9uXX0gJT4lIG5hbWVzKCkNCiAgbWVtYiA8LSB2ZWN0b3IoJ2NoYXJhY3RlcicsIGxlbmd0aChjZW50KSkNCiAgbmFtZXMobWVtYikgPC0gbmFtZXMNCiAgZnJvbSA8LSB0byA8LSBjKCkNCiAgY29tcHMgPC0gZ3JhcGguZW1wdHkobj0wLCBkaXJlY3RlZD1GKQ0KICBjb21wcyA8LSBhZGRfdmVydGljZXMoY29tcHMsIGxlbmd0aChuYW1lcyksIG5hbWU9bmFtZXMpDQogIGZvcihpIGluIDE6bGVuZ3RoKG5hbWVzKSkgew0KICAgIG5tIDwtIG5hbWVzW2ldDQogICAgbmVpIDwtIGFzLmNoYXJhY3RlcihuZWlnaGJvcnMoZ3JhcGgsIG5tKSkNCiAgICBuZWlfY2VudCA8LSBjZW50W25laV0NCiAgICBpZihhbnkoY2VudFtubV08bmVpX2NlbnQpKSB7DQogICAgICBjb21wcyA8LSBhZGRfZWRnZXMoY29tcHMsIGMobm0sIG5laVt3aGljaC5tYXgobmVpX2NlbnQpXSkpDQogICAgfSBlbHNlIGlmKG1lcmdlX3NhbWVfbGV2ZWw+MCZhbnkoY2VudFtubV09PW5laV9jZW50KSZwcm9iX2Jvb2wobWVyZ2Vfc2FtZV9sZXZlbCkpIHsNCiAgICAgIGNvbXBzIDwtIGFkZF9lZGdlcyhjb21wcywgYyhubSwgbmVpW3doaWNoLm1heChuZWlfY2VudCldKSkNCiAgICB9IGVsc2UgaWYobG9uZWx5X2pvaW5fbmVpZ2hib3Vycz4wJnByb2JfYm9vbChsb25lbHlfam9pbl9uZWlnaGJvdXJzKSkgew0KICAgICAgY29tcHMgPC0gYWRkX2VkZ2VzKGNvbXBzLCBjKG5tLCBuZWlbd2hpY2gubWF4KG5laV9jZW50KV0pKQ0KICAgIH0NCiAgfQ0KICBjbXBzIDwtIGNvbXBvbmVudHMoY29tcHMpDQogIHJldHVybihjbXBzJG1lbWJlcnNoaXApDQp9DQpgYGANCg0KYGBge3J9DQpzYW1wbGVfZGVnIDwtIHNhbXBsZV9kZWdzZXEoc2FtcGxlKGMoMiwzLDMsNCksMzAsVCkpICU+JSBzaW1wbGlmeSgpDQpgYGANCg0KYGBge3J9DQpwYXIobWFyPXJlcCgwLDQpKQ0KcGxvdChzYW1wbGVfZGVnLCB2ZXJ0ZXguY29sb3I9Y2x1c3Rlcl9jb25maWRlbmNlKHNhbXBsZV9kZWcsMCwxLDEpKQ0KYGBgDQoNCg0KDQpgYGB7cn0NCmxpYnJhcnkoc2NhbGVzKQ0KbGlicmFyeShzbGFtKQ0KcGFyKG1hcj1yZXAoMCw0KSkNCmxheW91dF9uZXV0cmFsaXR5IDwtIGZ1bmN0aW9uKGdyYXBoLCBjZW50PU5VTEwsIGNpcmNsZXNfbm89TlVMTCkgew0KICBuYW1lcyA8LSB2ZXJ0aWNlc19pZHMoZ3JhcGgpDQogIGlmKGlzLm51bGwoY2VudCkpIHsNCiAgICBjZW50IDwtIGNlbnRyX25ldXRyKGdyYXBoKSANCiAgfQ0KICBpZihpcy5udWxsKGNpcmNsZXNfbm8pKSB7DQogICAgY2lyY2xlc19ubyA8LSBjZWlsaW5nKChkaWFtZXRlcihncmFwaCkgLSAxKS8yKQ0KICB9DQogIGNlbnQgPC0gc2NhbGVzOjpyZXNjYWxlKGNlbnQsIGMoMCwxKSkNCiAgI2NpcmNsZXMgPC0gdGFibGUoY2VudCkgJT4lIHNvcnQoKSAlPiUgey5bMjpsZW5ndGgoLildfSAlPiUgbmFtZXMoKQ0KICBjaXJjbGVzX2NlbnRzIDwtIGN1dChjZW50W2NlbnQhPTBdLCBjaXJjbGVzX25vLCAxOmNpcmNsZXNfbm8vY2lyY2xlc19ubykNCiAgbGV2ZWxzIDwtIHVuaXF1ZShjaXJjbGVzX2NlbnRzKQ0KICBjb29yZHMgPC0gbWF0cml4KG5yb3cgPSB2Y291bnQoZ3JhcGgpLCBuY29sID0gMikNCiAgcm93bmFtZXMoY29vcmRzKSA8LSBuYW1lcw0KICBtaW4gPC0gd2hpY2gubWluKGNlbnQpICU+JSBuYW1lcygpDQogIG5hbWVzKGNpcmNsZXNfY2VudHMpIDwtIHNldGRpZmYobmFtZXMsIG1pbikNCiAgcmF3X2Rpc3RzIDwtIHNpbXBsZV90cmlwbGV0X3plcm9fbWF0cml4KHZjb3VudChncmFwaCksIHZjb3VudChncmFwaCkpDQogIGNvb3Jkc1ttaW4sXSA8LSBjKDAsMCkNCiAgZm9yKGUgaW4gbGV2ZWxzKSB7DQogICAgcG9pbnRzIDwtIA0KICB9DQogIHJldHVybihjb29yZHMpDQp9DQpsYXlvdXRfbmV1dHJhbGl0eShzYW1wbGVfZGVnKQ0KI3Bsb3Qoc2FtcGxlX2RlZywgdmVydGV4LmNvbG9yPWNsdXN0ZXJfY29uZmlkZW5jZShzYW1wbGVfZGVnLDAsMSwxKSkNCmBgYA0KDQoNClRvbyBvZnRlbiByZXNlYXJjaGVycyBhZG9wdCBjbHVzdGVyaW5nIGJhc2VkIG9uIG1vZHVsYXJpdHkgb3B0aW1pemF0aW9uLCBhcyBpdCB3b3VsZCBiZSB0aGUgb25seSBpbXBvcnRhbnQgcGFydCBvZiBjbHVzdGVyaW5nLiBXaGlsZSBpbiBleHBsb3JhdG9yeSByZXNlYXJjaCwgd2hlbiB3ZSBkbyBub3QgbWFrZSBhIGxvdCBvZiBhc3N1bXB0aW9ucyB0aGlzIGlzIGRlZmluaXRlbHkgdGhlIHJpZ2h0IGFwcHJvYWNoLCBpbiB0aGUgc3R1ZGllcyB3ZSBkbyBoYXZlIGh5cG90aGVzZXMsIHdlIHNob3VsZCBhbHNvIGRlcml2ZSBhc3N1bXB0aW9ucyBhbmQgYWRvcHQgdGhlbSBhcyBwYXJ0IG9mIGNsdXN0ZXJpbmcu

Leave a Reply