Weighted Relative Neighborhood Graph in R based on cccd::rng

The R package cccd contains a nice implementation of the Relative Neighborhood Graph (rng) but in the current version 1.5 it returns a non-weighted igraph. But for one of my experiments I needed the weighted version so I've slightly changed the code to get an igraph with weights.
rng <- function (x = NULL, dx = NULL, r = 1, method = NULL, usedeldir = TRUE,
          open = TRUE, k = NA, algorithm = "cover_tree", weighted = TRUE) {
  if (is.na(k)) {
    if (is.null(dx)) {
      if (is.null(x))
        stop("One of x or dx must be given.")
      dx <- as.matrix(proxy::dist(x, method = method))
    }
    else {
      usedeldir <- FALSE
    }
    n <- nrow(dx)
    A <- matrix(0, nrow = n, ncol = n)
    if (is.vector(x))
      x <- matrix(x, ncol = 1)
    if (usedeldir && ncol(x) == 2) {
      del <- deldir::deldir(x[, 1], x[, 2])
      for (edge in 1:nrow(del$delsgs)) {
        i <- del$delsgs[edge, 5]
        j <- del$delsgs[edge, 6]
        d <- min(apply(cbind(dx[i, -c(i, j)], dx[j, -c(i, j)]), 1, max))
        rd <- r * dx[i, j]
        if ((open && rd < d) || rd <= d) {
          A[i, j] <- A[j, i] <- rd
        }
      }
    } else {
      diag(dx) <- Inf
      for (i in 1:n) {
        for (j in setdiff(1:n, i)) {
          d <- min(apply(cbind(dx[i, -c(i, j)], dx[j, -c(i, j)]), 1, max))
          rd <- r * dx[i, j]
          if ((open && rd < d) || rd <= d) {
            A[i, j] <- A[j, i] <- rd
          }
        }
      }
    }
    diag(A) <- 0
    out <- graph.adjacency(A, mode = "undirected", weighted = weighted)
  } else {
    if (is.null(x))
      stop("x must not be null")
    n <- nrow(x)
    k <- min(k, n - 1)
    dx <- get.knn(x, k = k, algorithm = algorithm)
    edges <- NULL
    weights <- NULL
    for (i in 1:n) {
      i.indices <- dx$nn.index[i, ]
      i.dists <- dx$nn.dist[i, ]
      for (j in 1:k) {
        rd <- r * i.dists[j]/2
        j.indices <- dx$nn.index[i.indices[j], ]
        j.dists <- dx$nn.dist[i.indices[j], ]
        rd <- r * i.dists[j]
        S <- setdiff(intersect(i.indices, j.indices),
                     c(i, i.indices[j]))
        if (length(S) > 0) {
          d <- Inf
          for (si in S) {
            a <- which(i.indices == si)
            b <- which(j.indices == si)
            d <- min(d, max(i.dists[a], j.dists[b]))
          }
          if ((open && rd < d) || rd <= d) {
            edges <- cbind(edges, c(i, i.indices[j]))
            weights <- cbind(weights, rd)
          }
        }
      }
    }
    g <- graph(edges, n = n, directed = FALSE)
    if( weighted ) {
      edge.attributes(g) <- list(weight=weights)
    }
    out <- simplify(g, edge.attr.comb = "first")
  }
  if (!is.null(x)) {
    out$layout <- x
  }
  out$r <- r
  out
}

No comments: