R/transitive.reduction.R

In IATscores: Implicit Association Test Scores Using Robust Statistics

# function borrowed from package 'nem', since the installation of 
# nem from bioconductor proved problematic
# 
transitive.reduction <- function (g) 
{
  # if (!(class(g) %in% c("matrix", "graphNEL"))) 
  #   stop("Input must be an adjacency matrix or graphNEL object")
  # if (class(g) == "graphNEL") {
  #   g = as(g, "matrix")
  # }
  g = transitive.closure(g, mat = TRUE)
  g = g - diag(diag(g))
  type = (g > 1) * 1 - (g < 0) * 1
  for (y in 1:nrow(g)) {
    for (x in 1:nrow(g)) {
      if (g[x, y] != 0) {
        for (j in 1:nrow(g)) {
          if ((g[y, j] != 0) & sign(type[x, j]) * sign(type[x, 
                                                            y]) * sign(type[y, j]) != -1) {
            g[x, j] = 0
          }
        }
      }
    }
  }
  g
}


transitive.closure <- function (g, mat = FALSE, loops = TRUE) 
{
  # if (!(class(g) %in% c("graphNEL", "matrix"))) 
  #   stop("Input must be either graphNEL object or adjacency matrix")
  # g <- as(g, "matrix")
  n <- ncol(g)
  matExpIterativ <- function(x, pow, y = x, z = x, i = 1) {
    while (i < pow) {
      z <- z %*% x
      y <- y + z
      i <- i + 1
    }
    return(y)
  }
  h <- matExpIterativ(g, n)
  h <- (h > 0) * 1
  dimnames(h) <- dimnames(g)
  if (!loops) 
    diag(h) <- rep(0, n)
  else diag(h) <- rep(1, n)
  # if (!mat) 
  #   h <- as(h, "graphNEL")
  return(h)
}