iramuteq.org Git - iramuteq/blob - Rscripts/distance-labbe.R

   1 #Author: Pierre Ratinaud
   2 #Copyright (c) 2015-2016 Pierre Ratinaud
   3 #License: GNU/GPL
   4
   5 #Distance de Labbe
   6 ###########
   7 #NEED TEST#
   8 ###########
   9
  10
  11 compute.labbe <- function(x, y, tab) {
  12
  13     mini.tab <- tab[,c(x, y)]
  14
  15     cs <- colSums(mini.tab)
  16
  17     N1 <- cs[1]
  18     N2 <- cs[2]
  19
  20     plus.grand <- ifelse(N1>N2, 1,2)
  21     plus.petit <- ifelse(N1>N2, 2,1)
  22
  23     if (plus.grand == 1) {
  24         U <- N2/N1
  25         mini.tab[,1] <- mini.tab[,1] * U
  26                 col.plusgrand <- mini.tab[,1]
  27                 cs.plus.grand <- sum(col.plusgrand[col.plusgrand>=1])
  28     } else {
  29         U <- N1/N2
  30         mini.tab[,2] <- mini.tab[,2] * U
  31                 col.plusgrand <- mini.tab[,2]
  32                 cs.plus.grand <- sum(col.plusgrand[col.plusgrand>=1])
  33     }
  34     #print(U)
  35     #print(cs.plus.grand)
  36     commun <- which((mini.tab[,1] > 0) & (mini.tab[,2] > 0))
  37     deA <- which((mini.tab[,plus.petit] > 0) & (mini.tab[,plus.grand] == 0))
  38     deB <- which((mini.tab[,plus.petit] == 0)  & (mini.tab[,plus.grand] >= 1))
  39
  40     dist.commun <- abs(mini.tab[commun, plus.petit] - mini.tab[commun, plus.grand])
  41     dist.deA <- abs(mini.tab[deA, plus.petit] - mini.tab[deA, plus.grand])
  42     dist.deB <- abs(mini.tab[deB, plus.petit] - mini.tab[deB, plus.grand])
  43     dist.labbe <- sum(dist.commun) + sum(dist.deA) + sum(dist.deB)
  44     #print(cs[plus.petit])
  45     #print(dist.labbe)
  46
  47     indice.labbe <- dist.labbe/(cs[plus.petit] + cs.plus.grand)
  48     res = list(indice.labbe = indice.labbe, commun=commun, deA=deA, deB=deB, dist.commun=dist.commun, dist.deA=dist.deA, dist.deB=dist.deB)
  49         res
  50 }
  51
  52 #calcul pour distance texte 1 et 2
  53 #compute.labbe(1,2,tab)
  54
  55 dist.labbe <- function(tab) {
  56         mat <- matrix(NA, ncol=ncol(tab), nrow=ncol(tab))
  57         rownames(mat) <- colnames(tab)
  58         colnames(mat) <- colnames(tab)
  59         for (i in 1:(ncol(tab)-1)) {
  60                 for (j in (1+i):ncol(tab)) {
  61                         #lab <- compute.labbe(i,j,tab)
  62                         mat[j,i] <- compute.labbe(i,j,tab)$indice.labbe
  63                 }
  64         }
  65     mat
  66 }
  67
  68 dist.labbe2 <- function(tab) {
  69     distance_from_idxs <- function (idxs) {
  70         i1 <- idxs[1]
  71         i2 <- idxs[2]
  72         compute.labbe(i1, i2, tab)$indice.labbe
  73     }
  74
  75     size <- ncol(tab)
  76     d <- apply(utils::combn(size, 2), 2, distance_from_idxs)
  77     attr(d, "Size") <- size
  78     xnames <- colnames(tab)
  79     if (!is.null(xnames)) {
  80         attr(d, "Labels") <- xnames
  81     }
  82     attr(d, "Diag") <- FALSE
  83     attr(d, "Upper") <- FALSE
  84     class(d) <- "dist"
  85     d
  86         #mat <- matrix(NA, ncol=ncol(tab), nrow=ncol(tab))
  87         #rownames(mat) <- colnames(tab)
  88         #colnames(mat) <- colnames(tab)
  89         #for (i in 1:(ncol(tab)-1)) {
  90         #       for (j in (1+i):ncol(tab)) {
  91                         #lab <- compute.labbe(i,j,tab)
  92         #               mat[j,i] <- compute.labbe(i,j,tab)$indice.labbe
  93         #       }
  94         #}
  95     #mat
  96 }
  97
  98 dist.labbe3 <- function(tab) {
  99     distance_from_idxs <- function (idxs) {
 100         i1 <- tab[,idxs[1]]
 101         i2 <- tab[,idxs[2]]
 102         labbe(i1, i2)
 103     }
 104
 105     size <- ncol(tab)
 106     d <- apply(utils::combn(size, 2), 2, distance_from_idxs)
 107     attr(d, "Size") <- size
 108     xnames <- colnames(tab)
 109     if (!is.null(xnames)) {
 110         attr(d, "Labels") <- xnames
 111     }
 112     attr(d, "Diag") <- FALSE
 113     attr(d, "Upper") <- FALSE
 114     class(d) <- "dist"
 115     d
 116
 117 }