.Rhistory

while(dummy0){
i <- i + 1                                                                                             # labels nodes as we visit them
j <- j + 1                                                                                             # position in stack of nodes
# update node numbering
Stack_S[j] <- v
node_numbering[v,"node_number"] <- i
node_numbering[v,"node_lowlink"] <- i
node_numbering[v,"node_onStack"] <- 1
# successors
w_labels <- unlist(successors[v])
# update records were v features as successor
back_idx <- which(util_table_df[,"w_k_node"] == v)
if (length(back_idx) > 0){
util_table_df[back_idx, "w_k_number"] <- node_numbering[v,"node_number"]
util_table_df[back_idx, "w_k_lowlink"] <- node_numbering[v,"node_lowlink"]
}
# check if successor is a sink node
sink_test <- which(is.na(w_labels))
if (length(sink_test) == 0){
w <- match(w_labels, node_names)
n_successors <- length(w)
} else {
w <- NA
n_successors <- 0
}
# initialise a progressive counter for incident nodes reachable from the current node
k <- 0
# Loop #2: explores incident nodes "sequentially" for a given node
dummy1 <- TRUE
while(dummy1){
if(length(sink_test) == 0){                                                                          # the current node has a successor
k <- k + 1
w_k <- w[k]                                                                                        # next incident node (neighbor)
# update main tableau (df version)
util_table_df_subset <- which(rownames(util_table_df) == v_label)                                  # filter for the current node v
if(length(util_table_df_subset) > 1){
if(k == 1){
util_table_df[util_table_df_subset,][k,"i"] <- i
util_table_df[util_table_df_subset,][k,"j"] <- j
util_table_df[util_table_df_subset,][k,"level"] <- level
util_table_df[util_table_df_subset,][k,"v_node"] <- v
util_table_df[util_table_df_subset,][k,"v_number"] <- node_numbering[v,"node_number"]
util_table_df[util_table_df_subset,][k,"v_lowlink"] <- node_numbering[v,"node_lowlink"]
util_table_df[util_table_df_subset,][k,"successors"] <- n_successors
}
util_table_df[util_table_df_subset,][k,"k_successor_idx"] <- k
# util_table_df[util_table_df_subset,][k,"w_k_node"] <- w_k                                        # could be removed...
util_table_df[util_table_df_subset,][k,"w_k_number"] <- node_numbering[w_k,"node_number"]
util_table_df[util_table_df_subset,][k,"w_k_lowlink"] <- node_numbering[w_k, "node_lowlink"]
} else {
if(k == 1){
util_table_df[util_table_df_subset,"i"] <- i
util_table_df[util_table_df_subset,"j"] <- j
util_table_df[util_table_df_subset,"level"] <- level
util_table_df[util_table_df_subset,"v_node"] <- v
util_table_df[util_table_df_subset,"v_number"] <- node_numbering[v,"node_number"]
util_table_df[util_table_df_subset,"v_lowlink"] <- node_numbering[v,"node_lowlink"]
util_table_df[util_table_df_subset,"successors"] <- n_successors
}
util_table_df[util_table_df_subset,"k_successor_idx"] <- k
# util_table_df[util_table_df_subset,"w_k_node"] <- w_k                                            # could be removed...
util_table_df[util_table_df_subset,"w_k_number"] <- node_numbering[w_k,"node_number"]
util_table_df[util_table_df_subset,"w_k_lowlink"] <- node_numbering[w_k, "node_lowlink"]
}
# tests
test0 <- is.na(node_numbering[w_k,"node_number"])                                                  # we can jump onto this node (depth first)
test1 <- node_numbering[w_k,"node_number"] < node_numbering[v,"node_number"]                       # the next node has been visited already?
test2 <- node_numbering[w_k,"node_onStack"] == 1                                                   # the next node is in the stack already OR has been on the stack
} else {                                                                                             # there is no successor to the current node (sink)
# tests
test0 <- FALSE                                                                                     # forces to backtrack if there is no successor
test1 <- FALSE
test2 <- FALSE
# update main tableau (df version)
util_table_df_subset <- which(rownames(util_table_df) == v_label)                                  # filter for the current node v
util_table_df[util_table_df_subset,"i"] <- i
util_table_df[util_table_df_subset,"j"] <- j
util_table_df[util_table_df_subset,"level"] <- level
util_table_df[util_table_df_subset,"v_node"] <- v
util_table_df[util_table_df_subset,"v_number"] <- node_numbering[v,"node_number"]
util_table_df[util_table_df_subset,"v_lowlink"] <- node_numbering[v,"node_lowlink"]
util_table_df[util_table_df_subset,"successors"] <- n_successors
util_table_df[util_table_df_subset,"k_successor_idx"] <- k
util_table_df[util_table_df_subset,"w_k_node"] <- (-1)
util_table_df[util_table_df_subset,"w_k_number"] <- (-1)
util_table_df[util_table_df_subset,"w_k_lowlink"] <- (-1)
}
test_POP <- FALSE
# THIS IS WHERE WE DECIDE WHETHER TO CONTINUE DEPTH-FIRST, LOOK INTO A NEIGHBOUR, OR BACKTRACK
if (test0){
# continue depth-first search
dummy1 <- FALSE                                                                                    # break Loop 2 (exit sequential exploration of successors for a given node)
v <- w_k                                                                                           # move on to successor
v_label <- node_names[v]
# the below avoids having more than one line with the same level
level_max <- max(util_table_df[,"level"], na.rm = T)
if (level < level_max){                                                                            # probably we backtracked and re-winded the level counter.This should get us back where we were before the rewind
level <- level_max + 1
} else {
level <- level + 1
}
} else {
# start "back tracking"
# Loop #3: are there neighbors left to explore?
dummy5 <- TRUE
while(dummy5){
if(k != 0 & k < n_successors) {                                                                  # there are other adjacent nodes left to explore
dummy5 <- FALSE
# update lowlink values - FIRST TYPE (going downwards)
if (test1 == TRUE & test2 == TRUE){                                                             # the current k successor has been visited PRIOR to v (has lower number), and it is on the stack already
node_numbering[v,"node_lowlink"] <- min(node_numbering[v,"node_lowlink"],node_numbering[w_k,"node_number"])
util_table_df_subset <- which(rownames(util_table_df) == v_label)                              # filter for the current node v
if(length(util_table_df_subset) > 1){
util_table_df[util_table_df_subset,][1,"v_lowlink"] <- node_numbering[v,"node_lowlink"]      # always update the first line, corresponding to v
} else {
util_table_df[util_table_df_subset,"v_lowlink"] <- node_numbering[v,"node_lowlink"]
}
# update lowlink elsewhere
other_idx <- which(util_table_df[,"w_k_node"] == v)
if(length(other_idx)>0){
util_table_df[other_idx, "w_k_lowlink"] <- node_numbering[v,"node_lowlink"]
}
}
} else {
dummy3 <- TRUE
# Loop #4: revisit all the neighbours already visited
while (dummy3) {
if(n_successors !=0 & k !=0){                         # we are not at a sink node / we have not re-visited all the neighbors
# re-do test
test0 <- is.na(node_numbering[w_k,"node_number"])                                 # we can jump onto this node (depth first)
test1 <- node_numbering[w_k,"node_number"] < node_numbering[v,"node_number"]      # the next node has been visited already?
test2 <- node_numbering[w_k,"node_onStack"] == 1                                  # the next node is in the stack already
if (test2){                                                                       # the next node is STILL on the stack PLEASE DO NOT ADD TEST 1 OR WILL MESS UP
# update lowlink values - SECOND TYPE (ascending)
old_v_lowlink <- node_numbering[v,"node_lowlink"]
node_numbering[v,"node_lowlink"] <- min(node_numbering[v,"node_lowlink"],node_numbering[w_k,"node_lowlink"])
util_table_df_subset <- which(rownames(util_table_df) == v_label)                              # filter for the current node v
if(length(util_table_df_subset) > 1){
util_table_df[util_table_df_subset,][1,"v_lowlink"] <- node_numbering[v,"node_lowlink"]      # always update the first line, corresponding to v
} else {
util_table_df[util_table_df_subset,"v_lowlink"] <- node_numbering[v,"node_lowlink"]
}
# update lowlink elsewhere
other_idx <- which(util_table_df[,"w_k_node"] == v)
if(length(other_idx)>0){
util_table_df[other_idx, "w_k_lowlink"] <- node_numbering[v,"node_lowlink"]
}
}
# go back to the previous neighbour already visited
k <- k - 1
if (k !=0){
w_k <- w[k]
#re-do the test
test0 <- is.na(node_numbering[w_k,"node_number"])                                 # we can jump onto this node (depth first)
test1 <- node_numbering[w_k,"node_number"] < node_numbering[v,"node_number"]      # the next node has been visited already?
test2 <- node_numbering[w_k,"node_onStack"] == 1                                  # the next node is in the stack already
} else {
test2 <- FALSE
test1 <- FALSE
test0 <- FALSE
w_k <- (-1)
}
} else {
# either we are at a sink node or we have re-visited all the neighbors
# NEW: WHEN WE ARE HERE, WE ARE FORCING THE BACKTRACKING - THERE WAS NO PATH LEADING US back to previously encountered nodes
# therefore we MUST NOT UPDATE LOWLINK when we encounter a node we visited before
# if v is a root node (lowlink = number), we can pop the stack at this stage
test_POP <- node_numbering[v,"node_number"] == node_numbering[v,"node_lowlink"]       # from Tarjan's original paper
# BEFORE POPPING
abort_POP <- (test_POP & level == 1)
if (abort_POP & flag_extra_round){
# we reached the last level (at least until we restart with level 1); WE NEED TO make sure that all nodes' lowlink values matches the lowest  lowlink of their successors.
# It happens that the root node gets popped out then the lowlink update occurs, and a bunch of nodes are left without root and can't pop next
# if that's not the case it may be that we need more rounds of update
extra_round_counter <- extra_round_counter + 1
# the below checks that we DON'T HAVE NODES WITH THE LATEST SUCCESSOR'S LOWLINK VALUE BEING lower THAN THE NODE'S LOWLINK
# if a node's LOWLINK is larger than the lowest among its successors' LOWLINK the we need to keep updating
update_needed <- lapply(Stack_S, function(x){
v_lowlink <- node_numbering[x,"node_lowlink"]
v_neigb_lowest_lowlink <- min(util_table_df[which(util_table_df[,"v_node"] == x) , "w_k_lowlink"])
if(v_neigb_lowest_lowlink > 0){                                                       # sink nodes by convention get "-1" in this field which might cause looping forever
if(v_lowlink != v_neigb_lowest_lowlink){
1
} else {0}
} else {0}
})
updates_test <- sum(unlist(update_needed))
if(updates_test > 0 & extra_round_counter < 4){
# reset the level to a max but add one and let the loop later pick which level is righ
level <- max(util_table_df[which(!is.na(util_table_df[,"level"])),"level"]) + 1          # start all over again, hoping we get all the lowlinks updated
test_POP <- FALSE                                                                        # ABORT POPPING FOR NOW
} else {
flag_extra_round <- FALSE                                                             # break out of this
abort_POP <- FALSE
}
}
if (test_POP){
# THIS IS WHERE WE POP THE STACK AND POPULATE THE COMPONENT
# update count of nodes not numbered yet
nodes_not_numbered_yet <- length(which(is.na(node_numbering[,"node_number"])))
# NEW: we want to pop the stack but only using v as a root (leave other nodes alone, if any) - different test to enter the stack-popping stage
temp_idx <- as.numeric(which(!is.na(node_numbering[,"node_number"])))
temp_subset_a <- which(node_numbering[temp_idx, "node_number"] >= node_numbering[v,"node_number"])
nodes_visited_so_far <- match(names(temp_subset_a[as.numeric(which(node_numbering[names(temp_subset_a), "node_onStack"] == 1))]), node_names)
Stack_S_BACKUP <- Stack_S
Component_list_BACKUP <- Component_list
# Start of "Pop nodes" sub, but only if we're done with depth-first search
# NEW: notice that the loop below should go from node "v" onward
for(r in nodes_visited_so_far){
x <- as.numeric(node_numbering[r,])
if (x[1] == x[2]){                         # the node is a root node
comp_count <- comp_count + 1                               # component number
# put nodes in component
temp_component_list <- lapply(1:length(Stack_S), function(s){
y <- Stack_S[[s]]
pop_test1 <- node_numbering[y, "node_number"] >= x[1]
pop_test2 <- node_numbering[y, "node_lowlink"] == x[2]
if(pop_test1 & pop_test2){
y
}
})
to_delete <- unlist(temp_component_list)
Component_list[[comp_count]] <- to_delete
# pop elements out of stack
#idx_delete <- which(Stack_S == to_delete)
temp_idx_delete <- rep(seq_along(Stack_S), sapply(Stack_S, length))         # thread: https://stackoverflow.com/questions/11002391/fast-way-of-getting-index-of-match-in-list
idx_delete <- temp_idx_delete[match(to_delete, unlist(Stack_S))]
Stack_S[idx_delete] <- NULL
# update j or the size of the stack will change later
j <- j - length(idx_delete)
# update table
node_numbering[to_delete,"node_onStack"] <- (-1)    # mark elements that have been on stack, but no longer are
}
}
}
dummy3 <- FALSE                                                                                                    # break loop 4 after moving one level up - REGARDLESS of popping the stack
# NEW: modified version of finding the "right level" to go back to
# ignore if we're forcing one last iteration to update lowling - special case
test_skip <- FALSE
while(!test_skip & level > 0){
level <- level - 1                                                                                             # if there is no successor OR the node at this level is not on the stack, keep going backwards
if(level != 0){
v_temp <- util_table_df[which(util_table_df[,"level"] == level),"v_node"]
level_on_stack <- (node_numbering[v_temp,"node_onStack"] == 1)                                               # skip levels that correspond to nodes that have been removed from stack
test_any_successor <- length(which(util_table_df[,"level"] == level & util_table_df[, "successors"] !=0))    # (no successor going up one level)
test_skip <- (level_on_stack & test_any_successor > 0)
}
}
# GET BACK TO WHERE YOU LEFT THINGS AT THE PREVIOUS LEVEL
if (level > 0){
back_idx <- which(util_table_df[,"level"] == level & util_table_df[, "successors"] !=0)       # there may be more than one node with the same level if E.G. ONE NEIGHBOUR IS A SINK but the other isn't. We ignore the sink
v <- util_table_df[back_idx, "v_node"]
v_label <-  node_names[v]
n_successors <- util_table_df[back_idx, "successors"]
k_back_idx_a <- as.numeric(which(util_table_df[, "v_node"] == v))
util_table_df_subset <- util_table_df[k_back_idx_a,]
if(length(k_back_idx_a) > 1){
k_back_idx_b <- max(which(!is.na(util_table_df_subset[, "k_successor_idx"])))               # retrieve last successor index explored for the current node
k <- util_table_df_subset[k_back_idx_b , "k_successor_idx"]
w_k <- util_table_df_subset[k_back_idx_b , "w_k_node"]
} else {
k <- as.numeric(util_table_df_subset["k_successor_idx"])
w_k <- as.numeric(util_table_df_subset["w_k_node"])
}
w <- as.numeric(util_table_df[k_back_idx_a, "w_k_node"])
w_labels <- node_names[w]
sink_test <- which(is.na(w_labels))                                                         # check if the successor is a sink node
# re-do test
test0 <- is.na(node_numbering[w_k,"node_number"])                                 # we can jump onto this node (depth first)
test1 <- node_numbering[w_k,"node_number"] < node_numbering[v,"node_number"]      # the next node has been visited already?
test2 <- node_numbering[w_k,"node_onStack"] == 1                                  # the next node is in the stack already
}
}
} # end of Loop 4 (dummy 3)
if(level == 0) {
dummy5 <- FALSE                                                                                # break loop 3
dummy1 <- FALSE                                                                                # break loop 2 (ends up in the same place as if there were no successors)
}
}
}  # end of Loop 3 (dummy 5)
} #  end of ELSE - "back tracking" sub
} # end of Loop 2 (dummy1)
nodes_not_numbered_yet <- length(which(is.na(node_numbering[,"node_number"])))
nodes_visited_so_far <- as.numeric(which(!is.na(node_numbering[,"node_number"]) & node_numbering[,"node_onStack"] == 1))
if(!test0 & test_POP){
if(nodes_not_numbered_yet == 0){                                                                     # break Loop 1 (depths first exploration of successors, jumping between nodes) and move up one level
dummy4 <- FALSE                                                                                    # break Loop 5: YOU'RE DONE
}
dummy0 <- FALSE                                                                                      # break Loop 1
# if we are here, we'll restart the level counter. re-label the LEVELS used so that they do not interefere with the next component
util_table_df_BACKUP <- util_table_df
idx_change_level <- which(!is.na(util_table_df[,"level"]) & util_table_df[,"level"] > 0)
util_table_df[idx_change_level,"level"] <- (-1)*util_table_df[idx_change_level,"level"]
}
} # end of Loop 1 (dummy0)
} # end of Loop 0 (dummy4)
list(n = length(Component_list),
sizes = Component_list|> lengths())
}
#' Tarjan's algorithm for finding strongly connected components in C++
#'
#' This function performs a depth-first search (DFS) on a directed graph to identify
#' strongly connected components (SCCs) and their size
#'
#' This function is a modified version of the C++ implementation of Tarjan's
#' algorithm for finding strongly connected components in directed graphs made
#' available by the webiste Geeks for Geeks (see References).
#'
#'
#' @param x A square adjacency matrix representing the directed network.
#'
#' @details The function consists of several internal steps:
#' \enumerate{
#'   \item{Node Labeling - All nodes are labeled with two-digit names for clarity in referencing.}
#'   \item{Successor List Creation - For each node, lists of direct successors are compiled.}
#'   \item{Utilization Table Setup - A table is set up for tracking exploration details such as depth and backtracking information.}
#'   \item{Main DFS Loop - The core loop where DFS occurs, including node visitation and backtracking logic to determine SCCs.}
#'   \item{Stack Management - Nodes are managed in a stack to keep track of the current path of exploration and to facilitate backtracking.}
#'   \item{SCC Identification - Upon finishing exploration of an SCC, it is identified and nodes are popped from the stack.}
#' }
#'
#' @return A list containing two elements:
#' \itemize{
#'  \item{\code{n} - number of strongly connected components}
#'  \item{\code{sizes} - size of each strongly connected component, in order of discovery}
#' }
#'
#' @references Geeks for Geeks. ‘Strongly Connected Components’. C++, 17 January 2024. \url{https://www.geeksforgeeks.org/strongly-connected-components/}.
#'
#' @author \enc{Geeks for Geeks}{GeeksForGeeks}
#' @author \enc{Telarico, Fabio Ashtar}{Fabio Ashtar Telarico}
#'
#' @useDynLib FinNet
#' @importFrom Rcpp sourceCpp
#'
#' @family SCC finders
#'
#' @keywords internal
SCC2 <- function(x){
# Create list of edges in the format
# list(c(starting_node_edge1, end_node_edge1),
#      c(starting_node_edge2, end_node_edge2),
#      ...)
# Remove isolated nodes
x2 <- x[rowSums(x)!=0, colSums(x)!=0]
# If only one node left
if(!is(x2, 'matrix')){
return(list(n = nrow(x), sizes = rep(1, nrow(x))))
} else {
x <- x2
}
# Locate out-going neighbours
x <- apply(x, 1, function(j)which(j!=0))
# Take care of nodes with multiple or no out-going neighbours
x <- lapply(seq_along(x), function(i){ # For each starting node
# Create a data frame
matrix(x[[i]], nrow = 1, byrow = TRUE)|>
rbind(rep(i, length(x[[i]])), x2 = _)|>
as.data.frame()
})
# Get list of edges
x <- do.call(cbind, x)|> as.list()
y <- .Call('_FinNet_findSCC', length(unique(unlist(x))), x)
list(n = length(y), sizes = lengths(y))
}
x<-mat
# For each node in the ordering
for(k in seq_along(nodes)[-n]) {
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
sizes[k+1] <- max(y$sizes)
num[k+1] <- y$n
}; rm(i, k, y)
x<-mat
k<-1
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
sizes[k+1] <- max(y$sizes)
num[k+1] <- y$n
i <- nodes[2]
i <- k-sum(nodes[1:(k-1)]<i)
x[-nodes[i], -nodes[i]]
blockmodeling::plot.mat(x)
f(x)
f<-SCC2
x<-mat
k<-1
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
y$n
k<-2
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
max(y$sizes)
blockmodeling::plot.mat(x)
f<-SCC
x<-mat
k<-1
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
k<-2
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
blockmodeling::plot.mat(x)
y <- f(x)
y$n
max(y$sizes)
x<-mat
# For each node in the ordering
for(k in seq_along(nodes)[-n]) {
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
sizes[k+1] <- max(y$sizes)
num[k+1] <- y$n
}; rm(i, k, y)
x<-mat
x<-mat; f<-SCC2
# For each node in the ordering
for(k in seq_along(nodes)[-n]) {
print(c(k, nodes[k]))
i <- nodes[k]
if(k!=1){
i <- k-sum(nodes[1:(k-1)]<i)
}
x <- x[-nodes[i], -nodes[i]]
y <- f(x)
sizes[k+1] <- max(y$sizes)
num[k+1] <- y$n
}; rm(i, k, y)
devtools::check(env_vars = c(NOT_CRAN = 'false'))
devtools::build()
# Check if `yahoofinancer` is installed
isTRUE(requireNamespace('yahoofinancer', quietly = TRUE))
# Create a list of the desired firms
data('firms_US')
firms <- firms_US
rm(firms_US)
firms <- firms_US
# Identify common-ownership relations in a firm-firm matrix
FF <- FF.norm.ownership(firms)
# Identify common-ownership relations in a firm-firm matrix
FF <- FinNet::FF.norm.ownership(firms)
# Create a simple-looking graph
g <- FF.net(FF, aesthetic = 'simple')
# Create a simple-looking graph
g <- FinNet::FF.net(FF, aesthetic = 'simple')
# The order of the graph equals the number of rows in the FF matrix
network.edgecount(g) == nrow(FF)
# The order of the graph equals the number of rows in the FF matrix
network.edgecount(g@data) == nrow(FF)
network::network.edgecount
?network.vertex.names
devtools::build()
devtools::document()
?network::plot.network
devtools::document()
devtools::build()
devtools::build()
devtools::build()
devtools::build()
devtools::install()
devtools::install()
# Create a list of the desired firms
data('firms_US')
firms <- firms_US
rm(firms_US)
# Identify common-ownership relations in a firm-firm matrix
FF <- FF.norm.ownership(firms)
library(FinNet)
library(FinNet)
View(firms)
remove.packages("FinNet")
devtools::install()
devtools::install()
devtools::install()
if('FinNet'%in%rownames(installed.packages()))remove.packages('FinNet')
devtools::document()
devtools::build()
devtools::check(env_vars = c(NOT_CRAN = 'false'))