Nothing
# define methods ----------------------------------------------------------
# init the statistical matrix
init_REM_choice <- function(effectFun, ...) {
UseMethod("init_REM_choice", effectFun)
}
# default -----------------------------------------------------------------
init_REM_choice.default <- function(
effectFun,
network = NULL, attribute = NULL,
window,
n1, n2, ...) {
init_DyNAM_choice.default(
effectFun = effectFun,
network = network, attribute = attribute,
window = window,
n1 = n1, n2 = n2, ...
)
}
# Structural effects ------------------------------------------------------
# tie ---------------------------------------------------------------------
init_REM_choice.tie <- function(effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.tie(
effectFun = effectFun, network = network,
window = window, n1 = n1, n2 = n2, ...
)
}
update_REM_choice_tie <- function(
network,
sender, receiver, replace,
weighted = FALSE, transformFun = identity) {
update_DyNAM_choice_tie(
network = network,
sender = sender, receiver = receiver, replace = replace,
weighted = weighted, transformFun = transformFun
)
}
# inertia -----------------------------------------------------------------
init_REM_choice.inertia <- function(effectFun, network, window, n1, n2, ...) {
init_REM_choice.tie(
effectFun = effectFun, network = network,
window = window, n1 = n1, n2 = n2, ...
)
}
update_REM_choice_inertia <- function(
network,
sender, receiver, replace,
weighted = FALSE, transformFun = identity) {
update_REM_choice_tie(
network = network,
sender = sender, receiver = receiver, replace = replace,
weighted = weighted, transformFun = transformFun
)
}
# recip -------------------------------------------------------------------
init_REM_choice.recip <- function(effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.recip(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_recip <- function(
network,
sender, receiver, replace,
isTwoMode = FALSE,
weighted = FALSE,
transformFun = identity) {
update_DyNAM_choice_recip(
network = network,
sender = sender, receiver = receiver, replace = replace,
isTwoMode = isTwoMode,
weighted = weighted,
transformFun = transformFun
)
}
# indeg -------------------------------------------------------------------
#' init stat matrix indegree using cache
#'
#' @param effectFun function with additional parameters weighted, isTwoMode,
#' transformFun, type
#' @param network matrix n1*n2
#' @param window NULL|numeric size of the window
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#'
#' @return list with named components: cache numeric vector size n2,
#' stat matrix numeric n1*n2
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) {
#' NULL
#' }
#' init_REM_choice.indeg(effectFUN, network, NULL, 5, 6)
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0,
#' 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 3,
#' 1, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0
#' ),
#' nrow = 5, ncol = 5, byrow = TRUE
#' )
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity,
#' type = "ego") {
#' NULL
#' }
#' init_REM_choice.indeg(effectFUN, network, NULL, 5, 5)
#'
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity,
#' type = "alter") {
#' NULL
#' }
#' init_REM_choice.indeg(effectFUN, network, NULL, 5, 5)
#' }
init_REM_choice.indeg <- function(effectFun, network, window, n1, n2, ...) {
# Get arguments
params <- formals(effectFun)
weighted <- eval(params[["weighted"]])
isTwoMode <- eval(params[["isTwoMode"]])
funApply <- eval(params[["transformFun"]])
type <- eval(params[["type"]])
if (isTwoMode && type == "ego") {
stop(dQuote("indeg"),
"effect must not use for type 'ego' (type = 'ego') when is ",
"a two-mode network (isTwoMode = TRUE) ",
call. = FALSE
)
}
# has window or is empty initialize empty
if ((!is.null(window) && !is.infinite(window)) || all(network == 0)) {
return(list(
cache = numeric(n2),
stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2)
))
}
# indeg as colsums
cache <- .colSums(if (weighted) network else network > 0, n1, n2,
na.rm = TRUE
)
# applied transformFun instead
stat <- forceAndCall(1, funApply, cache)
# return expected n1 * n2 matrix
# update check that type should be one of "alter" or "ego"
byRow <- type == "alter"
stat <- matrix(stat, nrow = n1, ncol = n2, byrow = byRow)
#
if (!isTwoMode) diag(stat) <- 0
return(list(cache = cache, stat = stat))
}
#' update stat indegree using cache
#'
#' @param network matrix n1*n2
#' @param sender integer
#' @param receiver integer
#' @param replace numeric
#' @param cache numeric vector size n2
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#' @param isTwoMode logical
#' @param weighted logical
#' @param transformFun function to apply to the stat
#' @param type character should be 'alter' or 'ego' type
#'
#' @return list:
#' cache numeric vector size n2,
#' changes NULL || array cbind(node1 = x, node2 = y, replace = z) stat updates
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' cache <- c(2, 7, 0, 1, 0, 7)
#' update_REM_choice_indeg(
#' network,
#' 1, 2, 3,
#' cache, 5, 6,
#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "ego"
#' )
#'
#' update_REM_choice_indeg(
#' network,
#' 1, 2, 3,
#' cache, 5, 6,
#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "al"
#' )
#' }
update_REM_choice_indeg <- function(
network,
sender, receiver, replace, cache,
n1, n2, isTwoMode = FALSE,
weighted = FALSE, transformFun = identity,
type = c("alter", "ego")) {
type <- match.arg(type)
# init res: changes NULL if not changes
res <- list(cache = NULL, changes = NULL)
# Get old value
oldValue <- network[sender, receiver]
# change weighted
if (!weighted) {
oldValue <- sign(oldValue)
replace <- sign(replace)
}
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(oldValue)) oldValue <- 0
if (is.na(replace)) replace <- 0
# update cache for receiver, event/tie
cache[receiver] <- cache[receiver] + replace - oldValue
if (type == "alter") {
# when the cache had change
if (isTwoMode) {
other <- seq_len(n1)
} else {
other <- setdiff(seq_len(n1), receiver)
}
changes <- cbind(
node1 = other,
node2 = receiver,
replace = forceAndCall(1, transformFun, cache[receiver])
)
} else if (type == "ego") {
# when the cache had change
if (isTwoMode) {
other <- seq_len(n2)
} else {
other <- setdiff(seq_len(n2), receiver)
}
changes <- cbind(
node1 = receiver,
node2 = other,
replace = forceAndCall(1, transformFun, cache[receiver])
)
}
return(list(cache = cache, changes = changes))
}
# outdeg -------------------------------------------------------------------
#' init stat matrix outdegree using cache
#'
#' @param effectFun function with additional parameters weighted, isTwoMode,
#' transformFun, type
#' @param network matrix n1*n2
#' @param window NULL||numeric(1) size of the window,
#' if not null and not Inf return empty stat and cache
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#'
#' @return list with named components: cache numeric vector size n2,
#' stat matrix numeric n1*n2
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) {
#' NULL
#' }
#' init_REM_choice.outdeg(effectFUN, network, NULL, 5, 6)
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0,
#' 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 3,
#' 1, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0
#' ),
#' nrow = 5, ncol = 5, byrow = TRUE
#' )
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity,
#' type = "ego") {
#' NULL
#' }
#' init_REM_choice.outdeg(effectFUN, network, 1, 5, 5)
#'
#' effectFUN <- function(
#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity,
#' type = "alter") {
#' NULL
#' }
#' init_REM_choice.outdeg(effectFUN, network, NULL, 5, 5)
#' }
init_REM_choice.outdeg <- function(effectFun, network, window, n1, n2, ...) {
# Get arguments
params <- formals(effectFun)
weighted <- eval(params[["weighted"]])
isTwoMode <- eval(params[["isTwoMode"]])
funApply <- eval(params[["transformFun"]])
type <- eval(params[["type"]])
if (isTwoMode && type == "alter") {
stop(
dQuote("outdeg"),
"effect must not use for type 'alter' (type = 'alter') when is ",
"a two-mode network (isTwoMode = TRUE) ",
call. = FALSE
)
}
# has window or is empty initialize empty
if ((!is.null(window) && !is.infinite(window)) || all(network == 0)) {
return(list(
cache = numeric(n1),
stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2)
))
}
# indeg as colsums
cache <- .rowSums(if (weighted) network else network > 0, n1, n2,
na.rm = TRUE
)
# applied transformFun instead
stat <- forceAndCall(1, funApply, cache)
# return expected n1 * n2 matrix
# update check that type should be one of "alter" or "ego"
byRow <- type == "alter"
stat <- matrix(stat, nrow = n1, ncol = n2, byrow = byRow)
#
if (!isTwoMode) diag(stat) <- 0
return(list(cache = cache, stat = stat))
}
#' update stat outdegree using cache
#'
#' @param network matrix n1*n2
#' @param sender integer
#' @param receiver integer
#' @param replace numeric
#' @param cache numeric vector size n2
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#' @param isTwoMode logical
#' @param weighted logical
#' @param transformFun function to apply to the stat
#' @param type character should be 'alter' or 'ego' type
#'
#' @return list:
#' cache numeric vector size n1,
#' changes NULL || array cbind(node1 = x, node2 = y, replace = z) stat updates
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' cache <- c(2, 7, 0, 1, 0, 7)
#' update_REM_choice_outdeg(
#' network,
#' 1, 2, 3,
#' cache, 5, 6,
#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "ego"
#' )
#'
#' update_REM_choice_outdeg(
#' network,
#' 1, 2, 3,
#' cache, 5, 6,
#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "al"
#' )
#' }
update_REM_choice_outdeg <- function(
network,
sender, receiver, replace, cache,
n1, n2, isTwoMode = FALSE,
weighted = FALSE, transformFun = identity,
type = c("alter", "ego")) {
type <- match.arg(type)
# init res: changes NULL if not changes
res <- list(cache = NULL, changes = NULL)
# Get old value
oldValue <- network[sender, receiver]
# change weighted
if (!weighted) {
oldValue <- sign(oldValue)
replace <- sign(replace)
}
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(oldValue)) oldValue <- 0
if (is.na(replace)) replace <- 0
# update cache for sender, event/tie
cache[sender] <- cache[sender] + replace - oldValue
if (type == "alter") {
# when the cache had change
if (isTwoMode) {
other <- seq_len(n1)
} else {
other <- setdiff(seq_len(n1), sender)
}
changes <- cbind(
node1 = other,
node2 = sender,
replace = forceAndCall(1, transformFun, cache[sender])
)
} else if (type == "ego") {
# when the cache had change
if (isTwoMode) {
other <- seq_len(n2)
} else {
other <- setdiff(seq_len(n2), sender)
}
changes <- cbind(
node1 = sender,
node2 = other,
replace = forceAndCall(1, transformFun, cache[sender])
)
}
return(list(cache = cache, changes = changes))
}
# trans -------------------------------------------------------------------
init_REM_choice.trans <- function(effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.trans(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_trans <- function(
network,
sender,
receiver,
replace, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_trans(
network = network,
sender = sender, receiver = receiver, replace = replace,
cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# cycle -------------------------------------------------------------------
init_REM_choice.cycle <- function(effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.cycle(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_cycle <- function(
network,
sender,
receiver,
replace, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_cycle(
network = network,
sender = sender, receiver = receiver, replace = replace,
cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# common receiver ---------------------------------------------------------
init_REM_choice.commonReceiver <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.commonReceiver(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_commonReceiver <- function(
network,
sender,
receiver,
replace, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_commonReceiver(
network = network,
sender = sender, receiver = receiver, replace = replace,
cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# common sender -----------------------------------------------------------
init_REM_choice.commonSender <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.commonSender(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_commonSender <- function(
network,
sender,
receiver,
replace, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_commonSender(
network = network,
sender = sender, receiver = receiver, replace = replace,
cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# mixedTrans --------------------------------------------------------------
init_REM_choice.mixedTrans <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.mixedTrans(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_mixedTrans <- function(
network,
sender,
receiver,
replace, netUpdate, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_mixedTrans(
network = network,
sender = sender, receiver = receiver, replace = replace,
netUpdate = netUpdate, cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# mixedCycle --------------------------------------------------------------
init_REM_choice.mixedCycle <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.mixedCycle(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_mixedCycle <- function(
network,
sender,
receiver,
replace, netUpdate, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_mixedCycle(
network = network,
sender = sender, receiver = receiver, replace = replace,
netUpdate = netUpdate, cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# mixed common receiver ---------------------------------------------------
init_REM_choice.mixedCommonReceiver <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.mixedCommonReceiver(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_mixedCommonReceiver <- function(
network,
sender,
receiver,
replace, netUpdate, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_mixedCommonReceiver(
network = network,
sender = sender, receiver = receiver, replace = replace,
netUpdate = netUpdate, cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# mixed common sender -----------------------------------------------------
init_REM_choice.mixedCommonSender <- function(
effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.mixedCommonSender(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_mixedCommonSender <- function(
network,
sender,
receiver,
replace, netUpdate, cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_mixedCommonSender(
network = network,
sender = sender, receiver = receiver, replace = replace,
netUpdate = netUpdate, cache = cache,
isTwoMode = isTwoMode, transformFun = transformFun
)
}
# four --------------------------------------------------------------------
init_REM_choice.four <- function(effectFun, network, window, n1, n2, ...) {
init_DyNAM_choice.four(
effectFun = effectFun, network = network,
window = window,
n1 = n1, n2 = n2, ...
)
}
update_REM_choice_four <- function(
network,
sender, receiver, replace,
cache,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_four(
network = network,
sender = sender, receiver = receiver, replace = replace,
cache = cache,
isTwoMode = isTwoMode,
transformFun = transformFun
)
}
# tertius ----------------------------------------------------------------
#' init stat matrix tertius using cache
#'
#' @param effectFun function with additional parameters transformFun,
#' aggregateFun
#' @param network matrix n1*n2
#' @param attribute numeric vector n1
#' @param window NULL|numeric size of the window
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#'
#' @return list
#' cache numeric vector n1
#' stat matrix numeric n1*n2
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' attribute <- c(1, 0, 1, 3, 1)
#' effectFUN <- function(
#' type = "alter", isTwoMode = TRUE,
#' transformFun = abs, aggregateFun = function(x) median(x, na.rm = TRUE)) {
#' NULL
#' }
#' init_REM_choice.tertius(effectFUN, network, attribute)
#' }
init_REM_choice.tertius <- function(
effectFun, network, attribute, window, n1, n2, ...) {
# Get arguments
params <- formals(effectFun)
aggFun <- eval(params[["aggregateFun"]])
funApply <- eval(params[["transformFun"]]) # applied FUN instead
isTwoMode <- eval(params[["isTwoMode"]])
type <- eval(params[["type"]])
if (isTwoMode && type == "ego") {
stop("'tertius' effect must not use for type 'ego' (type = 'ego') when is ",
"a two-mode network (isTwoMode = TRUE) ",
call. = FALSE
)
}
# if (anyNA(network)) network[is.na(network)] <- 0
# has window or is empty initialize empty
if ((!is.null(window) && !is.infinite(window)) || all(network == 0)) {
return(list(
cache = numeric(n2),
stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2)
))
}
# always weighted
network <- sign(unname(network))
# compute cache[j]: agg_{k \in N^-(j)}(z_k) || NA if N^-(j) == \empty
cache <- apply(
X = network, MARGIN = 2,
FUN = function(x) {
# # inNeighbor of j
inReceiver <- which(x == 1)
# # not aggregated if not inNeighbor(j)
if (length(inReceiver) == 0) {
return(NA_real_)
}
# # apply aggFun to inNeighbor(j)
forceAndCall(1, aggFun, attribute[inReceiver])
}
)
# applied transformFun
stat <- forceAndCall(1, funApply, cache)
# impute missing values by the average
if (anyNA(stat)) {
imputeVal <- mean(stat, na.rm = TRUE)
stat[is.na(stat)] <- imputeVal
}
# return expected n1 * n2 matrix
# update check that type should be one of "alter" or "ego"
byRow <- type == "alter"
stat <- matrix(stat, nrow = n1, ncol = n2, byrow = byRow)
#
if (!isTwoMode) diag(stat) <- 0
return(list(cache = cache, stat = stat))
}
#' update stat tertius using cache
#'
#' @param network matrix n1*n1
#' @param attribute numeric vector n1
#' @param sender integer||NULL if node is not NULL
#' @param receiver integer||NULL if node is not NULL
#' @param node integer||NULL if sender and receiver are not NULL
#' @param replace numeric
#' @param cache numeric vector n1
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#' @param transformFun function to apply to the difference
#' @param aggregateFun function usa to aggregate in-neighbors attributes
#'
#' @return list:
#' cache numeric vector size n1
#' changes NULL || array cbind(node1 = x, node2 = y, replace = z) stat updates
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' attribute <- c(1, 0, 1, 3, 1)
#' cache <- c(2, 1, 0, 1, 0, 2)
#'
#' update_REM_choice_tertius(network, attribute,
#' sender = 2, receiver = 3,
#' node = NULL,
#' 3,
#' cache,
#' n1 = 5, n2 = 6,
#' transformFun = function(x) x^2,
#' aggregateFun = function(x) median(x, na.rm = TRUE)
#' )
#'
#' update_REM_choice_tertius(network, attribute,
#' sender = NULL, receiver = NULL,
#' node = 3,
#' 3,
#' cache,
#' n1 = 5, n2 = 6,
#' transformFun = function(x) x^2,
#' aggregateFun = function(x) median(x, na.rm = TRUE)
#' )
#' }
update_REM_choice_tertius <- function(
network,
attribute,
sender = NULL,
receiver = NULL,
node = NULL,
replace,
cache,
n1 = n1, n2 = n2,
isTwoMode = FALSE,
type = c("alter", "ego"),
transformFun = identity,
aggregateFun = function(x) mean(x, na.rm = TRUE)) {
type <- match.arg(type)
# utility functions to return third nodes
third <- function(n, diff = c(node)) {
setdiff(seq_len(n), diff)
}
# init with empty network
isEmpty <- all(cache == 0)
isImpute <- anyNA(cache)
# init res
res <- list(cache = NULL, changes = NULL)
# case 1: an update in the network[sende, receiver] <- replace
if (is.null(node) && !is.null(sender) && !is.null(receiver)) {
# get old value, always weighted
replace <- sign(replace)
oldValue <- sign(network[sender, receiver])
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(oldValue)) oldValue <- 0
if (is.na(replace)) replace <- 0
newValue <- replace - oldValue
if (newValue == 1) {
# get all in-neighbors of receiver k->j, consider also sender
inReceiver <- c(which(network[, receiver] > 0), sender)
} else {
# delete the k -> j tie, not consider sender
inReceiver <- setdiff(which(network[, receiver] > 0), sender)
}
# change stat
valChangeCache <- forceAndCall(
1, aggregateFun,
if (length(inReceiver) > 0) attribute[inReceiver] else NA
)
# changes case 1: all nodes needs to be update the att[i] - cache[j] values
# if (isTwoMode) seq_len(n2) else third(n1, receiver)
nodesChange <- if (!is.na(valChangeCache)) receiver else numeric()
isImpute <- ifelse(!isImpute && is.na(valChangeCache), TRUE, isImpute)
cache[receiver] <- valChangeCache
}
# case 2: an update in the attribute[node] <- replace
if (!is.null(node) && is.null(sender) && is.null(receiver)) {
# Get old value
oldValue <- attribute[node]
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(replace)) replace <- mean(attribute[-node], na.rm = TRUE)
# get all out-neighbors of node k->j
outNode <- which(network[node, ] > 0)
cache[outNode] <-
vapply(
X = outNode,
FUN = function(x) {
# # inNeighbor of outNode, excluding Node because has a new value
inReceiver <- setdiff(which(network[, x] > 0), node)
# # apply aggFun to inNeighbor(outNode)
forceAndCall(1, aggregateFun, c(attribute[inReceiver], replace))
},
FUN.VALUE = double(1)
)
# changes case 2: is an update value for node,
# then its update is done separately
nodesChange <- outNode
}
# changes depending isTwoMode
if (type == "alter") {
# when the cache had change
changes <- Reduce(
rbind,
lapply(
nodesChange,
\(x) {
cbind(
node1 = if (isTwoMode) seq_len(n1) else third(n1, x),
node2 = x,
replace = forceAndCall(1, transformFun, cache[x])
)
}
)
)
} else if (type == "ego") {
# when the cache had change
changes <- Reduce(
rbind,
lapply(
nodesChange,
\(x) {
cbind(
node1 = x,
node2 = if (isTwoMode) seq_len(n1) else third(n1, x),
replace = forceAndCall(1, transformFun, cache[x])
)
}
)
)
}
# when is just initialize it need to change all values to the average
if (isEmpty || isImpute) {
toImpute <- which(is.na(cache))
imputeVal <- mean(cache, na.rm = TRUE)
# changes depending isTwoMode
if (type == "alter") {
#
changes <- rbind(
changes,
Reduce(
rbind,
lapply(
toImpute,
\(x) {
cbind(
node1 = if (isTwoMode) seq_len(n1) else third(n1, x),
node2 = x,
replace = forceAndCall(1, transformFun, imputeVal)
)
}
)
)
)
} else if (type == "ego") {
#
changes <- rbind(
changes,
Reduce(
rbind,
lapply(
toImpute,
\(x) {
cbind(
node1 = x,
node2 = if (isTwoMode) seq_len(n1) else third(n1, x),
replace = forceAndCall(1, transformFun, imputeVal)
)
}
)
)
)
}
}
return(list(cache = cache, changes = changes))
}
# tertiusDiff ----------------------------------------------------------------
#' init stat matrix tertius-diff using cache
#'
#' @param effectFun function with additional parameters transformFun,
#' aggregateFun
#' @param network matrix n1*n2
#' @param attribute numeric vector n1
#' @param window NULL|numeric size of the window
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#'
#' @return list
#' cache numeric vector n1
#' stat matrix numeric n1*n2
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' attribute <- c(1, 0, 1, 3, 1)
#' effectFUN <- function(transformFun = abs,
#' aggregateFun = function(x) median(x, na.rm = TRUE)) {
#' NULL
#' }
#' init_REM_choice.tertiusDiff(effectFUN, network, attribute)
#' }
init_REM_choice.tertiusDiff <- function(
effectFun, network, attribute, window, n1, n2, ...) {
init_DyNAM_choice.tertiusDiff(
effectFun = effectFun,
network = network, attribute = attribute,
window = window,
n1 = n1, n2 = n2
)
}
#' update stat transitivity using cache
#'
#' @param network matrix n1*n1
#' @param attribute numeric vector n1
#' @param sender integer||NULL if node is not NULL
#' @param receiver integer||NULL if node is not NULL
#' @param node integer||NULL if sender and receiver are not NULL
#' @param replace numeric
#' @param cache numeric vector n1
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#' @param transformFun function to apply to the difference
#' @param aggregateFun function usa to aggregate in-neighbors attributes
#'
#' @return list:
#' cache numeric vector size n1
#' changes NULL || array cbind(node1 = x, node2 = y, replace = z) stat updates
#' @noRd
#'
#' @examples
#' \donttest{
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0, 0,
#' 0, 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 0, 3,
#' 1, 0, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0, 0
#' ),
#' nrow = 5, ncol = 6, byrow = TRUE
#' )
#' attribute <- c(1, 0, 1, 3, 1)
#' cache <- c(2, 1, 0, 1, 0, 2)
#'
#' update_REM_choice_tertiusDiff(
#' network, attribute,
#' sender = 2, receiver = 3,
#' node = NULL,
#' 3,
#' cache,
#' n1 = 5, n2 = 6,
#' transformFun = function(x) x^2,
#' aggregateFun = function(x) median(x, na.rm = TRUE)
#' )
#'
#' update_REM_choice_tertiusDiff(
#' network, attribute,
#' sender = NULL, receiver = NULL,
#' node = 3,
#' 3,
#' cache,
#' n1 = 5, n2 = 6,
#' transformFun = function(x) x^2,
#' aggregateFun = function(x) median(x, na.rm = TRUE)
#' )
#' }
update_REM_choice_tertiusDiff <- function(
network,
attribute,
sender = NULL,
receiver = NULL,
node = NULL,
replace,
cache,
isTwoMode = FALSE,
n1 = n1, n2 = n2,
transformFun = abs,
aggregateFun = function(x) mean(x, na.rm = TRUE)) {
update_DyNAM_choice_tertiusDiff(
network = network,
attribute = attribute,
sender = sender,
receiver = receiver,
node = node,
replace = replace,
cache = cache,
isTwoMode = isTwoMode,
n1 = n1, n2 = n2,
transformFun = transformFun,
aggregateFun = aggregateFun
)
}
# nodeTrans ------------------------------------------------------------------
#' node trans init
#' number of transitive triangles i->j->k;i->k where node i is embedded.
#' Source node
#' @param effectFun function with additional parameters isTwoMode, transformFun,
#' type, etc.
#' @param network matrix n1*n2
#' @param window NULL|numeric size of the window
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#'
#' @return list with named components: cache numeric vector size n2,
#' stat matrix numeric n1*n2
#' @noRd
#'
#' @examples
#' \donttest{
#'
#' network <- matrix(
#' c(
#' 0, 0, 0, 1, 0,
#' 0, 0, 0, 0, 0,
#' 0, 2, 0, 0, 3,
#' 1, 0, 0, 0, 4,
#' 1, 2, 0, 0, 0
#' ),
#' nrow = 5, ncol = 5, byrow = TRUE
#' )
#' effectFUN <- function(
#' isTwoMode = TRUE, transformFun = identity, type = "ego") {
#' NULL
#' }
#' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5)
#'
#' effectFUN <- function(
#' isTwoMode = FALSE, transformFun = identity, type = "ego") {
#' NULL
#' }
#' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5)
#'
#' effectFUN <- function(
#' isTwoMode = FALSE, transformFun = identity, type = "alter") {
#' NULL
#' }
#' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5)
#'
#' effectFUN <- function(
#' isTwoMode = FALSE, transformFun = identity, type = "alter") {
#' NULL
#' }
#' init_REM_choice.nodeTrans(effectFUN, network, 9, 5, 5)
#' }
init_REM_choice.nodeTrans <- function(effectFun, network, window, n1, n2, ...) {
# Get arguments
params <- formals(effectFun)
isTwoMode <- eval(params[["isTwoMode"]])
funApply <- eval(params[["transformFun"]])
type <- eval(params[["type"]])
if (isTwoMode) {
stop("'nodeTrans' effect must not use ",
"when is a two-mode network (isTwoMode = TRUE)",
call. = FALSE
)
}
# has window or is empty initialize empty
if ((!is.null(window) && !is.infinite(window)) || all(network == 0)) {
return(list(
cache = numeric(n1),
stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2)
))
}
# always weighted
network <- sign(network)
# compute stat: number of triangles i->j->k, i->k from i perspective
# stat <- diag(tcrossprod(network %*% network, network))
cache <- .rowSums((network %*% network) * network,
m = n1, n = n2,
na.rm = TRUE
)
stat <- matrix(forceAndCall(1, funApply, cache),
nrow = n1, ncol = n2, byrow = (type == "alter")
)
# if (!isTwoMode)
diag(stat) <- 0
return(list(cache = cache, stat = stat))
}
#' update node trans
#' number of transitive triangles i->j->k;i->k where node i is embedded as
#' a source node
#' @param network matrix n1*n2
#' @param sender integer
#' @param receiver integer
#' @param replace numeric
#' @param cache numeric vector size n1
#' @param n1 integer nrow(network)
#' @param n2 integer ncol(network)
#' @param isTwoMode logical
#' @param transformFun function to apply to the stat
#' @param type character should be 'alter' or 'ego' type
#'
#' @return list:
#' cache numeric vector size n2,
#' changes NULL || array cbind(node1 = x, node2 = y, replace = z) stat updates
#' @noRd
#'
#' @examples
#' \donttest{
#' cache <- c(0, 0, 1, 1, 0)
#' update_REM_choice_nodeTrans(network, 1, 5, 1, cache, 5, 5, type = "alter")
#' update_REM_choice_nodeTrans(network, 1, 5, 1, cache, 5, 5, type = "ego")
#' update_REM_choice_nodeTrans(network, 3, 2, 0, cache, 5, 5, type = "ego")
#' }
update_REM_choice_nodeTrans <- function(
network,
sender,
receiver,
replace,
cache,
n1, n2,
isTwoMode = FALSE,
transformFun = identity,
type = c("alter", "ego")) {
type <- match.arg(type)
res <- list(cache = NULL, changes = NULL)
# only relevant for one-mode networks
if (sender == receiver) {
return(res)
}
# get old value, always weighted
replace <- sign(replace)
oldValue <- sign(network[sender, receiver])
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(oldValue)) oldValue <- 0
if (is.na(replace)) replace <- 0
third <- function(n, diff) {
setdiff(seq_len(n), diff)
}
# compute neighbourhoods for sender and receivers,
# (i = sender, j = receiver)
outNeighSender <- which(network[sender, ] > 0) # N^+(i)
inNeighReceiver <- which(network[, receiver] > 0) # N^-(j)
# commonReceivers = k: i->j & i->k & j->k => trans(i) += 1
commonReceivers <- intersect(
outNeighSender,
which(network[receiver, ] > 0)
) # N^+(i) \cap N^+(j)
# commonSenders = l: l->i & l->j & i->j => trans(l) += 1
commonSenders <- intersect(
which(network[, sender] > 0),
inNeighReceiver
) # N^-(i) \cap N^-(j)
# brokers = b: i->b & b->j & i->j => trans(i) += 1
brokers <- intersect(outNeighSender, inNeighReceiver) # N^+(i) \cap N^-(j)
senderChanges <- length(commonReceivers) + length(brokers) # trans(i) += 1
changes <- NULL
if (senderChanges > 0) {
replaceValues <- (replace - oldValue) * senderChanges + cache[sender]
if (type == "ego") {
changes <- cbind(
node1 = sender, node2 = third(n1, sender), replace = replaceValues
)
} else {
changes <- cbind(
node1 = third(n1, sender), node2 = sender, replace = replaceValues
)
}
cache[sender] <- replaceValues
}
if (length(commonSenders) > 0) {
replaceValues <- (replace - oldValue) + cache[commonSenders]
changes <- rbind(
changes,
Reduce(
rbind,
lapply(
seq_along(commonSenders),
\(x) {
if (type == "ego") {
cbind(
node1 = commonSenders[x],
node2 = third(n1, commonSenders[x]),
replace = replaceValues[x]
)
} else {
cbind(
node1 = third(n1, commonSenders[x]),
node2 = commonSenders[x],
replace = replaceValues[x]
)
}
}
)
)
)
cache[commonSenders] <- replaceValues
}
if (!is.null(changes)) {
changes[, "replace"] <- forceAndCall(1, transformFun, changes[, "replace"])
# res$changes <- changes
}
return(list(cache = cache, changes = changes))
}
# Covariate effects -------------------------------------------------------
# ego ---------------------------------------------------------------------
init_REM_choice.ego <- function(effectFun, attribute, n1, n2, ...) {
# Get arguments
params <- formals(effectFun)
isTwoMode <- eval(params[["isTwoMode"]])
# compute stat
stats <- matrix(attribute, nrow = n1, ncol = n2, byrow = FALSE)
if (!isTwoMode) diag(stats) <- 0
return(list(stat = stats))
}
update_REM_choice_ego <- function(
attribute,
node, replace,
n1, n2,
isTwoMode = FALSE) {
res <- list(changes = NULL)
# Get old value
oldValue <- attribute[node]
# Check if old value has changed
if (is.na(oldValue) && is.na(replace)) {
return(res)
} else if (!is.na(oldValue) && !is.na(replace) && oldValue == replace) {
return(res)
}
if (is.na(replace)) replace <- mean(attribute[-node], na.rm = TRUE)
# utility functions to return third nodes
third <- function(n, diff = c(node)) {
setdiff(seq_len(n), diff)
}
if (!isTwoMode) nodesChange <- third(n1, node) else nodesChange <- seq_len(n2)
# change stat
res$changes <- cbind(node1 = node, node2 = nodesChange, replace = replace)
return(res)
}
# alter -------------------------------------------------------------------
init_REM_choice.alter <- function(effectFun, attribute, n1, n2, ...) {
init_DyNAM_choice.alter(
effectFun = effectFun, attribute = attribute, n1 = n2, n2 = n2, ...
)
}
update_REM_choice_alter <- function(
attribute,
node, replace,
n1, n2,
isTwoMode = FALSE) {
update_DyNAM_choice_alter(
attribute = attribute,
node = node, replace = replace,
n1 = n1, n2 = n2,
isTwoMode = isTwoMode
)
}
# same --------------------------------------------------------------------
init_REM_choice.same <- function(effectFun, attribute, ...) {
init_DyNAM_choice.same(effectFun = effectFun, attribute = attribute, ...)
}
update_REM_choice_same <- function(
attribute,
node, replace,
isTwoMode = FALSE) {
update_DyNAM_choice_same(
attribute = attribute,
node = node, replace = replace,
isTwoMode = isTwoMode
)
}
# diff --------------------------------------------------------------------
init_REM_choice.diff <- function(effectFun, attribute, ...) {
init_DyNAM_choice.diff(effectFun = effectFun, attribute = attribute, ...)
}
update_REM_choice_diff <- function(
attribute, node, replace,
n1, n2,
isTwoMode = FALSE,
transformFun = abs) {
update_DyNAM_choice_diff(
attribute = attribute,
node = node, replace = replace,
isTwoMode = isTwoMode,
n1 = n1, n2 = n2,
transformFun = transformFun
)
}
# sim ---------------------------------------------------------------------
init_REM_choice.sim <- function(effectFun, attribute, ...) {
init_DyNAM_choice.sim(effectFun = effectFun, attribute = attribute, ...)
}
update_REM_choice_sim <- function(
attribute, node, replace,
n1, n2,
isTwoMode = FALSE,
transformFun = abs) {
update_DyNAM_choice_sim(
attribute = attribute,
node = node, replace = replace,
n1 = n1, n2 = n2,
isTwoMode = isTwoMode,
transformFun = transformFun
)
}
# ego alter interaction ---------------------------------------------------
init_REM_choice.egoAlterInt <- function(effectFun, attribute, ...) {
init_DyNAM_choice.sim(effectFun = effectFun, attribute = attribute, ...)
}
update_REM_choice_egoAlterInt <- function(
attribute, node, replace,
attUpdate,
n1, n2,
isTwoMode = FALSE,
transformFun = identity) {
update_DyNAM_choice_egoAlterInt(
attribute = attribute,
node = node, replace = replace,
attUpdate = attUpdate,
n1 = n1, n2 = n2,
isTwoMode = isTwoMode,
transformFun = transformFun
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.