Nothing
##################### ###
#
# Goldfish package
# Some utility functions useful in
# various parts of the code
#
##################### ###
#' get data objects
#'
#' @param namedList list
#' @param keepOrder logical.
#' @param removeFirst logical.
#'
#' @return a
#' @noRd
#'
#' @examples
#' \donttest{
#' data("Social_Evolution")
#' callNetwork <- defineNetwork(nodes = actors, directed = TRUE)
#' callNetwork <- linkEvents(
#' x = callNetwork, changeEvent = calls, nodes = actors
#' )
#' callsDependent <- defineDependentEvents(
#' events = calls, nodes = actors, defaultNetwork = callNetwork
#' )
#' parsedformula <- parseFormula(callsDependent ~ ego(actors$floor))
#' objectsEffectsLink <- getObjectsEffectsLink(parsedformula$rhsNames, 1L)
#' getDataObjects(list(rownames(objectsEffectsLink)), removeFirst = FALSE)
#' }
getDataObjects <- function(namedList, keepOrder = FALSE, removeFirst = TRUE) {
# strip function names
objNames <- unlist(namedList)
if (removeFirst) objNames <- unlist(lapply(namedList, "[", -1))
# strip named parameters except for reserved ones
if (!is.null(names(objNames))) {
ids <- isReservedElementName(names(objNames)) | names(objNames) == ""
objNames <- objNames[ids]
}
if (!keepOrder) objNames <- unique(objNames)
# # case list(...)
areList <- grepl("list\\(\\s*(.+)\\s*\\)", objNames)
.split <- ifelse(areList,
gsub("list\\(\\s*(.+)\\s*\\)", "\\1", objNames),
objNames
)
.split <- unlist(strsplit(.split, split = "\\s*,\\s*"))
if (!keepOrder) .split <- unique(.split)
# # case attributes
split <- strsplit(.split, split = "$", fixed = TRUE)
objNameTable <- Reduce(
rbind,
lapply(
split,
\(v) {
if (length(v) == 1) {
data.frame(
object = v,
nodeset = NA,
attribute = NA,
stringsAsFactors = FALSE
)
} else {
data.frame(
object = NA,
nodeset = v[1],
attribute = v[2],
stringsAsFactors = FALSE
)
}
}
)
)
return(cbind(name = .split, objNameTable, stringsAsFactors = FALSE))
}
getElementFromDataObjectTable <- function(x, envir = environment()) {
elements <- list()
if (nrow(x) == 0) {
return(elements)
}
for (i in seq_len(nrow(x))) {
elements[[i]] <- NA
row <- x[i, ]
if (!is.na(row$object)) {
elements[[i]] <- get(row$object, envir = envir)
}
if (!is.na(row$nodeset) && !is.na(row$attribute)) {
elements[[i]] <- getElement(
get(row$nodeset, envir = envir),
row$attribute
)
}
}
return(elements)
}
# Check whether (date) input is of POSIXct format
# currently not needed in parseTimeWindows because
# POSIXct doesn't have duration names and
# we don't want to have any unnecessary package dependencies.
# We keep this utility function however,
# as it may be useful elsewhere...
# is.POSIXct <- function(x) inherits(x, "POSIXct")
isReservedElementName <- function(x) {
x %in% c("network", "attribute", "network2", "attribute2")
}
#' Sanitize events
#'
#' replace labels with IDs and specific time formats with numeric
#'
#' @param events a dataframe that represents a valid events list
#' @inheritParams linkEvents
#'
#' @return a data frame with IDs instead of labels and time in numeric format
#' @noRd
#'
#' @examples
#' \donttest{
#' data("Social_Evolution")
#' afterSanitize <- sanitizeEvents(calls, "actors")
#' }
sanitizeEvents <- function(events, nodes, nodes2 = nodes, envir = new.env()) {
if (is.character(nodes)) nodes <- get(nodes, envir = envir)
if (is.character(nodes2)) nodes2 <- get(nodes2, envir = envir)
if (is.character(events$node)) {
events$node <- match(events$node, nodes$label)
}
if (is.character(events$sender)) {
events$sender <- match(events$sender, nodes$label)
}
if (is.character(events$receiver)) {
events$receiver <- match(events$receiver, nodes2$label)
}
events$time <- as.numeric(events$time)
events
}
#' Reduce preprocess output
#'
#' It took a preprocess object and return a matrix with all the
#' change statistics together for each effect.
#' `effectPos` argument allows to reduce just for a subset of effects,
#' it won't reduce the time or memory space used.
#'
#' @param preproData a preprocess data object from preprocess.
#' @param type a character. `"withTime"` returns the dependent stats changes
#' with the time where they occur.
#' @param effectPos a vector of integers of the effects to keep.
#'
#' @return a list with a matrix for each effect.
#' @noRd
#'
#' @examples
#' \donttest{
#' data("Social_Evolution")
#' callNetwork <- defineNetwork(nodes = actors, directed = T)
#' callNetwork <- linkEvents(
#' x = callNetwork, changeEvent = calls, nodes = actors
#' )
#' callsDependent <- defineDependentEvents(
#' events = calls, nodes = actors, defaultNetwork = callNetwork
#' )
#' prep <- estimate(callsDependent ~ inertia + trans,
#' model = "DyNAM", subModel = "choice",
#' preprocessingOnly = TRUE, silent = TRUE
#' )
#' v00 <- ReducePreprocess(prep, "withTime")
#' v01 <- ReducePreprocess(prep, "withTime", c(1L, 3L))
#' v03 <- ReducePreprocess(prep, "withoutTime")
#' }
ReducePreprocess <- function(
preproData,
type = c("withTime", "withoutTime"),
effectPos = NULL) {
stopifnot(
is.null(effectPos) || !is.null(effectPos) && inherits(effectPos, "integer")
)
type <- match.arg(type)
nEffects <- dim(preproData$initialStats)[3]
stopifnot(
is.null(effectPos) || !is.null(effectPos) && max(effectPos) <= nEffects
)
ReduceEffUpdates <- function(statsChange, eventTime) {
reduce <- Map(
\(x, y) {
lapply(
x,
\(z) {
if (is.null(z)) {
return(NULL)
} # no changes, no problem
if (nrow(z) == 1) {
return(
if (type == "withTime") cbind(time = y, z) else z
)
} # just one update, no problem
discard <- duplicated(z[, c("node1", "node2")], fromLast = TRUE)
changes <- cbind(
time = if (type == "withTime") rep(y, sum(!discard)) else NULL,
z[!discard, , drop = FALSE]
)
if (nrow(changes) == 1) {
return(changes)
}
# print(changes)
changes <- changes[order(changes[, "node1"], changes[, "node2"]), ]
}
) # multiple updates might be repeated, keep the last
},
statsChange, eventTime
)
return(lapply(
seq_len(nEffects),
function(i) {
Reduce(rbind, lapply(reduce, "[[", i))
}
))
}
outDependentStatChange <- ReduceEffUpdates(
preproData$dependentStatsChange,
preproData$eventTime[preproData$orderEvents == 1]
)
if ((preproData$subModel == "rate" || preproData$model == "REM") &&
length(preproData$rightCensoredStatsChange) > 0) {
rightCensoredStatChange <- ReduceEffUpdates(
preproData$rightCensoredStatsChange,
preproData$eventTime[preproData$orderEvents == 2]
)
# combine lists
reducedPrepro <- list()
for (ii in seq.int(length(outDependentStatChange))) {
reducedPrepro[[ii]] <- list(
dependent = outDependentStatChange[[ii]],
rightCensored = rightCensoredStatChange[[ii]]
)
}
if (!is.null(effectPos)) {
return(reducedPrepro[effectPos])
} else {
return(reducedPrepro)
}
} else if (!is.null(effectPos)) {
return(outDependentStatChange[effectPos])
} else {
return(outDependentStatChange)
}
}
#' Expand a set of changes
#'
#' given a `node` and a `replace` value, set the change to all the nodes in
#' the nodes `set`. Add the `time` to the array if provided.
#'
#' @param nodes a numeric vector with the sanitize position of the nodes
#' @param replace a numeric vector with the replace value
#' @param time a numeric vector with the time-stamp when the changes happen
#' @param set a numeric vector with the index id of the node set
#' @param isTwoMode logical, whether self ties are allow or not
#'
#' @return an array with columns `node1`, `node2`, `replace` and `time`
#' @noRd
#'
#' @examples
#' fillChanges(c(1, 3), c(4, 8), NULL, 1:5)
fillChanges <- function(nodes, replace, time, set, isTwoMode = FALSE) {
times <- ifelse(isTwoMode, length(set), length(set) - 1)
cbind(
time = if (!is.null(time)) rep(time, each = times) else NULL,
node1 = rep(nodes, each = times),
node2 = Reduce(c, lapply(nodes, \(x) set[!set %in% x])),
replace = rep(replace, each = times)
)
}
#' update a network (adjacency matrix)
#'
#' @param network a network (adjacency matrix) to update with an event list.
#' @inheritParams linkEvents
#'
#' @return a network (adjacency matrix) after update events from changeEvents
#' @noRd
#'
#' @examples
#' \donttest{
#' data("Social_Evolution")
#' callNetwork <- defineNetwork(nodes = actors, directed = TRUE)
#' callNetwork <- linkEvents(
#' x = callNetwork, changeEvent = calls, nodes = actors
#' )
#' callsDependent <- defineDependentEvents(
#' events = calls, nodes = actors, defaultNetwork = callNetwork
#' )
#' prep <- estimate(callsDependent ~ inertia + trans,
#' model = "DyNAM", subModel = "choice",
#' preprocessingOnly = TRUE, silent = TRUE
#' )
#' finalNet <- UpdateNetwork(callNetwork, calls, nodes = "actors")
#' finalStat <- UpdateNetwork(
#' prep$initialStats[, , 1], ReducePreprocess(prep, "withoutTime", 1L)[[1]]
#' )
#' }
UpdateNetwork <- function(network, changeEvents, nodes = NULL, nodes2 = nodes) {
stopifnot(
inherits(network, "matrix"),
inherits(changeEvents, "data.frame") || inherits(changeEvents, "matrix")
)
if (!is.null(nodes)) {
changeEvents <- sanitizeEvents(changeEvents, nodes, nodes2)
}
if (inherits(changeEvents, "matrix") &&
all(c("node1", "node2", "replace") %in% colnames(changeEvents))) {
changeEvents <- data.frame(changeEvents)
names(changeEvents)[match(c("node1", "node2"), names(changeEvents))] <-
c("sender", "receiver")
} else if (!all(c("sender", "receiver") %in% names(changeEvents))) {
stop("Expected changeEvents with either c('sender', 'receiver') or ")
}
if ("time" %in% names(changeEvents)) {
changeEvents$time <- NULL
}
# include additional checks
if ("increment" %in% names(changeEvents)) {
if (any(network[!is.na(network)] != 0)) {
posNE <- which(!is.na(network) & network != 0, arr.ind = TRUE)
# print(str(posNE))
changeEvents <- rbind(
changeEvents,
data.frame(
sender = posNE[, 1],
receiver = posNE[, 2],
increment = network[posNE]
)
)
}
redEvents <- stats::aggregate(
increment ~ sender + receiver, changeEvents, sum
)
chIncrement <- match("increment", names(redEvents))
names(redEvents)[chIncrement] <- "replace"
} else if ("replace" %in% names(changeEvents)) {
discard <- duplicated(changeEvents[, c("sender", "receiver")],
fromLast = TRUE
)
redEvents <- changeEvents[
!discard,
c("sender", "receiver", "replace"),
drop = FALSE
]
}
network[cbind(redEvents$sender, redEvents$receiver)] <- redEvents$replace
return(network)
}
GetDetailPrint <- function(
objectsEffectsLink,
parsedformula,
fixedParameters = NULL) {
# matrix with the effects in rows and objects in columns,
# which net or actor att
maxObjs <- max(objectsEffectsLink, na.rm = TRUE)
effectDescription <- matrix(
t(
apply(
objectsEffectsLink, 2,
function(x) {
notNA <- !is.na(x)
objs <- x[notNA]
objs <- names(objs[order(objs)])
c(objs, rep("", maxObjs - length(objs)))
}
)
),
nrow = ncol(objectsEffectsLink),
ncol = maxObjs
)
# # handle degenerate case one effect one object
dimnames(effectDescription) <- list(
colnames(objectsEffectsLink),
if (ncol(effectDescription) == 1) {
"Object"
} else {
sprintf("Object %d", seq_len(ncol(effectDescription)))
}
)
objectsName <- colnames(effectDescription)
# adding other parameters: each effect refers to which network
# or actor attribute
# effectDescription <- cbind(
# effect = rownames(effectDescription),
# effectDescription
# )
if (any(unlist(parsedformula$ignoreRepParameter))) {
effectDescription <- cbind(effectDescription,
ignoreRep = ifelse(parsedformula$ignoreRepParameter, "B", "")
)
}
if (any(unlist(parsedformula$weightedParameter))) {
effectDescription <- cbind(effectDescription,
weighted = ifelse(parsedformula$weightedParameter, "W", "")
)
}
if (any(parsedformula$typeParameter != "")) {
effectDescription <- cbind(effectDescription,
type = parsedformula$typeParameter
)
}
hasWindows <- FALSE
if (!all(vapply(parsedformula$windowParameters, is.null, logical(1)))) {
hasWindows <- TRUE
effectDescription <- cbind(
effectDescription,
window = vapply(
parsedformula$windowParameters,
function(x) ifelse(is.null(x), "", gsub("['\"]", "", x)),
character(1)
)
)
# reduce object name
effectDescription[, objectsName] <- t(apply(
effectDescription,
1,
\(x) {
gsub(
paste0("^(.+)_", gsub(" ", "", x["window"]), "$"),
"\\1",
x[objectsName]
)
}
))
}
if (any(parsedformula$transParameter != "")) {
effectDescription <- cbind(effectDescription,
transformFun = parsedformula$transParameter
)
}
if (any(parsedformula$aggreParameter != "")) {
effectDescription <- cbind(effectDescription,
aggregateFun = parsedformula$aggreParameter
)
}
# DyNAMi
if (any(parsedformula$joiningParameter != "")) {
effectDescription <- cbind(effectDescription,
joining = parsedformula$joiningParameter
)
}
if (any(parsedformula$subTypeParameter != "")) {
effectDescription <- cbind(effectDescription,
subType = parsedformula$subTypeParameter
)
}
# rownames(effectDescription) <- NULL
if (parsedformula$hasIntercept) {
effectDescription <- rbind("", effectDescription)
rownames(effectDescription)[1] <- "Intercept"
}
if (!is.null(fixedParameters)) {
effectDescription <- cbind(effectDescription,
fixed = !is.na(fixedParameters)
)
}
attr(effectDescription, "hasWindows") <- hasWindows
return(effectDescription)
}
GetFixed <- function(object) {
if ("fixed" %in% colnames(object$names)) {
vapply(
object$names[, "fixed"],
function(x) eval(parse(text = x)),
logical(1)
)
} else {
rep(FALSE, length(object$parameters))
}
}
checkArgsEstimation <- function(variables) {
}
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.