R/neighb.R

In mplex/multiplex: Algebraic Tools for the Analysis of Multiple Social Networks

neighb <-
function (x, rs, type = c("und", "inn", "out"), k = 1, inclx = FALSE, 
    expand) 
{
    if (isTRUE(attr(rs, "class") == "Rel.System") == FALSE) {
        if (is.array(rs) == FALSE) {
            stop("Data must be at least a stacked array of square matrices.")
        }
        warning("'rs' is transformed into a entire relational system of a \"Rel.System\" class.")
        rs <- rel.sys(rs, bonds = "entire")
    }
    if (isTRUE(k < 0L) == TRUE) 
        stop("'k' must not be negative.")
    if (isTRUE(k == 0L) == TRUE) 
        ifelse((inclx), return(x), return(character(0)))
    ifelse(missing(expand) == FALSE && isTRUE(expand == TRUE) == 
        TRUE, expand <- TRUE, expand <- FALSE)
    if (isTRUE(all(x %in% unique(unlist(dhc(as.character(rs$nodes)))))) == 
        TRUE) {
        if (isTRUE(length(rs$Ties) > 0L) == TRUE) {
            rst <- as.list(unlist(rs$Ties))
            srs <- list()
            for (i in seq_len(length(rst))) {
                tmp <- vector()
                if (length(rst[[i]]) > 0L) {
                  for (n in seq_len(length(x))) {
                    for (j in seq_len(length(rst[[i]]))) {
                      if (x[n] %in% c(c(strsplit(rst[[i]][j], 
                        rs$sep)[[1]][1], strsplit(rst[[i]][j], 
                        rs$sep)[[1]][2]))) {
                        tmp <- append(tmp, rst[[i]][j])
                      }
                    }
                    rm(j)
                  }
                  rm
                }
                srs[[i]] <- as.vector(unlist(tmp))
            }
            rm(i)
            attr(srs, "names") <- attr(rst, "names")
            nrs <- vector()
            for (i in seq_len(length(srs))) {
                if (isTRUE(length(srs[[i]]) > 0L) == TRUE) {
                  for (j in seq_len(length(srs[[i]]))) {
                    switch(match.arg(type), und = nrs <- append(nrs, 
                      strsplit(srs[[i]][j], rs$sep)[[1]][1]), 
                      inn = nrs <- append(nrs, strsplit(srs[[i]][j], 
                        rs$sep)[[1]][1]), out = nrs <- append(nrs, 
                        (strsplit(srs[[i]][j], rs$sep)[[1]][2])))
                    switch(match.arg(type), und = nrs <- append(nrs, 
                      strsplit(srs[[i]][j], rs$sep)[[1]][2]), 
                      inn = NA, out = NA)
                  }
                  rm(j)
                }
            }
            rm(i)
            nb <- unique(nrs)
            if (isTRUE(k > 1L) == TRUE) {
                if (isTRUE(expand == FALSE) == TRUE) {
                  for (K in 2:k) {
                    nb <- append(nb, ngbs(nb, rs, type = type))
                  }
                  rm(K)
                }
                else if (isTRUE(expand == TRUE) == TRUE) {
                  nb2 <- nb
                  nbk <- list()
                  if (!(inclx)) {
                    nbk[[1]] <- nb2[which(!(nb2 %in% x))]
                    ink <- 2L
                  }
                  else {
                    nbk[[1]] <- x
                    nbk[[2]] <- nb2[which(!(nb2 %in% x))]
                    ink <- 3
                    k <- k + 1L
                  }
                  for (K in ink:k) {
                    nb2 <- append(nb2, ngbs(nb2, rs, type = type))
                    nbk[[K]] <- nb2[which(!(nb2 %in% c(nb, unlist(nbk))))]
                  }
                  rm(K)
                  ifelse(!(inclx), attr(nbk, "names") <- paste0("k=", 
                    seq_len(k)), attr(nbk, "names") <- paste0("k=", 
                    seq_along((ink - 2L):k) - 1L))
                }
            }
            else {
                NA
            }
        }
        else if (isTRUE(length(rs$Ties) > 0L) == FALSE) {
            nb <- x
        }
        if (isTRUE(expand == FALSE) == TRUE) {
            ifelse(!(inclx), return(nb[which(!(nb %in% x))]), 
                return(nb))
        }
        else if (isTRUE(expand == TRUE) == TRUE) {
            return(nbk)
        }
    }
    else {
        warning("'x' is not part of the relational system provided.")
        x
    }
}