From 9303d18d41a99bb1638b27da9fbd9369fc747822 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 22 Jun 2022 18:10:41 +0200 Subject: [PATCH 01/36] Add initial simulation code and lifecycle dependency --- DESCRIPTION | 4 +- NAMESPACE | 3 + R/functions_estimation.R | 1 - R/functions_simulation.R | 191 +++++++++++++ R/functions_simulation_engine.R | 359 +++++++++++++++++++++++++ R/goldfish-package.R | 54 ++-- man/figures/lifecycle-archived.svg | 1 + man/figures/lifecycle-defunct.svg | 1 + man/figures/lifecycle-deprecated.svg | 1 + man/figures/lifecycle-experimental.svg | 1 + man/figures/lifecycle-maturing.svg | 1 + man/figures/lifecycle-questioning.svg | 1 + man/figures/lifecycle-stable.svg | 1 + man/figures/lifecycle-superseded.svg | 1 + 14 files changed, 589 insertions(+), 31 deletions(-) create mode 100644 R/functions_simulation.R create mode 100644 R/functions_simulation_engine.R create mode 100644 man/figures/lifecycle-archived.svg create mode 100644 man/figures/lifecycle-defunct.svg create mode 100644 man/figures/lifecycle-deprecated.svg create mode 100644 man/figures/lifecycle-experimental.svg create mode 100644 man/figures/lifecycle-maturing.svg create mode 100644 man/figures/lifecycle-questioning.svg create mode 100644 man/figures/lifecycle-stable.svg create mode 100644 man/figures/lifecycle-superseded.svg diff --git a/DESCRIPTION b/DESCRIPTION index 9f67fb4..3732c13 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,9 +43,11 @@ Imports: stats, generics, ggplot2, - tibble + tibble, + lifecycle LinkingTo: Rcpp, RcppArmadillo NeedsCompilation: yes Config/testthat/edition: 3 +Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index f6985b5..a0c951c 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,6 +20,7 @@ S3method(print,nodes.goldfish) S3method(print,preprocessed.goldfish) S3method(print,result.goldfish) S3method(print,summary.result.goldfish) +S3method(simulate,formula) S3method(summary,result.goldfish) S3method(tail,dependent.goldfish) S3method(tail,network.goldfish) @@ -36,6 +37,7 @@ export(examineOutliers) export(glance) export(goldfishObjects) export(linkEvents) +export(simulate) export(tidy) importFrom(Rcpp,sourceCpp) importFrom(changepoint,cpt.mean) @@ -56,6 +58,7 @@ importFrom(ggplot2,theme_minimal) importFrom(ggplot2,xlab) importFrom(ggplot2,ylab) importFrom(graphics,points) +importFrom(lifecycle,deprecated) importFrom(methods,is) importFrom(stats,AIC) importFrom(stats,BIC) diff --git a/R/functions_estimation.R b/R/functions_estimation.R index 9a7c188..ec998e3 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -132,7 +132,6 @@ #' (see \code{\link{defineDependentEvents}}) and at the right-hand side the #' effects and the variables for which the effects are expected to occur #' (see \code{\link{goldfishEffects}}). -# or a preprocessed statistics object. #' #' @return returns an object of \code{\link{class}} \code{"result.goldfish"} #' when \code{preprocessingOnly = FALSE} or diff --git a/R/functions_simulation.R b/R/functions_simulation.R new file mode 100644 index 0000000..9fbf1dd --- /dev/null +++ b/R/functions_simulation.R @@ -0,0 +1,191 @@ +#' Simulate a sequence of events +#' +#' @description +#' `r lifecycle::badge("experimental")` +#' +#' Experimental version of the simulate functionality. +#' Current version **only** simulate endogenous events for a DyNAM model +#' with rate and choice submodel specifications. +#' It's restricted to simulate a fix length sequence, +#' oppose to the general case of simulate events until end time is reached. +#' +#' @inheritParams estimate +#' @param formulaRate a formula as define in \code{\link{estimate}} with the +#' effects for the rate sub-model \code{subModel = "rate"}. +#' @param parameterRate a numeric vector with the numerical values that +#' effects parameters on \code{formulaRate} should take during simulation. +#' @param formulaChoice a formula as define in \code{\link{estimate}} with the +#' effects for the choice sub-model \code{subModel = "choice"}. +#' When \code{model = "REM"} this formula is not required. +#' @param parameterChoice a numeric vector with the numerical values that +#' effects parameters on \code{formulaChoice} should take during simulation. +#' @param nEvents integer with the number of events to simulate from +#' the given formulas and parameter vectors. Default to \code{100}. +#' +#' @export +#' +#' @examples +#' +#' +#' +simulate <- function(formulaRate, + parameterRate, + formulaChoice = NULL, + parameterChoice = NULL, + model = c("DyNAM", "REM"), + subModel = c("choice", "choice_coordination"), + # estimationInit = NULL, + # preprocessingInit = NULL, + # preprocessingOnly = FALSE, + verbose = FALSE, + silent = FALSE, + debug = FALSE, + nEvents = 100) { + UseMethod("simulate", formulaRate) +} + + +# First estimation from a formula: can return either +# a preprocessed object or a result object +#' @export +simulate.formula <- function(formulaRate, + parameterRate, + formulaChoice = NULL, + parameterChoice = NULL, + model, + subModel, + # estimationInit = NULL, + # preprocessingInit = NULL, + # preprocessingOnly = FALSE, + verbose = FALSE, + silent = FALSE, + debug = FALSE, + nEvents = 100) { + + # CHECK THE INPUT + if (subModel == "choice_coordination") + stop( + "It doesn't support simulating a DyNAM choice coordination model.\n", + "Since the generating process for the waiting time is not specified", + call. = FALSE) + + # PARSE THE FORMULA + + ## 1.1 PARSE for all cases: preprocessingInit or not + parsedformulaRate <- parseFormula(formulaRate, model, subModel) + rhsNamesRate <- parsedformulaRate$rhsNames + depNameRate <- parsedformulaRate$depName + hasInterceptRate <- parsedformulaRate$hasIntercept + defaultNetworkNameRate <- parsedformulaRate$defaultNetworkName + # The number of the independent variables should be the length + # of the input parameter vector + if (length(rhsNamesRate) + hasInterceptRate != length(parameterRate)) + stop( + "The number of independent effects should be the same", + " as the length of the input parameter vector:", + format(formulaRate), " with parameter ", + paste(parameterRate, collapse = ",", sep = ""), + call. = FALSE + ) + + if (!is.null(formulaChoice)) { + if (!(model == "DyNAM" && subModel == "choice")) + stop( + "The model you specified doesn't require a formula", + "for the choice subModel", + call. = FALSE) + + ## 1.1 PARSE for all cases: preprocessingInit or not + parsedformulaChoice <- parseFormula(formulaChoice, model, subModel) + rhsNamesChoice <- parsedformulaChoice$rhsNames + # depNameChoice <- parsedformulaChoice$depName + # defaultNetworkNameChoice <- parsedformulaChoice$defaultNetworkName + if (parsedformulaChoice$hasIntercept) + # In the DyNAM choice model, + # the intercept will be cancelled and hence useless. + stop("Intercept in the choice subModel model will be ignored.", + " Please remove the intercep and run again.", call. = FALSE) + + if (length(rhsNamesChoice) != length(parameterChoice)) + stop( + "The number of the independent effects should be the same", + " as the length of the input parameter:", + format(formulaChoice), " with parameter ", + paste(parameterChoice, collapse = ","), + call. = FALSE + ) + } + + # CHECK THE INPUT FORMULA + # If there's no intercept in the formula for the waiting-time generating process (For example, DyNAM choice, or REM), + # we take the coefficient of the intercept as 0. + if (!hasInterceptRate) { + cat("\n", "You didn't specify an intercept in the first formula so we take the intercept as 0.", "\n") + parameterRate <- c(0, parameterRate) + } + + + + # get node sets of dependent variable + nodes <- attr(get(depNameRate), "nodes") + isTwoMode <- FALSE + + # two-mode networks(2 kinds of nodes) + if (length(nodes) == 2) { + nodes2 <- nodes[2] + nodes <- nodes[1] + isTwoMode <- TRUE + } else { + nodes2 <- nodes + } + + + + ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not + + # enviroment from which get the objects + envir <- environment() + + # effect and objectsEffectsLink for sender-deciding process + effectsRate <- createEffectsFunctions(rhsNamesRate, + model, subModel, envir = envir) + objectsEffectsLinkRate <- getObjectsEffectsLink(rhsNamesRate) + + # effect and objectsEffectsLink for receiver-deciding process + effectsChoice <- NULL + objectsEffectsLinkChoice <- NULL + if (!is.null(formulaChoice)) { + effectsChoice <- createEffectsFunctions(rhsNamesChoice, + model, subModel, envir = envir) + objectsEffectsLinkChoice <- getObjectsEffectsLink(rhsNamesChoice) + } + + + + + + # Simulating! + if (!silent) cat("Starting simulation\n") + events <- simulate_engine( + model, + subModel, + parameter = parameterRate, + effects = effectsRate, + objectsEffectsLink = objectsEffectsLinkRate, # for parameterization + parameterChoice = parameterChoice, + effectsChoice = effectsChoice, + objectsEffectsLinkChoice = objectsEffectsLinkChoice, + nodes = nodes, + nodes2 = nodes2, + isTwoMode = isTwoMode, + rightCensored = FALSE, # ToDo: check + verbose = verbose, + silent = silent, + nEvents = nEvents + ) + + # Styling the result + events <- data.frame(time = events[, 1], sender = as.character(actors$label[events[, 2]]), receiver = as.character(actors$label[events[, 3]]), increment = events[, 4], stringsAsFactors = FALSE) + + return(events) +} diff --git a/R/functions_simulation_engine.R b/R/functions_simulation_engine.R new file mode 100644 index 0000000..c41fbdb --- /dev/null +++ b/R/functions_simulation_engine.R @@ -0,0 +1,359 @@ +#' preprocess event and related objects describe in the formula to estimate +#' +#' Create a preprocess.goldfish class objectRate with the necessary information +#' for simulation. +#' +#' @inheritParams estimate +#' @inheritParams simulate +#' @inheritParams preprocess +#' @param objectsEffectsLinkRate data.frame output of +#' \code(getObjectsEffectsLink) +#' @param objectsEffectsLinkChoice data.frame output of +#' \code(getObjectsEffectsLink) +#' +#' @return a list of class preprocessed.goldfish +#' +#' @keywords internal +#' @noRd +simulate_engine <- function( + model, + subModel, + parameterRate, + effectsRate, + objectsEffectsLinkRate, + parameterChoice, + effectsChoice, + objectsEffectsLinkChoice, + # multipleParameter, + nodes, + nodes2 = nodes, + isTwoMode, + # add more parameters + startTime = 0, + endTime = NULL, + rightCensored = FALSE, + verbose = TRUE, + silent = FALSE, + nEvents) { + + prepEnvir <- environment() + + + n1 <- nrow(get(nodes)) + n2 <- nrow(get(nodes2)) + nEffectsRate <- length(effectsRate) + nEffectsChoice <- length(effectsChoice) + + + if (!silent) cat("Initializing cache objects and statistical matrices.\n") + + # Initialize stat matrix for rate model + windowParametersRate <- lapply(effectsRate, function(x) NULL) + statCacheRate <- initializeCacheStat( + objectsEffectsLinkRate, effectsRate, windowParametersRate, n1, n2, + model, subModel, + envir = prepEnvir + ) + + # Initialize stat matrix for the choice model + if (!is.null(parameterChoice)) { + # windowParametersChoice <- lapply(effectsChoice, function(x) NULL) + statCacheChoice <- initializeCacheStat( + objectsEffectsLinkChoice, effectsChoice, windowParametersRate, n1, n2, + model, "choice", + envir = prepEnvir + ) + # the variable subModel is for the sender-deciding process. ToDo: check + subModel <- "rate" + } + + # We put the initial stats to the previous format of 3 dimensional array + initialStatsRate <- array( + unlist(lapply(statCacheRate, "[[", "stat")), + dim = c(n1, n2, nEffectsRate) + ) + statMatRate <- initialStatsRate + statCacheRate <- lapply(statCacheRate, "[[", "cache") + # for receiver-deciding process if it's necessary + if (!is.null(parameterChoice)) { + initialStatsChoice <- array( + unlist(lapply(statCacheChoice, "[[", "stat")), + dim = c(n1, n2, nEffectsChoice) + ) + statMatChoice <- initialStatsChoice + statCacheChoice <- lapply(statCacheChoice, "[[", "cache") + } + + # ToDo: change to startTime + currentTime <- 0 + events <- matrix(0, nEvents, 4) + + # initialize progressbar output + showProgressBar <- FALSE + progressEndReached <- FALSE + + if (!silent) { + cat("Simulating events.\n") + showProgressBar <- TRUE + # # how often print, max 50 prints + pb <- utils::txtProgressBar(max = nEvents, char = "*", style = 3) + dotEvents <- ifelse(nEvents > 50, ceiling(nEvents / 50), 1) + } + + # Simulation each event + for (i in 1:nEvents) { + # # progress bar + if (showProgressBar && i %% dotEvents == 0) { + utils::setTxtProgressBar(pb, i) + } else if (showProgressBar && i == nEvents) { + utils::setTxtProgressBar(pb, i) + close(pb) + } + + # nextEvent <- 1 + effIdsRate <- seq.int(length(objectsEffectsLinkRate)) + effIdsChoice <- seq.int(length(objectsEffectsLinkChoice)) + objTableRate <- getDataObjects( + list(rownames(objectsEffectsLinkRate)), + removeFirst = FALSE) + objectNameRate <- objTableRate$name + objectRate <- getElementFromDataObjectTable( + objTableRate, envir = prepEnvir)[[1]] + + #### GENERATING EVENT + # We consider only two types of model, REM and DyNAM, and don't consider DyNAM-MM + if (model == "REM") { + simulatedEvent <- generationREM( + statMatRate, parameterRate, n1, n2, isTwoMode) + waitingTime <- simulatedEvent$waitingTime + simulatedSender <- simulatedEvent$simulatedSender + simulatedReceiver <- simulatedEvent$simulatedReceiver + } else if (model == "DyNAM" && subModel == "rate") { + simulatedSenderEvent <- generationDyNAMRate( + statMatRate, parameterRate, n1, n2, isTwoMode) + waitingTime <- simulatedSenderEvent$waitingTime + simulatedSender <- simulatedSenderEvent$simulatedSender + simulatedReceiverEvent <- generationDyNAMChoice( + statMatChoice, parameterChoice, simulatedSender, n1, n2, isTwoMode) + simulatedReceiver <- simulatedReceiverEvent$simulatedReceiver + } + + # event <- c(simulatedSender,simulatedReceiver,objectRate[simulatedSender, simulatedReceiver]) + event <- data.frame( + sender = as.integer(simulatedSender), + receiver = as.integer(simulatedReceiver), + replace = objectRate[simulatedSender, simulatedReceiver] + 1) + # RECORD EVENT + events[i, ] <- c( + currentTime + waitingTime, + simulatedSender, + simulatedReceiver, + 1) + + ### CALCULATE UPDATES + isUndirectedNet <- FALSE + updatesList <- getUpdates( + event, effectsRate, effIdsRate, + objectsEffectsLinkRate, isUndirectedNet, n1, n2, + isTwoMode, prepEnvir, "statCacheRate") + ### APPLYING UPDATES TO statMatRate + # For sender + for (id in effIdsRate) { + if (id <= length(updatesList) && !is.null(updatesList[[id]])) { + updates <- updatesList[[id]] + # ToDo: check + statMatRate[cbind(updates[, "node1"], updates[, "node2"], id)] <- + updates[, "replace"] + } + } + # For receiver + if (!is.null(parameterChoice)) { + updatesList <- getUpdates( + event, effectsChoice, effIdsChoice, + objectsEffectsLinkChoice, isUndirectedNet, n1, n2, + isTwoMode, prepEnvir, "statCacheChoice") + ### APPLYING UPDATES TO statMatRate + # For receiver + for (id in effIdsChoice) { + if (id <= length(updatesList) && !is.null(updatesList[[id]])) { + updates <- updatesList[[id]] + statMatChoice[cbind(updates[, "node1"], updates[, "node2"], id)] <- + updates[, "replace"] + } + } + } + + ### update other information + currentTime <- currentTime + waitingTime + objectRate[simulatedSender, simulatedReceiver] <- + objectRate[simulatedSender, simulatedReceiver] + 1 + eval(parse(text = paste(objectNameRate, "<- objectRate")), + envir = prepEnvir) + } + + return(events) +} + + +generationREM <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { + n_parameters <- dim(statMatRate)[3] + # +1 for intercept + stat_mat <- matrix(0, n1 * n2, n_parameters + 1) + stat_mat[, 1] <- 1 + for (i in 1:n_parameters) { + stat_mat[, i + 1] <- t(statMatRate[, , i]) + } + expValue <- exp(stat_mat %*% parameterRate) + if (!isTwoMode) { + for (i in 1:n1) expValue[i + (i - 1) * n2] <- 0 + } + + # expected time + tauSum <- sum(expValue) + expectedWaitingtime <- 1 / tauSum + waitingTime <- rexp(1, tauSum) + + # Conditional on the waiting time, + # the process to choose a sender-receiver pair is a multinomial process + simulatedSenderReceiver <- sample(1:length(expValue), 1, prob = expValue) + simulatedSender <- ceiling(simulatedSenderReceiver / n2) + simulatedReceiver <- simulatedSenderReceiver - (simulatedSender - 1) * n2 + + + return(list( + simulatedSenderReceiver = simulatedSenderReceiver, + simulatedSender = simulatedSender, + simulatedReceiver = simulatedReceiver, + expectedWaitingtime = expectedWaitingtime, + waitingTime = waitingTime + )) +} + +generationDyNAMRate <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { + # Copy from functions_estimation_engine.R for matrix reduction + # In the end, we will get a n1 x nEffectsRate matrix stat_mat. + if (isTwoMode == FALSE) { + dims <- dim(statMatRate) # statsArrayComp: + stat_mat <- apply(statMatRate, 3, function(stat) { + diag(stat) <- 0 + m <- stat + stat <- rowMeans(m, na.rm = T) * (dim(m)[1]) / (dim(m)[1] - 1) + stat + }) + } else { + dims <- dim(statMatRate) + # statsArrayComp: n_nodes1*n_nodes2*num_statistics matrix + stat_mat <- apply(statMatRate, 3, function(stat) { + m <- stat + stat <- rowMeans(m, na.rm = T) + stat + }) + } + expValue <- exp(stat_mat %*% parameterRate[-1] + parameterRate[1]) + + # expected time + tauSum <- sum(expValue) + expectedWaitingtime <- 1 / tauSum + waitingTime <- rexp(1, tauSum) + + # Conditional on the waiting time, the process to choose a sender is + # a multinomial process + simulatedSender <- sample(1:length(expValue), 1, prob = expValue) + + + return(list( + simulatedSender = simulatedSender, + expectedWaitingtime = expectedWaitingtime, + waitingTime = waitingTime + )) +} + +generationDyNAMChoice <- function( + statMatRate, parameterChoice, simulatedSender, n1, n2, isTwoMode) { + stat_mat <- statMatRate[simulatedSender, , ] + expValue <- exp(stat_mat %*% parameterChoice) + if (!isTwoMode) expValue[simulatedSender] <- 0 + # In DyNAM, we use multinomial process for receiver selection + simulatedReceiver <- sample(1:length(expValue), 1, prob = expValue) + return(list(simulatedReceiver = simulatedReceiver)) +} + +getUpdates <- function( + event, effects, effIds, + objectsEffectsLink, isUndirectedNet, n1, n2, + isTwoMode, prepEnvir, cacheName) { + # get the statCache from the prepEnvir + # We does it in this way because we have to update the statCache in + # the parent enviroment later. + statCache = get(cacheName, envir = prepEnvir) + # define the return variable + updatesList = list() + + for (id in effIds) { + # create the ordered list for the objects + objectsToPass <- objectsEffectsLink[, id][!is.na(objectsEffectsLink[, id])] + names <- rownames(objectsEffectsLink)[!is.na(objectsEffectsLink[, id])] + orderedNames <- names[order(objectsToPass)] + orderedObjectTable <- getDataObjects(list(list("", orderedNames))) + .objects <- getElementFromDataObjectTable( + orderedObjectTable, envir = prepEnvir) + # identify class to feed effects functions + objClass <- vapply(.objects, FUN = inherits, FUN.VALUE = integer(2), + what = c("numeric", "matrix"), which = TRUE) > 0 + attIDs <- which(objClass[1, ]) + netIDs <- which(objClass[2, ]) + + # call effects function with required arguments + .argsFUN <- list( + network = if (length(.objects[netIDs]) == 1) { + .objects[netIDs][[1]] + } else { + .objects[netIDs] + }, + attribute = if (length(.objects[attIDs]) == 1) { + .objects[attIDs][[1]] + } else { + .objects[attIDs] + }, + cache = statCache[[id]], + n1 = n1, + n2 = n2 + ) + + effectUpdate <- callFUN( + effects, id, "effect", c(.argsFUN, event), " cannot update \n", + colnames(objectsEffectsLink)[id] + ) + + updates <- effectUpdate$changes + # if cache and changes are not null update cache + if (!is.null(effectUpdate$cache) & !is.null(effectUpdate$changes)) { + statCache[[id]] <- effectUpdate$cache + } + + if (isUndirectedNet) { + event2 <- event + event2$sender <- event$receiver + event2$receiver <- event$sender + if (!is.null(effectUpdate$cache) & !is.null(effectUpdate$changes)) + .argsFUN$cache <- statCache[[id]] + effectUpdate2 <- callFUN( + effects, id, "effect", c(.argsFUN, event2), " cannot update \n", + colnames(objectsEffectsLink)[id] + ) + + if (!is.null(effectUpdate2$cache) & !is.null(effectUpdate2$changes)) + statCache[[id]] <- effectUpdate2$cache + updates2 <- effectUpdate2$changes + updates <- rbind(updates, updates2) + } + + updatesList[[id]] = updates + } + + #update the statCache + assign(cacheName, statCache, envir = prepEnvir) + #return updatesList + return(updatesList) + +} diff --git a/R/goldfish-package.R b/R/goldfish-package.R index 3c23395..c97e832 100644 --- a/R/goldfish-package.R +++ b/R/goldfish-package.R @@ -1,41 +1,37 @@ ## usethis namespace: start -#' `goldfish` package #' -#' The Goldfish Project is an R package that allows to fit statistical network models #' (such as DyNAM and REM) to dynamic network data. -#' -#' The \href{www.social-networks.ethz.ch/research/goldfish.html}{Goldfish} -#' package in R allows the study of time-stamped network data using a variety of models. -#' In particular, it implements different types of Dynamic Network Actor Models (DyNAMs), -#' a class of models that is tailored to the study of actor-oriented network processess through time. -#' Goldfish also implements different versions of the tie-oriented Relational Event Model by Carter Butts. -#' -#' @seealso \code{\link{estimate}} +#' @aliases goldfish goldfish-package +#' @docType package +#' @importFrom lifecycle experimental +#' @importFrom Rcpp sourceCpp +#' @name goldfish-package #' @references -#' Stadtfeld, C. (2012). Events in Social Networks: A Stochastic -#' Actor-oriented Framework for Dynamic Event Processes in Social Networks. +#' @seealso \code{\link{estimate}} +#' @useDynLib goldfish +#' #' \emph{KIT Scientific Publishing}. \doi{10.5445/KSP/1000025407} -#' -#' Stadtfeld, C., and Block, P. (2017). Interactions, Actors, and Time: -#' Dynamic Network Actor Models for Relational Events. +#' \emph{Network Science}, 8(S1), S4-S25. \doi{10.1017/nws.2020.3} +#' \emph{Sociological Methodology 47 (1)}. \doi{10.1177/0081175017709295} #' \emph{Sociological Science 4 (1)}, 318-52. \doi{10.15195/v4.a14} -#' -#' Stadtfeld, C., Hollway, J., and Block, P. (2017). +#' `goldfish` package +#' a class of models that is tailored to the study of actor-oriented network processess through time. +#' A model for the dynamics of face-to-face interactions in social groups. +#' Actor-oriented Framework for Dynamic Event Processes in Social Networks. +#' Dynamic Network Actor Models for Relational Events. #' Dynamic Network Actor Models: Investigating Coordination Ties Through Time. -#' \emph{Sociological Methodology 47 (1)}. \doi{10.1177/0081175017709295} -#' +#' Goldfish also implements different versions of the tie-oriented Relational Event Model by Carter Butts. +#' Hoffman, M., Block P., Elmer T., and Stadtfeld C. (2020). #' Hollway, J. (2020). -#' Network embeddedness and the rate of international water cooperation and conflict. #' In \emph{Networks in Water Governance}, edited by Manuel Fischer and Karin Ingold. +#' In particular, it implements different types of Dynamic Network Actor Models (DyNAMs), #' London: Palgrave, pp. 87-113. -#' -#' Hoffman, M., Block P., Elmer T., and Stadtfeld C. (2020). -#' A model for the dynamics of face-to-face interactions in social groups. -#' \emph{Network Science}, 8(S1), S4-S25. \doi{10.1017/nws.2020.3} -#' @name goldfish-package -#' @docType package -#' @aliases goldfish goldfish-package -#' @useDynLib goldfish -#' @importFrom Rcpp sourceCpp +#' Network embeddedness and the rate of international water cooperation and conflict. +#' package in R allows the study of time-stamped network data using a variety of models. +#' Stadtfeld, C. (2012). Events in Social Networks: A Stochastic +#' Stadtfeld, C., and Block, P. (2017). Interactions, Actors, and Time: +#' Stadtfeld, C., Hollway, J., and Block, P. (2017). +#' The \href{www.social-networks.ethz.ch/research/goldfish.html}{Goldfish} +#' The Goldfish Project is an R package that allows to fit statistical network models ## usethis namespace: end NULL diff --git a/man/figures/lifecycle-archived.svg b/man/figures/lifecycle-archived.svg new file mode 100644 index 0000000..48f72a6 --- /dev/null +++ b/man/figures/lifecycle-archived.svg @@ -0,0 +1 @@ + lifecyclelifecyclearchivedarchived \ No newline at end of file diff --git a/man/figures/lifecycle-defunct.svg b/man/figures/lifecycle-defunct.svg new file mode 100644 index 0000000..01452e5 --- /dev/null +++ b/man/figures/lifecycle-defunct.svg @@ -0,0 +1 @@ +lifecyclelifecycledefunctdefunct \ No newline at end of file diff --git a/man/figures/lifecycle-deprecated.svg b/man/figures/lifecycle-deprecated.svg new file mode 100644 index 0000000..4baaee0 --- /dev/null +++ b/man/figures/lifecycle-deprecated.svg @@ -0,0 +1 @@ +lifecyclelifecycledeprecateddeprecated \ No newline at end of file diff --git a/man/figures/lifecycle-experimental.svg b/man/figures/lifecycle-experimental.svg new file mode 100644 index 0000000..d1d060e --- /dev/null +++ b/man/figures/lifecycle-experimental.svg @@ -0,0 +1 @@ +lifecyclelifecycleexperimentalexperimental \ No newline at end of file diff --git a/man/figures/lifecycle-maturing.svg b/man/figures/lifecycle-maturing.svg new file mode 100644 index 0000000..df71310 --- /dev/null +++ b/man/figures/lifecycle-maturing.svg @@ -0,0 +1 @@ +lifecyclelifecyclematuringmaturing \ No newline at end of file diff --git a/man/figures/lifecycle-questioning.svg b/man/figures/lifecycle-questioning.svg new file mode 100644 index 0000000..08ee0c9 --- /dev/null +++ b/man/figures/lifecycle-questioning.svg @@ -0,0 +1 @@ +lifecyclelifecyclequestioningquestioning \ No newline at end of file diff --git a/man/figures/lifecycle-stable.svg b/man/figures/lifecycle-stable.svg new file mode 100644 index 0000000..e015dc8 --- /dev/null +++ b/man/figures/lifecycle-stable.svg @@ -0,0 +1 @@ +lifecyclelifecyclestablestable \ No newline at end of file diff --git a/man/figures/lifecycle-superseded.svg b/man/figures/lifecycle-superseded.svg new file mode 100644 index 0000000..75f24f5 --- /dev/null +++ b/man/figures/lifecycle-superseded.svg @@ -0,0 +1 @@ + lifecyclelifecyclesupersededsuperseded \ No newline at end of file From 56d6ace2da54729cea03c91f7e8a871898f29ef0 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 28 Jun 2022 17:30:36 +0200 Subject: [PATCH 02/36] WIP Refactor simulation functions --- R/functions_preprocessing.R | 8 +- R/functions_simulation.R | 154 ++++++++++++++------------------ R/functions_simulation_engine.R | 108 ++++++++++++++-------- 3 files changed, 145 insertions(+), 125 deletions(-) diff --git a/R/functions_preprocessing.R b/R/functions_preprocessing.R index d669e72..2eb562a 100644 --- a/R/functions_preprocessing.R +++ b/R/functions_preprocessing.R @@ -326,9 +326,9 @@ preprocess <- function( attIDs <- which(objCat == "attribute") netIDs <- which(objCat == "network") if (attr(objCat, "noneClass")) - stop("An object is not assigned either as network or attibute", + stop("An object is not assigned either as network or attibute\n\t", paste(names[attr(objCat, "manyClasses") != 1], collapse = ", "), - "check the class of the object.", call. = FALSE) + "\n\tcheck the class of the object.", call. = FALSE) # call effects function with required arguments .argsFUN <- list( @@ -468,9 +468,9 @@ initializeCacheStat <- function( # list of 4, call matrix, friendship matrix, actor$gradetype vector, actor$floor vector objCat <- assignCatToObject(.objects) if (attr(objCat, "noneClass")) - stop("An object is not assigned either as network or attibute", + stop("An object is not assigned either as network or attibute\n\t", paste(rownames(objectsEffectsLink)[attr(objCat, "manyClasses") != 1], collapse = ", "), - "check the class of the object.", call. = FALSE) + "\n\tcheck the class of the object.", call. = FALSE) # objects: list of 6, each element is a 84*84 matrix objectsRet <- lapply( diff --git a/R/functions_simulation.R b/R/functions_simulation.R index 9fbf1dd..fb6b070 100644 --- a/R/functions_simulation.R +++ b/R/functions_simulation.R @@ -12,12 +12,12 @@ #' @inheritParams estimate #' @param formulaRate a formula as define in \code{\link{estimate}} with the #' effects for the rate sub-model \code{subModel = "rate"}. -#' @param parameterRate a numeric vector with the numerical values that +#' @param parametersRate a numeric vector with the numerical values that #' effects parameters on \code{formulaRate} should take during simulation. #' @param formulaChoice a formula as define in \code{\link{estimate}} with the #' effects for the choice sub-model \code{subModel = "choice"}. #' When \code{model = "REM"} this formula is not required. -#' @param parameterChoice a numeric vector with the numerical values that +#' @param parametersChoice a numeric vector with the numerical values that #' effects parameters on \code{formulaChoice} should take during simulation. #' @param nEvents integer with the number of events to simulate from #' the given formulas and parameter vectors. Default to \code{100}. @@ -29,9 +29,9 @@ #' #' simulate <- function(formulaRate, - parameterRate, + parametersRate, formulaChoice = NULL, - parameterChoice = NULL, + parametersChoice = NULL, model = c("DyNAM", "REM"), subModel = c("choice", "choice_coordination"), # estimationInit = NULL, @@ -39,7 +39,6 @@ simulate <- function(formulaRate, # preprocessingOnly = FALSE, verbose = FALSE, silent = FALSE, - debug = FALSE, nEvents = 100) { UseMethod("simulate", formulaRate) } @@ -49,42 +48,62 @@ simulate <- function(formulaRate, # a preprocessed object or a result object #' @export simulate.formula <- function(formulaRate, - parameterRate, + parametersRate, formulaChoice = NULL, - parameterChoice = NULL, - model, - subModel, + parametersChoice = NULL, + model = c("DyNAM", "REM"), + subModel = c("choice", "rate"), # estimationInit = NULL, # preprocessingInit = NULL, # preprocessingOnly = FALSE, verbose = FALSE, silent = FALSE, - debug = FALSE, nEvents = 100) { - # CHECK THE INPUT + # CHECK INPUT + model <- match.arg(model) + subModel <- match.arg(subModel) + + ### check model and subModel + checkModelPar(model, subModel, + modelList = c("DyNAM", "REM", "DyNAMi", "TriNAM"), + subModelList = list( + DyNAM = c("choice", "rate", "choice_coordination"), + REM = "choice", + DyNAMi = c("choice", "rate"), + TriNAM = c("choice", "rate") + ) + ) + if (subModel == "choice_coordination") stop( "It doesn't support simulating a DyNAM choice coordination model.\n", "Since the generating process for the waiting time is not specified", call. = FALSE) + + stopifnot( + inherits(formulaRate, "formula"), + inherits(formulaChoice, "formula"), + inherits(parametersRate, "numeric"), + inherits(parametersChoice, "numeric"), + inherits(verbose, "logical"), + inherits(silent, "logical"), + inherits(nEvents, "numeric") && nEvents > 0 + ) - # PARSE THE FORMULA - - ## 1.1 PARSE for all cases: preprocessingInit or not - parsedformulaRate <- parseFormula(formulaRate, model, subModel) - rhsNamesRate <- parsedformulaRate$rhsNames - depNameRate <- parsedformulaRate$depName - hasInterceptRate <- parsedformulaRate$hasIntercept - defaultNetworkNameRate <- parsedformulaRate$defaultNetworkName + ## 1.1 Preparing + parsedformulaRate <- parseFormula(formulaRate) + # The number of the independent variables should be the length # of the input parameter vector - if (length(rhsNamesRate) + hasInterceptRate != length(parameterRate)) + if (length(parsedformulaRate$rhsNames) + + parsedformulaRate$hasIntercept != + length(parametersRate)) stop( "The number of independent effects should be the same", " as the length of the input parameter vector:", format(formulaRate), " with parameter ", - paste(parameterRate, collapse = ",", sep = ""), + paste(parametersRate, collapse = ",", sep = ""), call. = FALSE ) @@ -96,92 +115,55 @@ simulate.formula <- function(formulaRate, call. = FALSE) ## 1.1 PARSE for all cases: preprocessingInit or not - parsedformulaChoice <- parseFormula(formulaChoice, model, subModel) - rhsNamesChoice <- parsedformulaChoice$rhsNames - # depNameChoice <- parsedformulaChoice$depName - # defaultNetworkNameChoice <- parsedformulaChoice$defaultNetworkName + parsedformulaChoice <- parseFormula(formulaChoice) if (parsedformulaChoice$hasIntercept) # In the DyNAM choice model, # the intercept will be cancelled and hence useless. stop("Intercept in the choice subModel model will be ignored.", " Please remove the intercep and run again.", call. = FALSE) - if (length(rhsNamesChoice) != length(parameterChoice)) + if (length(parsedformulaChoice$rhsNames) != + length(parametersChoice)) stop( "The number of the independent effects should be the same", " as the length of the input parameter:", format(formulaChoice), " with parameter ", - paste(parameterChoice, collapse = ","), + paste(parametersChoice, collapse = ","), call. = FALSE ) - } - - # CHECK THE INPUT FORMULA - # If there's no intercept in the formula for the waiting-time generating process (For example, DyNAM choice, or REM), - # we take the coefficient of the intercept as 0. - if (!hasInterceptRate) { - cat("\n", "You didn't specify an intercept in the first formula so we take the intercept as 0.", "\n") - parameterRate <- c(0, parameterRate) - } - - - - # get node sets of dependent variable - nodes <- attr(get(depNameRate), "nodes") - isTwoMode <- FALSE - - # two-mode networks(2 kinds of nodes) - if (length(nodes) == 2) { - nodes2 <- nodes[2] - nodes <- nodes[1] - isTwoMode <- TRUE + + if (parsedformulaRate$depName != parsedformulaChoice$depName) + stop("formula for rate and choice submodels", + " must be defined over the same dependent event object", + call. = FALSE) } else { - nodes2 <- nodes + parsedformulaChoice <- NULL } - - - ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not - - # enviroment from which get the objects - envir <- environment() - - # effect and objectsEffectsLink for sender-deciding process - effectsRate <- createEffectsFunctions(rhsNamesRate, - model, subModel, envir = envir) - objectsEffectsLinkRate <- getObjectsEffectsLink(rhsNamesRate) - - # effect and objectsEffectsLink for receiver-deciding process - effectsChoice <- NULL - objectsEffectsLinkChoice <- NULL - if (!is.null(formulaChoice)) { - effectsChoice <- createEffectsFunctions(rhsNamesChoice, - model, subModel, envir = envir) - objectsEffectsLinkChoice <- getObjectsEffectsLink(rhsNamesChoice) - } - - - - + # CHECK THE INPUT FORMULA + # There must exist the intercept in the formula for the waiting-time + # generating process (For example, DyNAM rate, or REM), + if (!parsedformulaRate$hasIntercept) + stop("You didn't specify an intercept in the rate formula.", + "\n\tCurrent implementation requires intercept and", + " a positive parameter value for it.", + call. = FALSE) # Simulating! if (!silent) cat("Starting simulation\n") events <- simulate_engine( - model, - subModel, - parameter = parameterRate, - effects = effectsRate, - objectsEffectsLink = objectsEffectsLinkRate, # for parameterization - parameterChoice = parameterChoice, - effectsChoice = effectsChoice, - objectsEffectsLinkChoice = objectsEffectsLinkChoice, - nodes = nodes, - nodes2 = nodes2, - isTwoMode = isTwoMode, + model = model, + subModel = subModel, + parametersRate = parametersRate, + parsedformulaRate = parsedformulaRate, + parametersChoice = parametersChoice, + parsedformulaChoice = parsedformulaChoice, + nEvents = nEvents, + startTime = 0, + endTime = NULL, rightCensored = FALSE, # ToDo: check verbose = verbose, - silent = silent, - nEvents = nEvents + silent = silent ) # Styling the result diff --git a/R/functions_simulation_engine.R b/R/functions_simulation_engine.R index c41fbdb..f578e30 100644 --- a/R/functions_simulation_engine.R +++ b/R/functions_simulation_engine.R @@ -1,4 +1,4 @@ -#' preprocess event and related objects describe in the formula to estimate +#' internal function to perform simulation based on preprocessing #' #' Create a preprocess.goldfish class objectRate with the necessary information #' for simulation. @@ -6,24 +6,19 @@ #' @inheritParams estimate #' @inheritParams simulate #' @inheritParams preprocess -#' @param objectsEffectsLinkRate data.frame output of -#' \code(getObjectsEffectsLink) -#' @param objectsEffectsLinkChoice data.frame output of -#' \code(getObjectsEffectsLink) #' -#' @return a list of class preprocessed.goldfish +#' @return an array with simulated events #' #' @keywords internal #' @noRd simulate_engine <- function( model, subModel, - parameterRate, - effectsRate, - objectsEffectsLinkRate, - parameterChoice, - effectsChoice, - objectsEffectsLinkChoice, + parametersRate, + parsedformulaRate, + parametersChoice, + parsedformulaChoice, + nEvents, # multipleParameter, nodes, nodes2 = nodes, @@ -33,33 +28,76 @@ simulate_engine <- function( endTime = NULL, rightCensored = FALSE, verbose = TRUE, - silent = FALSE, - nEvents) { + silent = FALSE) { prepEnvir <- environment() + + + # get node sets of dependent variable + nodes <- attr(get(parsedformulaRate$depName), "nodes") + isTwoMode <- FALSE + + # two-mode networks(2 kinds of nodes) + if (length(nodes) == 2) { + nodes2 <- nodes[2] + nodes <- nodes[1] + isTwoMode <- TRUE + } else { + nodes2 <- nodes + } + + ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not + + # enviroment from which get the objects + envir <- environment() + + # effect and objectsEffectsLink for sender-deciding process + effectsRate <- createEffectsFunctions(parsedformulaRate$rhsNames, + model, subModel, envir = envir) + objectsEffectsLinkRate <- getObjectsEffectsLink( + parsedformulaRate$rhsNames) + + # effect and objectsEffectsLink for receiver-deciding process + effectsChoice <- NULL + objectsEffectsLinkChoice <- NULL + if (!is.null(parametersChoice)) { + effectsChoice <- createEffectsFunctions(parsedformulaChoice$rhsNames, + model, subModel, envir = envir) + objectsEffectsLinkChoice <- getObjectsEffectsLink( + parsedformulaChoice$rhsNames) + } + + # n1 <- nrow(get(nodes)) n2 <- nrow(get(nodes2)) nEffectsRate <- length(effectsRate) nEffectsChoice <- length(effectsChoice) - - + if (!silent) cat("Initializing cache objects and statistical matrices.\n") - + # ToDo: Impute misssing data + # startTime and endTime handling + # Initialize stat matrix for rate model - windowParametersRate <- lapply(effectsRate, function(x) NULL) statCacheRate <- initializeCacheStat( - objectsEffectsLinkRate, effectsRate, windowParametersRate, n1, n2, - model, subModel, + objectsEffectsLink = objectsEffectsLinkRate, + effects = effectsRate, + groupsNetwork = NULL, + windowParameters = parsedformulaRate$windowParameters, + n1 = n1, n2 = n2, + model = model, subModel = "rate", envir = prepEnvir ) # Initialize stat matrix for the choice model - if (!is.null(parameterChoice)) { - # windowParametersChoice <- lapply(effectsChoice, function(x) NULL) + if (!is.null(parametersChoice)) { statCacheChoice <- initializeCacheStat( - objectsEffectsLinkChoice, effectsChoice, windowParametersRate, n1, n2, + objectsEffectsLink = objectsEffectsLinkChoice, + effects = effectsChoice, + groupsNetwork = NULL, + windowParameters = parsedformulaChoice$windowParameters, + n1 = n1, n2 = n2, model, "choice", envir = prepEnvir ) @@ -75,7 +113,7 @@ simulate_engine <- function( statMatRate <- initialStatsRate statCacheRate <- lapply(statCacheRate, "[[", "cache") # for receiver-deciding process if it's necessary - if (!is.null(parameterChoice)) { + if (!is.null(parametersChoice)) { initialStatsChoice <- array( unlist(lapply(statCacheChoice, "[[", "stat")), dim = c(n1, n2, nEffectsChoice) @@ -90,7 +128,7 @@ simulate_engine <- function( # initialize progressbar output showProgressBar <- FALSE - progressEndReached <- FALSE + # progressEndReached <- FALSE if (!silent) { cat("Simulating events.\n") @@ -124,17 +162,17 @@ simulate_engine <- function( # We consider only two types of model, REM and DyNAM, and don't consider DyNAM-MM if (model == "REM") { simulatedEvent <- generationREM( - statMatRate, parameterRate, n1, n2, isTwoMode) + statMatRate, parametersRate, n1, n2, isTwoMode) waitingTime <- simulatedEvent$waitingTime simulatedSender <- simulatedEvent$simulatedSender simulatedReceiver <- simulatedEvent$simulatedReceiver } else if (model == "DyNAM" && subModel == "rate") { simulatedSenderEvent <- generationDyNAMRate( - statMatRate, parameterRate, n1, n2, isTwoMode) + statMatRate, parametersRate, n1, n2, isTwoMode) waitingTime <- simulatedSenderEvent$waitingTime simulatedSender <- simulatedSenderEvent$simulatedSender simulatedReceiverEvent <- generationDyNAMChoice( - statMatChoice, parameterChoice, simulatedSender, n1, n2, isTwoMode) + statMatChoice, parametersChoice, simulatedSender, n1, n2, isTwoMode) simulatedReceiver <- simulatedReceiverEvent$simulatedReceiver } @@ -167,7 +205,7 @@ simulate_engine <- function( } } # For receiver - if (!is.null(parameterChoice)) { + if (!is.null(parametersChoice)) { updatesList <- getUpdates( event, effectsChoice, effIdsChoice, objectsEffectsLinkChoice, isUndirectedNet, n1, n2, @@ -195,7 +233,7 @@ simulate_engine <- function( } -generationREM <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { +generationREM <- function(statMatRate, parametersRate, n1, n2, isTwoMode) { n_parameters <- dim(statMatRate)[3] # +1 for intercept stat_mat <- matrix(0, n1 * n2, n_parameters + 1) @@ -203,7 +241,7 @@ generationREM <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { for (i in 1:n_parameters) { stat_mat[, i + 1] <- t(statMatRate[, , i]) } - expValue <- exp(stat_mat %*% parameterRate) + expValue <- exp(stat_mat %*% parametersRate) if (!isTwoMode) { for (i in 1:n1) expValue[i + (i - 1) * n2] <- 0 } @@ -229,7 +267,7 @@ generationREM <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { )) } -generationDyNAMRate <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { +generationDyNAMRate <- function(statMatRate, parametersRate, n1, n2, isTwoMode) { # Copy from functions_estimation_engine.R for matrix reduction # In the end, we will get a n1 x nEffectsRate matrix stat_mat. if (isTwoMode == FALSE) { @@ -249,7 +287,7 @@ generationDyNAMRate <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { stat }) } - expValue <- exp(stat_mat %*% parameterRate[-1] + parameterRate[1]) + expValue <- exp(stat_mat %*% parametersRate[-1] + parametersRate[1]) # expected time tauSum <- sum(expValue) @@ -269,9 +307,9 @@ generationDyNAMRate <- function(statMatRate, parameterRate, n1, n2, isTwoMode) { } generationDyNAMChoice <- function( - statMatRate, parameterChoice, simulatedSender, n1, n2, isTwoMode) { + statMatRate, parametersChoice, simulatedSender, n1, n2, isTwoMode) { stat_mat <- statMatRate[simulatedSender, , ] - expValue <- exp(stat_mat %*% parameterChoice) + expValue <- exp(stat_mat %*% parametersChoice) if (!isTwoMode) expValue[simulatedSender] <- 0 # In DyNAM, we use multinomial process for receiver selection simulatedReceiver <- sample(1:length(expValue), 1, prob = expValue) From ecf2778c4f5a950af7cd1417d51f4952be04d84d Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 17 Aug 2022 11:37:48 +0200 Subject: [PATCH 03/36] WIP gather --- R/functions_estimation_engine_c.r | 26 ++++++++------------------ 1 file changed, 8 insertions(+), 18 deletions(-) diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index a1ef32c..d8b4e53 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -152,11 +152,11 @@ estimate_c_int <- function( currentRCInterval <- 1 nAvgActors <- 0 if (!is.null(nodes$present)) { - nActors <- length(which(nodes$present == TRUE)) + nActors <- sum(nodes$present) } else { - nActors <- dim(nodes)[1] + nActors <- nrow(nodes) } - for (i in 1:nEvents) { + for (i in seq.int(nEvents)) { previoustime <- time if (statsList$orderEvents[[i]] == 1) { time <- time + statsList$intervals[[currentInterval]] @@ -165,21 +165,11 @@ estimate_c_int <- function( time <- time + statsList$rightCensoredIntervals[[currentRCInterval]] currentRCInterval <- currentRCInterval + 1 } - nplus <- intersect( - intersect( - which(compChange1$time > previoustime), - which(compChange1$time <= time) - ), - which(compChange1$replace == TRUE) - ) - nminus <- intersect( - intersect( - which(compChange1$time > previoustime), - which(compChange1$time <= time) - ), - which(compChange1$replace == FALSE) - ) - nActors <- nActors + length(nplus) - length(nminus) + nplus <- compChange1$time > previoustime & compChange1$time <= time & + compChange1$replace + nminus <- compChange1$time > previoustime & compChange1$time <= time & + !compChange1$replace + nActors <- nActors + sum(nplus) - sum(nminus) nAvgActors <- nAvgActors + nActors } nAvgActors <- nAvgActors / length(statsList$orderEvents) From adfccf7cf5d83dd2b4027b35723a819f1e38a991 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 18 Aug 2022 18:09:22 +0200 Subject: [PATCH 04/36] Export `GatherPreprocessing()`, refactor initial value intercept rate model --- DESCRIPTION | 5 +- NAMESPACE | 4 +- NEWS.md | 5 ++ R/functions_estimation.R | 4 +- R/functions_estimation_engine.R | 79 ++++++++-------- R/functions_estimation_engine_c.r | 71 ++++++++------- R/functions_gather.R | 16 ++-- R/functions_simulation.R | 67 ++++++++++---- R/functions_simulation_engine.R | 50 ++++------- R/functions_utility.R | 4 + R/testthat-helpers.R | 14 ++- man/GatherPreprocessing.Rd | 58 ++++++++++++ man/simulate.Rd | 90 +++++++++++++++++++ .../test-effects_preprocessing_DyNAM_choice.R | 3 +- 14 files changed, 328 insertions(+), 142 deletions(-) create mode 100644 man/GatherPreprocessing.Rd create mode 100644 man/simulate.Rd diff --git a/DESCRIPTION b/DESCRIPTION index 12be520..b4d41c6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,8 +2,8 @@ Encoding: UTF-8 Package: goldfish Type: Package Title: Statistical Network Models for Dynamic Network Data -Version: 1.6.3 -Date: 2022-08-09 +Version: 1.6.4 +Date: 2022-08-18 Authors@R: c(person("James", "Hollway", role = c("cre", "aut", "dtc"), email = "james.hollway@graduateinstitute.ch", comment = c("IHEID", ORCID = "0000-0002-8361-9647")), @@ -62,4 +62,3 @@ RoxygenNote: 7.2.1 Roxygen: list(markdown = TRUE) NeedsCompilation: yes Config/testthat/edition: 3 -Roxygen: list(markdown = TRUE) diff --git a/NAMESPACE b/NAMESPACE index 8b9b342..02d5e2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -19,6 +19,7 @@ S3method(simulate,formula) S3method(summary,result.goldfish) S3method(tidy,result.goldfish) S3method(vcov,result.goldfish) +export(GatherPreprocessing) export(defineDependentEvents) export(defineGlobalAttribute) export(defineGroups_interaction) @@ -51,7 +52,7 @@ importFrom(ggplot2,theme_minimal) importFrom(ggplot2,xlab) importFrom(ggplot2,ylab) importFrom(graphics,points) -importFrom(lifecycle,deprecated) +importFrom(lifecycle,badge) importFrom(methods,is) importFrom(stats,.vcov.aliased) importFrom(stats,AIC) @@ -70,6 +71,7 @@ importFrom(stats,na.omit) importFrom(stats,pnorm) importFrom(stats,printCoefmat) importFrom(stats,qnorm) +importFrom(stats,rexp) importFrom(stats,sd) importFrom(stats,time) importFrom(tibble,as_tibble) diff --git a/NEWS.md b/NEWS.md index 0649f3e..88678e6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,8 @@ +# goldfish 1.6.4 + +* Export `GatherPreprocessing()`. Experimental functionality. +* Introduces experimental functionality `simulation()`. + # goldfish 1.6.3 * Add DyNAM-i vignette. diff --git a/R/functions_estimation.R b/R/functions_estimation.R index cc9381e..aa85685 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -345,7 +345,7 @@ estimate.formula <- function( # gather_compute and default_c don't support returnEventProbabilities if (!is.null(estimationInit) && "returnEventProbabilities" %in% names(estimationInit)) { - if (estimationInit["returnEventProbabilities"] == TRUE && + if (estimationInit["returnEventProbabilities"] && engine != "default") { warning("engine = ", dQuote(engine), " doesn't support", dQuote("returnEventProbabilities"), @@ -710,7 +710,7 @@ estimate.formula <- function( } else { modelTypeCall <- "REM" } - } else if (model %in% c("DyNAM", "TriNAM", "DyNAMi")) { + } else if (model %in% c("DyNAM", "DyNAMi")) { if (subModel == "rate" && !hasIntercept) { modelTypeCall <- "DyNAM-M-Rate-ordered" } else if (subModel == "rate") { diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 465dd04..2063102 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -142,65 +142,60 @@ estimate_int <- function( if (!is.null(compChangeName2) && length(compChangeName2) > 0) compChange2 <- get(compChangeName2, envir = prepEnvir) # add prepEnvir + nEvents <- length(statsList$orderEvents) + ## ADD INTERCEPT # CHANGED MARION # replace first parameter with an initial estimate of the intercept - if (modelType %in% c("REM", "DyNAM-M-Rate") && addInterceptEffect) { + if (modelType %in% c("REM", "DyNAM-M-Rate") && addInterceptEffect && + is.null(initialParameters) && + (is.null(fixedParameters) || is.na(fixedParameters[1]))) { + totalTime <- sum(unlist(statsList$intervals), na.rm = TRUE) + sum(unlist(statsList$rightCensoredIntervals), na.rm = TRUE) - nEvents <- length(statsList$orderEvents) - # CHANGED MARION: remove the use of the events object - time <- statsList$eventTime[[1]] - previoustime <- time - currentInterval <- 1 - currentRCInterval <- 1 - nAvgActors <- 0 - + if (!is.null(nodes$present)) { - nActors <- length(which(nodes$present == TRUE)) + nActors <- sum(nodes$present) } else { - nActors <- dim(nodes)[1] + nActors <- nrow(nodes) } - - for (i in seq.int(nEvents)) { + + if (is.null(compChange1)) { + nAvgActors <- nActors + } else { + # CHANGED MARION: remove the use of the events object + time <- statsList$eventTime[[1]] previoustime <- time - if (statsList$orderEvents[[i]] == 1) { - time <- time + statsList$intervals[[currentInterval]] - currentInterval <- currentInterval + 1 - } else { - time <- time + statsList$rightCensoredIntervals[[currentRCInterval]] - currentRCInterval <- currentRCInterval + 1 + currentInterval <- 1 + currentRCInterval <- 1 + nAvgActors <- 0 + for (i in seq.int(nEvents)) { + previoustime <- time + if (statsList$orderEvents[[i]] == 1) { + time <- time + statsList$intervals[[currentInterval]] + currentInterval <- currentInterval + 1 + } else { + time <- time + statsList$rightCensoredIntervals[[currentRCInterval]] + currentRCInterval <- currentRCInterval + 1 + } + nplus <- compChange1$time > previoustime & compChange1$time <= time & + compChange1$replace + nminus <- compChange1$time > previoustime & compChange1$time <= time & + !compChange1$replace + nActors <- nActors + sum(nplus) - sum(nminus) + nAvgActors <- nAvgActors + nActors } - nplus <- intersect( - intersect( - which(compChange1$time > previoustime), - which(compChange1$time <= time) - ), - which(compChange1$replace == TRUE) - ) - nminus <- intersect( - intersect( - which(compChange1$time > previoustime), - which(compChange1$time <= time) - ), - which(compChange1$replace == FALSE) - ) - nActors <- nActors + length(nplus) - length(nminus) - nAvgActors <- nAvgActors + nActors - } - nAvgActors <- nAvgActors / length(statsList$orderEvents) - if (is.null(initialParameters) && - (is.null(fixedParameters) || is.na(fixedParameters[1]))) { - initialInterceptEstimate <- log(nEvents / totalTime / nAvgActors) - parameters[1] <- initialInterceptEstimate + nAvgActors <- nAvgActors / length(statsList$orderEvents) } + + initialInterceptEstimate <- log(nEvents / totalTime / nAvgActors) + parameters[1] <- initialInterceptEstimate } # ## SET VARIABLES BASED ON STATSLIST # CHANGED MARION - nEvents <- length(statsList$orderEvents) # number of events ## ESTIMATION: INITIALIZATION diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index d8b4e53..4109350 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -48,8 +48,8 @@ estimate_c_int <- function( nParams <- dim(statsList$initialStats)[3] - length(excludeParameters) + addInterceptEffect # - parameters <- initialParameters - if (is.null(initialParameters)) parameters <- rep(0, nParams) + if (is.null(initialParameters)) parameters <- rep(0, nParams) else + parameters <- initialParameters # deal with fixedParameters idUnfixedCompnents <- seq_len(nParams) idFixedCompnents <- NULL @@ -137,55 +137,60 @@ estimate_c_int <- function( if (!is.null(compChangeName2) && length(compChangeName2) > 0) compChange2 <- get(compChangeName2, envir = prepEnvir) # add prepEnvir - + nEvents <- length(statsList$orderEvents) + ## ADD INTERCEPT # CHANGED MARION # replace first parameter with an initial estimate of the intercept - if (modelTypeCall %in% c("REM","DyNAM-M-Rate") && addInterceptEffect) { + if (modelTypeCall %in% c("REM", "DyNAM-M-Rate") && addInterceptEffect && + is.null(initialParameters) && + (is.null(fixedParameters) || is.na(fixedParameters[1]))) { + totalTime <- sum(unlist(statsList$intervals), na.rm = TRUE) + sum(unlist(statsList$rightCensoredIntervals), na.rm = TRUE) - nEvents <- length(statsList$orderEvents) - # CHANGED MARION: remove the use of the events object - time <- statsList$eventTime[[1]] - previoustime <- time - currentInterval <- 1 - currentRCInterval <- 1 - nAvgActors <- 0 + if (!is.null(nodes$present)) { nActors <- sum(nodes$present) } else { nActors <- nrow(nodes) } - for (i in seq.int(nEvents)) { + + if (is.null(compChange1)) { + nAvgActors <- nActors + } else { + # CHANGED MARION: remove the use of the events object + time <- statsList$eventTime[[1]] previoustime <- time - if (statsList$orderEvents[[i]] == 1) { - time <- time + statsList$intervals[[currentInterval]] - currentInterval <- currentInterval + 1 - } else { - time <- time + statsList$rightCensoredIntervals[[currentRCInterval]] - currentRCInterval <- currentRCInterval + 1 + currentInterval <- 1 + currentRCInterval <- 1 + nAvgActors <- 0 + for (i in seq.int(nEvents)) { + previoustime <- time + if (statsList$orderEvents[[i]] == 1) { + time <- time + statsList$intervals[[currentInterval]] + currentInterval <- currentInterval + 1 + } else { + time <- time + statsList$rightCensoredIntervals[[currentRCInterval]] + currentRCInterval <- currentRCInterval + 1 + } + nplus <- compChange1$time > previoustime & compChange1$time <= time & + compChange1$replace + nminus <- compChange1$time > previoustime & compChange1$time <= time & + !compChange1$replace + nActors <- nActors + sum(nplus) - sum(nminus) + nAvgActors <- nAvgActors + nActors } - nplus <- compChange1$time > previoustime & compChange1$time <= time & - compChange1$replace - nminus <- compChange1$time > previoustime & compChange1$time <= time & - !compChange1$replace - nActors <- nActors + sum(nplus) - sum(nminus) - nAvgActors <- nAvgActors + nActors + nAvgActors <- nAvgActors / length(statsList$orderEvents) } - nAvgActors <- nAvgActors / length(statsList$orderEvents) - if (is.null(initialParameters) && - (is.null(fixedParameters) || is.na(fixedParameters[1]))) { - initialInterceptEstimate <- log(nEvents / totalTime / nAvgActors) - parameters[1] <- initialInterceptEstimate - } - } + + initialInterceptEstimate <- log(nEvents / totalTime / nAvgActors) + parameters[1] <- initialInterceptEstimate + } # ## SET VARIABLES BASED ON STATSLIST # CHANGED MARION - nEvents <- length(statsList$orderEvents) # number of events - ## SET VARIABLES BASED ON STATSLIST twomode_or_reflexive <- (allowReflexive || isTwoMode) diff --git a/R/functions_gather.R b/R/functions_gather.R index db83e46..5a18cef 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -11,15 +11,18 @@ #' #' Preprocess is made with goldfish. #' -#' @param formula accepted by goldfish. Left side a dependent events object -#' @param model Look to `goldfish::estimate` documentation. `c('DyNAM', 'REM')` -#' @param subModel `goldfish::estimate`. `c('choice_coordination', 'choice')` +#' @param formula See [estimate()]. Left side a dependent events object defined +#' with [defineDependentEvents()] and right side effect parameters as described +#' in `vignette("goldfishEffects")`. +#' @param model See [estimate()]. Current version of gather works for +#' `c('DyNAM')` +#' @param subModel Current version supports `c('choice_coordination', 'choice')` #' @param preprocessArgs Additional preprocess arguments like `startTime`, -#' `endTime` and `opportunitiesList`. +#' `endTime` and `opportunitiesList`. See [estimate()]. #' @param progress Default `FALSE`. #' #' @return a list with the data and relevant information. -#' @noRd +#' @export #' #' @examples #' data("Fisheries_Treaties_6070") @@ -42,6 +45,7 @@ #' gatheredData <- GatherPreprocessing( #' createBilat ~ inertia(bilatnet) + trans(bilatnet) + tie(contignet) #' ) +#' GatherPreprocessing <- function( formula, model = c("DyNAM", "REM"), @@ -72,6 +76,8 @@ GatherPreprocessing <- function( warning(dQuote("GatherPreprocessing"), " doesn't implement yet the ", dQuote("opportunitiesList"), " functionality") } + + if (is.null(progress)) progress <- FALSE ### 1. PARSE the formula---- parsedformula <- parseFormula(formula) # envir = as.environment(-1) diff --git a/R/functions_simulation.R b/R/functions_simulation.R index fb6b070..da104e9 100644 --- a/R/functions_simulation.R +++ b/R/functions_simulation.R @@ -23,10 +23,24 @@ #' the given formulas and parameter vectors. Default to \code{100}. #' #' @export +#' @importFrom lifecycle badge #' #' @examples +#' 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) #' -#' +#' simulateEvents <- simulate( +#' formulaRate = callsDependent ~ 1 + indeg + outdeg, +#' parametersRate = c(-14, 0.76, 0.25), +#' formulaChoice = callsDependent ~ inertia + trans + recip + indeg, +#' parametersChoice = c(5.3, -0.05, 1.4, -0.16), +#' model = "DyNAM", subModel = "choice", +#' nEvents = 100 +#' ) #' simulate <- function(formulaRate, parametersRate, @@ -34,11 +48,7 @@ simulate <- function(formulaRate, parametersChoice = NULL, model = c("DyNAM", "REM"), subModel = c("choice", "choice_coordination"), - # estimationInit = NULL, - # preprocessingInit = NULL, - # preprocessingOnly = FALSE, - verbose = FALSE, - silent = FALSE, + progress = getOption("progress"), nEvents = 100) { UseMethod("simulate", formulaRate) } @@ -53,11 +63,7 @@ simulate.formula <- function(formulaRate, parametersChoice = NULL, model = c("DyNAM", "REM"), subModel = c("choice", "rate"), - # estimationInit = NULL, - # preprocessingInit = NULL, - # preprocessingOnly = FALSE, - verbose = FALSE, - silent = FALSE, + progress = getOption("progress"), nEvents = 100) { # CHECK INPUT @@ -83,13 +89,14 @@ simulate.formula <- function(formulaRate, stopifnot( inherits(formulaRate, "formula"), - inherits(formulaChoice, "formula"), + is.null(formulaChoice) || inherits(formulaChoice, "formula"), inherits(parametersRate, "numeric"), - inherits(parametersChoice, "numeric"), - inherits(verbose, "logical"), - inherits(silent, "logical"), + is.null(parametersChoice) || inherits(parametersChoice, "numeric"), + is.null(progress) || inherits(progress, "logical"), inherits(nEvents, "numeric") && nEvents > 0 ) + + if (is.null(progress)) progress <- FALSE ## 1.1 Preparing parsedformulaRate <- parseFormula(formulaRate) @@ -149,8 +156,20 @@ simulate.formula <- function(formulaRate, " a positive parameter value for it.", call. = FALSE) + # get node sets of dependent variable + nodes <- attr(get(parsedformulaRate$depName), "nodes") + isTwoMode <- FALSE + + # two-mode networks(2 kinds of nodes) + if (length(nodes) == 2) { + nodes2 <- nodes[2] + nodes <- nodes[1] + isTwoMode <- TRUE + } else { + nodes2 <- nodes + } # Simulating! - if (!silent) cat("Starting simulation\n") + if (progress) cat("Starting simulation\n") events <- simulate_engine( model = model, subModel = subModel, @@ -159,15 +178,25 @@ simulate.formula <- function(formulaRate, parametersChoice = parametersChoice, parsedformulaChoice = parsedformulaChoice, nEvents = nEvents, + nodes = nodes, + nodes2 = nodes2, + isTwoMode = isTwoMode, startTime = 0, endTime = NULL, rightCensored = FALSE, # ToDo: check - verbose = verbose, - silent = silent + progress = progress ) + nodes <- get(nodes, envir = environment()) + nodes2 <- get(nodes2, envir = environment()) # Styling the result - events <- data.frame(time = events[, 1], sender = as.character(actors$label[events[, 2]]), receiver = as.character(actors$label[events[, 3]]), increment = events[, 4], stringsAsFactors = FALSE) + events <- data.frame( + time = events[, 1], + sender = as.character(nodes$label[events[, 2]]), + receiver = as.character(nodes$label[events[, 3]]), + increment = events[, 4], + stringsAsFactors = FALSE + ) return(events) } diff --git a/R/functions_simulation_engine.R b/R/functions_simulation_engine.R index f578e30..2249f3f 100644 --- a/R/functions_simulation_engine.R +++ b/R/functions_simulation_engine.R @@ -9,7 +9,6 @@ #' #' @return an array with simulated events #' -#' @keywords internal #' @noRd simulate_engine <- function( model, @@ -27,26 +26,7 @@ simulate_engine <- function( startTime = 0, endTime = NULL, rightCensored = FALSE, - verbose = TRUE, - silent = FALSE) { - - prepEnvir <- environment() - - - - - # get node sets of dependent variable - nodes <- attr(get(parsedformulaRate$depName), "nodes") - isTwoMode <- FALSE - - # two-mode networks(2 kinds of nodes) - if (length(nodes) == 2) { - nodes2 <- nodes[2] - nodes <- nodes[1] - isTwoMode <- TRUE - } else { - nodes2 <- nodes - } + progress = FALSE) { ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not @@ -75,7 +55,7 @@ simulate_engine <- function( nEffectsRate <- length(effectsRate) nEffectsChoice <- length(effectsChoice) - if (!silent) cat("Initializing cache objects and statistical matrices.\n") + if (progress) cat("Initializing cache objects and statistical matrices.\n") # ToDo: Impute misssing data # startTime and endTime handling @@ -87,7 +67,7 @@ simulate_engine <- function( windowParameters = parsedformulaRate$windowParameters, n1 = n1, n2 = n2, model = model, subModel = "rate", - envir = prepEnvir + envir = envir ) # Initialize stat matrix for the choice model @@ -99,7 +79,7 @@ simulate_engine <- function( windowParameters = parsedformulaChoice$windowParameters, n1 = n1, n2 = n2, model, "choice", - envir = prepEnvir + envir = envir ) # the variable subModel is for the sender-deciding process. ToDo: check subModel <- "rate" @@ -130,7 +110,7 @@ simulate_engine <- function( showProgressBar <- FALSE # progressEndReached <- FALSE - if (!silent) { + if (progress) { cat("Simulating events.\n") showProgressBar <- TRUE # # how often print, max 50 prints @@ -156,7 +136,7 @@ simulate_engine <- function( removeFirst = FALSE) objectNameRate <- objTableRate$name objectRate <- getElementFromDataObjectTable( - objTableRate, envir = prepEnvir)[[1]] + objTableRate, envir = envir)[[1]] #### GENERATING EVENT # We consider only two types of model, REM and DyNAM, and don't consider DyNAM-MM @@ -193,7 +173,7 @@ simulate_engine <- function( updatesList <- getUpdates( event, effectsRate, effIdsRate, objectsEffectsLinkRate, isUndirectedNet, n1, n2, - isTwoMode, prepEnvir, "statCacheRate") + isTwoMode, envir, "statCacheRate") ### APPLYING UPDATES TO statMatRate # For sender for (id in effIdsRate) { @@ -209,7 +189,7 @@ simulate_engine <- function( updatesList <- getUpdates( event, effectsChoice, effIdsChoice, objectsEffectsLinkChoice, isUndirectedNet, n1, n2, - isTwoMode, prepEnvir, "statCacheChoice") + isTwoMode, envir, "statCacheChoice") ### APPLYING UPDATES TO statMatRate # For receiver for (id in effIdsChoice) { @@ -226,13 +206,13 @@ simulate_engine <- function( objectRate[simulatedSender, simulatedReceiver] <- objectRate[simulatedSender, simulatedReceiver] + 1 eval(parse(text = paste(objectNameRate, "<- objectRate")), - envir = prepEnvir) + envir = envir) } return(events) } - +#' @importFrom stats rexp generationREM <- function(statMatRate, parametersRate, n1, n2, isTwoMode) { n_parameters <- dim(statMatRate)[3] # +1 for intercept @@ -319,11 +299,11 @@ generationDyNAMChoice <- function( getUpdates <- function( event, effects, effIds, objectsEffectsLink, isUndirectedNet, n1, n2, - isTwoMode, prepEnvir, cacheName) { - # get the statCache from the prepEnvir + isTwoMode, envir, cacheName) { + # get the statCache from the envir # We does it in this way because we have to update the statCache in # the parent enviroment later. - statCache = get(cacheName, envir = prepEnvir) + statCache = get(cacheName, envir = envir) # define the return variable updatesList = list() @@ -334,7 +314,7 @@ getUpdates <- function( orderedNames <- names[order(objectsToPass)] orderedObjectTable <- getDataObjects(list(list("", orderedNames))) .objects <- getElementFromDataObjectTable( - orderedObjectTable, envir = prepEnvir) + orderedObjectTable, envir = envir) # identify class to feed effects functions objClass <- vapply(.objects, FUN = inherits, FUN.VALUE = integer(2), what = c("numeric", "matrix"), which = TRUE) > 0 @@ -390,7 +370,7 @@ getUpdates <- function( } #update the statCache - assign(cacheName, statCache, envir = prepEnvir) + assign(cacheName, statCache, envir = envir) #return updatesList return(updatesList) diff --git a/R/functions_utility.R b/R/functions_utility.R index df10b00..c2043b2 100644 --- a/R/functions_utility.R +++ b/R/functions_utility.R @@ -485,3 +485,7 @@ GetFixed <- function(object) { } else fixed <- rep(FALSE, length(object$parameters)) fixed } + +checkArgsEstimation <- function(variables) { + +} diff --git a/R/testthat-helpers.R b/R/testthat-helpers.R index e4df66e..53af44c 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -213,11 +213,17 @@ eventsIncrement <- data.frame( actorsEx <- data.frame( label = sprintf("Actor %d", 1:5), - present = rep(TRUE, 5), + present = c(rep(TRUE, 4), FALSE), attr1 = c(9.9, 0.1, 0.5, 0.45, 0.25), stringsAsFactors = FALSE ) +compChange <- data.frame( + node = sprintf("Actor %d", c(5, 4, 4, 1, 5, 1, 5)), + time = c(10, 12, 17, 26, 26, 30, 30), + replace = c(TRUE, FALSE, TRUE, FALSE, FALSE, TRUE, TRUE) +) + networkState <- matrix( c(0, 3, 0, 0, 0, 1, 0, 1, 1, 0, @@ -230,6 +236,12 @@ networkState <- matrix( ) # defining objects +actorsEx <- defineNodes(actorsEx) +actorsEx <- linkEvents( + x = actorsEx, + changeEvent = compChange, + attribute = "present") + networkState <- defineNetwork( matrix = networkState, nodes = actorsEx, directed = TRUE) diff --git a/man/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd new file mode 100644 index 0000000..9be53de --- /dev/null +++ b/man/GatherPreprocessing.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/functions_gather.R +\name{GatherPreprocessing} +\alias{GatherPreprocessing} +\title{Gather preprocess data from a formula} +\usage{ +GatherPreprocessing( + formula, + model = c("DyNAM", "REM"), + subModel = c("choice", "choice_coordination", "rate"), + preprocessArgs = NULL, + progress = getOption("progress") +) +} +\arguments{ +\item{formula}{See \code{\link[=estimate]{estimate()}}. Left side a dependent events object defined +with \code{\link[=defineDependentEvents]{defineDependentEvents()}} and right side effect parameters as described +in \code{vignette("goldfishEffects")}.} + +\item{model}{See \code{\link[=estimate]{estimate()}}. Current version of gather works for +\code{c('DyNAM')}} + +\item{subModel}{Current version supports \code{c('choice_coordination', 'choice')}} + +\item{preprocessArgs}{Additional preprocess arguments like \code{startTime}, +\code{endTime} and \code{opportunitiesList}. See \code{\link[=estimate]{estimate()}}.} + +\item{progress}{Default \code{FALSE}.} +} +\value{ +a list with the data and relevant information. +} +\description{ +Preprocess is made with goldfish. +} +\examples{ +data("Fisheries_Treaties_6070") +states <- defineNodes(states) +states <- linkEvents(states, sovchanges, attribute = "present") +states <- linkEvents(states, regchanges, attribute = "regime") +states <- linkEvents(states, gdpchanges, attribute = "gdp") + +bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) +bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) + +createBilat <- defineDependentEvents( + events = bilatchanges[bilatchanges$increment == 1, ], + nodes = states, defaultNetwork = bilatnet +) + +contignet <- defineNetwork(contignet, nodes = states, directed = FALSE) +contignet <- linkEvents(contignet, contigchanges, nodes = states) + +gatheredData <- GatherPreprocessing( + createBilat ~ inertia(bilatnet) + trans(bilatnet) + tie(contignet) +) + +} diff --git a/man/simulate.Rd b/man/simulate.Rd new file mode 100644 index 0000000..b49c770 --- /dev/null +++ b/man/simulate.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/functions_simulation.R +\name{simulate} +\alias{simulate} +\title{Simulate a sequence of events} +\usage{ +simulate( + formulaRate, + parametersRate, + formulaChoice = NULL, + parametersChoice = NULL, + model = c("DyNAM", "REM"), + subModel = c("choice", "choice_coordination"), + progress = getOption("progress"), + nEvents = 100 +) +} +\arguments{ +\item{formulaRate}{a formula as define in \code{\link{estimate}} with the +effects for the rate sub-model \code{subModel = "rate"}.} + +\item{parametersRate}{a numeric vector with the numerical values that +effects parameters on \code{formulaRate} should take during simulation.} + +\item{formulaChoice}{a formula as define in \code{\link{estimate}} with the +effects for the choice sub-model \code{subModel = "choice"}. +When \code{model = "REM"} this formula is not required.} + +\item{parametersChoice}{a numeric vector with the numerical values that +effects parameters on \code{formulaChoice} should take during simulation.} + +\item{model}{a character string defining the model type. +Current options include \code{"DyNAM"}, \code{"DyNAMi"} or \code{"REM"} +\describe{ +\item{DyNAM}{Dynamic Network Actor Models +(Stadtfeld, Hollway and Block, 2017 and Stadtfeld and Block, 2017)} +\item{DyNAMi}{Dynamic Network Actor Models for interactions +(Hoffman et al., 2020)} +\item{REM}{Relational Event Model (Butts, 2008)} +}} + +\item{subModel}{a character string defining the submodel type. +Current options include \code{"choice"}, \code{"rate"} or +\code{"choice_coordination"} +\describe{ +\item{choice}{a multinomial receiver choice model \code{model = "DyNAM"} +(Stadtfeld and Block, 2017), or the general Relational event model +\code{model = "REM"} (Butts, 2008). +A multinomial group choice model \code{model = "DyNAMi"} (Hoffman et al., 2020)} +\item{choice_coordination}{a multinomial-multinomial model for coordination +ties \code{model = "DyNAM"} (Stadtfeld, Hollway and Block, 2017)} +\item{rate}{A individual activity rates model \code{model = "DyNAM"} +(Stadtfeld and Block, 2017). +Two rate models, one for individuals joining groups and one for individuals +leaving groups, jointly estimated \code{model = "DyNAMi"}(Hoffman et al., 2020)} +}} + +\item{progress}{logical indicating whether should print a minimal output +to the console of the progress of the preprocessing and estimation processes.} + +\item{nEvents}{integer with the number of events to simulate from +the given formulas and parameter vectors. Default to \code{100}.} +} +\description{ +\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} + +Experimental version of the simulate functionality. +Current version \strong{only} simulate endogenous events for a DyNAM model +with rate and choice submodel specifications. +It's restricted to simulate a fix length sequence, +oppose to the general case of simulate events until end time is reached. +} +\examples{ +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) + +simulateEvents <- simulate( + formulaRate = callsDependent ~ 1 + indeg + outdeg, + parametersRate = c(-14, 0.76, 0.25), + formulaChoice = callsDependent ~ inertia + trans + recip + indeg, + parametersChoice = c(5.3, -0.05, 1.4, -0.16), + model = "DyNAM", subModel = "choice", + nEvents = 100 +) + +} diff --git a/tests/testthat/test-effects_preprocessing_DyNAM_choice.R b/tests/testthat/test-effects_preprocessing_DyNAM_choice.R index 6e6506a..91e0aaf 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAM_choice.R +++ b/tests/testthat/test-effects_preprocessing_DyNAM_choice.R @@ -3,7 +3,8 @@ test_that( "inertia/tie compute correct preprocessing objects weighted", { preproData <- estimate( - depNetwork ~ inertia(networkState, weighted = TRUE) + tie(networkExog, weighted = TRUE), + depNetwork ~ inertia(networkState, weighted = TRUE) + + tie(networkExog, weighted = TRUE), model = "DyNAM", subModel = "choice", # modelType = "DyNAM-M" preprocessingOnly = TRUE ) From e80d17db79b541f185ea8962a22942a8dfc68780 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Fri, 30 Sep 2022 16:28:10 +0200 Subject: [PATCH 05/36] Add `GatherPreprocessing` testing plus minor improvements --- R/functions_estimation.R | 3 +- R/functions_gather.R | 37 ++++++++++++++++-------- R/functions_parsing.R | 2 +- tests/testthat/test-functions_gather.R | 39 ++++++++++++++++++++++++++ 4 files changed, 68 insertions(+), 13 deletions(-) create mode 100644 tests/testthat/test-functions_gather.R diff --git a/R/functions_estimation.R b/R/functions_estimation.R index aa85685..20a2b33 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -295,7 +295,8 @@ estimate.formula <- function( # envir <- environment() ### check model and subModel - checkModelPar(model, subModel, + checkModelPar( + model, subModel, modelList = c("DyNAM", "REM", "DyNAMi"), subModelList = list( DyNAM = c("choice", "rate", "choice_coordination"), diff --git a/R/functions_gather.R b/R/functions_gather.R index 7588551..06d3d60 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -53,7 +53,10 @@ GatherPreprocessing <- function( preprocessArgs = NULL, progress = getOption("progress")) { - model <- match.arg(model) + model <- match.arg( + arg = if (length(model) > 1) model[1] else model, + choices = c("DyNAM", "REM", "DyNAMRE") + ) subModel <- match.arg(subModel) if (!is.null(preprocessArgs)) { @@ -62,7 +65,7 @@ GatherPreprocessing <- function( "startTime", "endTime", "opportunitiesList" ) - if (any(!parInit)) { + if (any(!parInit)) warning( "The parameter: ", paste(names(preprocessArgs)[!parInit], collapse = ", "), @@ -70,17 +73,17 @@ GatherPreprocessing <- function( "See the documentation for the list of available parameters", call. = FALSE, immediate. = TRUE ) - } - if (!is.null(preprocessArgs["opportunitiesList"])) + if (!is.null(preprocessArgs[["opportunitiesList"]])) warning(dQuote("GatherPreprocessing"), " doesn't implement yet the ", dQuote("opportunitiesList"), " functionality") } if (is.null(progress)) progress <- FALSE + envir <- new.env() ### 1. PARSE the formula---- - parsedformula <- parseFormula(formula) # envir = as.environment(-1) + parsedformula <- parseFormula(formula, envir = envir) rhsNames <- parsedformula$rhsNames depName <- parsedformula$depName hasIntercept <- parsedformula$hasIntercept @@ -93,6 +96,11 @@ GatherPreprocessing <- function( call. = FALSE, immediate. = TRUE) # Model-specific preprocessing initialization + if (model == "DyNAMRE") { + if (subModel == "choice") model <- "REM" else model <- "DyNAM" + altModel <- "DyNAMRE" + } else altModel <- NULL + if (model %in% c("DyNAM", "DyNAMi") && subModel %in% c("choice", "choice_coordination") && parsedformula$hasIntercept) { @@ -127,8 +135,6 @@ GatherPreprocessing <- function( ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not # enviroment from which get the objects - envir <- environment() - effects <- createEffectsFunctions( parsedformula$rhsNames, model, subModel, envir = envir) # Get links between objects and effects for printing results @@ -164,7 +170,8 @@ GatherPreprocessing <- function( startTime = preprocessArgs[["startTime"]], endTime = preprocessArgs[["endTime"]], rightCensored = rightCensored, - progress = progress + progress = progress, + prepEnvir = envir ) # # 3.3 additional processing to flat array objects @@ -175,7 +182,8 @@ GatherPreprocessing <- function( reduceMatrixToVector <- FALSE reduceArrayToMatrix <- FALSE - modelTypeCall <- "NON-VALID" + + if (!is.null(altModel) & subModel == "choice") model <- "DyNAM" if (model == "REM") { if (!parsedformula$hasIntercept) { @@ -198,8 +206,6 @@ GatherPreprocessing <- function( } } - if (modelTypeCall == "NON-VALID") stop("Invalid model", modelTypeCall) - # from estimate_c_init preprocessingStat <- modifyStatisticsList( preprocessingStat, modelTypeCall, @@ -320,6 +326,14 @@ GatherPreprocessing <- function( impute = FALSE ) + ## Add additional information + gatheredData$sender <- nodes$label[preprocessingStat$eventSender] + if (model == "REM" || (model == "DyNAM" & subModel != "rate")) { + gatheredData$receiver <- nodes2$label[preprocessingStat$eventReceiver] + } + + gatheredData$selected <- gatheredData$selected + 1 + ### 4. PREPARE PRINTING---- # functions_utility.R effectDescription <- @@ -330,6 +344,7 @@ GatherPreprocessing <- function( gatheredData$namesEffects <- namesEffects colnames(gatheredData$stat_all_events) <- namesEffects + gatheredData$effectDescription <- effectDescription return(gatheredData) } diff --git a/R/functions_parsing.R b/R/functions_parsing.R index 0a36af4..cb2a143 100644 --- a/R/functions_parsing.R +++ b/R/functions_parsing.R @@ -82,7 +82,7 @@ parseFormula <- function(formula, envir = new.env()) { # check right side: type = c("ego", "alter") typeParameter <- lapply(rhsNames, function(x) { v <- getElement(x, "type") - ifelse(!is.null(v), v, "") + ifelse(!is.null(v), eval(parse(text = v), envir = envir), "") }) # check right side: transformFun & aggregateFun getFunName <- function(x, which) { diff --git a/tests/testthat/test-functions_gather.R b/tests/testthat/test-functions_gather.R new file mode 100644 index 0000000..1b81c86 --- /dev/null +++ b/tests/testthat/test-functions_gather.R @@ -0,0 +1,39 @@ +test_that("Args check", { + expect_warning( + GatherPreprocessing( + depNetwork ~ inertia(networkState), + preprocessArgs = list(smth = 1)) + ) + expect_warning( + GatherPreprocessing( + depNetwork ~ inertia(networkState), + preprocessArgs = list(opportunitiesList = 1)) + ) + expect_error( + GatherPreprocessing(depNetwork ~ inertia(networkState, ignoreRep = TRUE)) + ) + expect_warning( + GatherPreprocessing(depNetwork ~ 1 + inertia(networkState)) + ) + expect_error( + GatherPreprocessing(depNetwork ~ 1 + inertia(networkState), model = "smh") + ) + expect_error( + GatherPreprocessing( + depNetwork ~ 1 + inertia(networkState), subModel = "smh" + ) + ) +}) +test_that("Printing", { + expect_output( + GatherPreprocessing(depNetwork ~ inertia(networkState), progress = TRUE), + "Preprocessing events." + ) +}) +test_that("Output", { + out <- GatherPreprocessing(depNetwork ~ inertia(networkState)) + expect_type(out, "list") + expect_length(out, 7) + + +}) From f7087e2359a110dbb55876301ebcba8104c2d846 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Mon, 3 Oct 2022 15:05:04 +0200 Subject: [PATCH 06/36] Add `envir` argument to `GatherPreprocessing()` --- R/functions_gather.R | 15 +++++++++++++-- man/GatherPreprocessing.Rd | 5 ++++- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/R/functions_gather.R b/R/functions_gather.R index 06d3d60..2be7c02 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -20,6 +20,7 @@ #' @param preprocessArgs Additional preprocess arguments like `startTime`, #' `endTime` and `opportunitiesList`. See [estimate()]. #' @param progress Default `FALSE`. +#' @param envir an `environment` where `formula` objects are available. #' #' @return a list with the data and relevant information. #' @export @@ -51,13 +52,24 @@ GatherPreprocessing <- function( model = c("DyNAM", "REM"), subModel = c("choice", "choice_coordination", "rate"), preprocessArgs = NULL, - progress = getOption("progress")) { + progress = getOption("progress"), + envir = new.env()) { model <- match.arg( arg = if (length(model) > 1) model[1] else model, choices = c("DyNAM", "REM", "DyNAMRE") ) subModel <- match.arg(subModel) + + checkModelPar( + model = model, subModel = subModel, + modelList = c("DyNAM", "REM", "DyNAMRE"), + subModelList = list( + DyNAM = c("choice", "rate", "choice_coordination"), + REM = "choice", + DyNAMRE = c("choice", "choice_coordination") + ) + ) if (!is.null(preprocessArgs)) { parInit <- names(preprocessArgs) %in% @@ -81,7 +93,6 @@ GatherPreprocessing <- function( if (is.null(progress)) progress <- FALSE - envir <- new.env() ### 1. PARSE the formula---- parsedformula <- parseFormula(formula, envir = envir) rhsNames <- parsedformula$rhsNames diff --git a/man/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd index 9be53de..a7e5df5 100644 --- a/man/GatherPreprocessing.Rd +++ b/man/GatherPreprocessing.Rd @@ -9,7 +9,8 @@ GatherPreprocessing( model = c("DyNAM", "REM"), subModel = c("choice", "choice_coordination", "rate"), preprocessArgs = NULL, - progress = getOption("progress") + progress = getOption("progress"), + envir = new.env() ) } \arguments{ @@ -26,6 +27,8 @@ in \code{vignette("goldfishEffects")}.} \code{endTime} and \code{opportunitiesList}. See \code{\link[=estimate]{estimate()}}.} \item{progress}{Default \code{FALSE}.} + +\item{envir}{an \code{environment} where \code{formula} objects are available.} } \value{ a list with the data and relevant information. From c34807ef2b0eb2d5c733d556a579c9b51b2e7258 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 13 Oct 2022 10:44:38 +0200 Subject: [PATCH 07/36] Debug Gather Preprocessing for rate submodel --- R/functions_estimation_engine_c.r | 5 +-- R/functions_gather.R | 47 ++++++++++++++++++-------- tests/testthat/test-functions_gather.R | 2 +- 3 files changed, 36 insertions(+), 18 deletions(-) diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index 013960f..3463229 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -114,7 +114,8 @@ estimate_c_int <- function( # CHANGED MARION: updated function # for rate model with intercept, add a table of all 1 to the # statsList$initStats - statsList <- modifyStatisticsList(statsList, modelTypeCall, + statsList <- modifyStatisticsList( + statsList, modelTypeCall, reduceMatrixToVector = reduceMatrixToVector, reduceArrayToMatrix = reduceArrayToMatrix, excludeParameters = excludeParameters, @@ -524,7 +525,7 @@ estimate_c_int <- function( ## ESTIMATION: END # calculate standard errors - # the variance for the fixed compenents should be 0 + # the variance for the fixed components should be 0 stdErrors <- rep(0,nParams) stdErrors[idUnfixedCompnents] <- sqrt(diag(inverseInformationUnfixed)) diff --git a/R/functions_gather.R b/R/functions_gather.R index 2be7c02..0cad99f 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -187,9 +187,6 @@ GatherPreprocessing <- function( # # 3.3 additional processing to flat array objects allowReflexive <- isTwoMode - dimensions <- dim(preprocessingStat$initialStats) - - nParams <- dimensions[3] + parsedformula$hasIntercept reduceMatrixToVector <- FALSE reduceArrayToMatrix <- FALSE @@ -226,16 +223,17 @@ GatherPreprocessing <- function( addInterceptEffect = parsedformula$hasIntercept ) - nEvents <- length(preprocessingStat$orderEvents) # number of events + # nEvents <- length(preprocessingStat$orderEvents)# number of events nodes <- get(.nodes) nodes2 <- get(.nodes2) ## SET VARIABLES BASED ON STATSLIST twomode_or_reflexive <- (allowReflexive || isTwoMode) - n_events <- length(preprocessingStat$orderEvents) + # n_events <- length(preprocessingStat$orderEvents) + dimensions <- dim(preprocessingStat$initialStats) n_parameters <- dimensions[3] n_actors1 <- dimensions[1] - n_actors2 <- nActors <- dimensions[2] + n_actors2 <- dimensions[2] ## CONVERT UPDATES INTO THE FORMAT ACCEPTED BY C FUNCTIONS temp <- convert_change(preprocessingStat$dependentStatsChange) @@ -245,7 +243,8 @@ GatherPreprocessing <- function( stat_mat_update[3, ] <- stat_mat_update[3, ] + 1 } # Convert the right-censored events - # which will be a zero matrice and a zero vector if there's no right-censored event + # which will be a zero matrice and a zero vector + # if there's no right-censored event if (length(preprocessingStat$rightCensoredIntervals) == 0) { stat_mat_rightcensored_update <- matrix(0, 4, 1) stat_mat_rightcensored_update_pointer <- numeric(1) @@ -254,13 +253,18 @@ GatherPreprocessing <- function( stat_mat_rightcensored_update <- temp$statMatUpdate stat_mat_rightcensored_update_pointer <- temp$statMatUpdatePointer if (parsedformula$hasIntercept) { - stat_mat_rightcensored_update[3, ] <- stat_mat_rightcensored_update[3, ] + 1 + stat_mat_rightcensored_update[3, ] <- + stat_mat_rightcensored_update[3, ] + 1 } } ## CONVERT COMPOSITION CHANGES INTO THE FORMAT ACCEPTED BY C FUNCTIONS - compChangeName1 <- attr(nodes, "events")["present" == attr(nodes, "dynamicAttribute")] - compChangeName2 <- attr(nodes2, "events")["present" == attr(nodes2, "dynamicAttribute")] + compChangeName1 <- attr(nodes, "events")[ + "present" == attr(nodes, "dynamicAttribute") + ] + compChangeName2 <- attr(nodes2, "events")[ + "present" == attr(nodes2, "dynamicAttribute") + ] if (!is.null(compChangeName1) && length(compChangeName1) > 0) { temp <- get(compChangeName1) temp <- sanitizeEvents(temp, nodes) @@ -296,8 +300,8 @@ GatherPreprocessing <- function( } ## CONVERT TYPES OF EVENTS AND TIMESPANS INTO THE FORMAT ACCEPTED BY C FUNCTIONS + is_dependent <- preprocessingStat$orderEvents == 1 if (modelTypeCall %in% c("DyNAM-M-Rate", "REM")) { - is_dependent <- preprocessingStat$orderEvents == 1 timespan <- length(is_dependent) timespan[is_dependent] <- preprocessingStat$intervals timespan[(!is_dependent)] <- preprocessingStat$rightCensoredIntervals @@ -306,7 +310,13 @@ GatherPreprocessing <- function( } ## CONVERT INFOS OF SENDERS AND RECEIVERS INTO THE FORMAT ACCEPTED BY C FUNCTIONS - event_mat <- t(matrix(c(unlist(preprocessingStat$eventSender), unlist(preprocessingStat$eventReceiver)), ncol = 2)) + event_mat <- t(matrix( + c( + unlist(preprocessingStat$eventSender), + unlist(preprocessingStat$eventReceiver) + ), + ncol = 2 + )) ## CONVERT THE INITIALIZATION OF DATA MATRIX INTO THE FORMAT ACCEPTED BY C FUNCTIONS stat_mat_init <- matrix(0, n_actors1 * n_actors2, n_parameters) @@ -339,11 +349,18 @@ GatherPreprocessing <- function( ## Add additional information gatheredData$sender <- nodes$label[preprocessingStat$eventSender] - if (model == "REM" || (model == "DyNAM" & subModel != "rate")) { - gatheredData$receiver <- nodes2$label[preprocessingStat$eventReceiver] + if (model == "REM" || (model == "DyNAM" && subModel != "rate")) { + gatheredData$receiver <- + nodes2$label[preprocessingStat$eventReceiver] + } else if (model == "DyNAM" && subModel == "rate" && + parsedformula$hasIntercept) { + gatheredData$timespan <- timespan + gatheredData$isDependent <- is_dependent } + gatheredData$hasIntercept <- parsedformula$hasIntercept - gatheredData$selected <- gatheredData$selected + 1 + gatheredData$selected <- gatheredData$selected + + if (parsedformula$hasIntercept) (1 * is_dependent) else 1 ### 4. PREPARE PRINTING---- # functions_utility.R diff --git a/tests/testthat/test-functions_gather.R b/tests/testthat/test-functions_gather.R index 1b81c86..0ef82a9 100644 --- a/tests/testthat/test-functions_gather.R +++ b/tests/testthat/test-functions_gather.R @@ -33,7 +33,7 @@ test_that("Printing", { test_that("Output", { out <- GatherPreprocessing(depNetwork ~ inertia(networkState)) expect_type(out, "list") - expect_length(out, 7) + expect_length(out, 8) }) From 81c17f1394895837f21edbc3f9eef721c6eb0322 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 21 Jun 2023 11:35:51 +0200 Subject: [PATCH 08/36] Styling code --- R/functions_checks.R | 11 +- R/functions_data.R | 42 +++-- R/functions_effects_DyNAM_choice.R | 29 ++-- ...ctions_effects_DyNAM_choice_coordination.R | 99 ++++++------ R/functions_effects_DyNAM_rate.R | 136 +++++++++------- R/functions_effects_DyNAMi_choice.R | 3 +- R/functions_effects_DyNAMi_rate.R | 3 +- R/functions_effects_REM.R | 135 ++++++++++------ R/functions_estimation.R | 16 +- R/functions_estimation_engine.R | 9 +- R/functions_parsing.R | 120 +++++++++----- R/functions_preprocessing.R | 2 +- R/testthat-helpers.R | 148 +++++++++++------- .../test-effects_preprocessing_DyNAM_rate.R | 88 ++++++----- 14 files changed, 512 insertions(+), 329 deletions(-) diff --git a/R/functions_checks.R b/R/functions_checks.R index ac643e7..673fb95 100644 --- a/R/functions_checks.R +++ b/R/functions_checks.R @@ -510,8 +510,9 @@ checkGlobalAttribute <- function(global) { # IF it's associated to a network # - a column "replace" OR "increment" of characters or numerics or booleans -checkEvents <- function(object, ...) +checkEvents <- function(object, ...) { UseMethod("checkEvents", object) +} ## Nodesets and Events # When adding an event to a nodeset: @@ -607,7 +608,7 @@ checkEvents.nodes.goldfish <- function( if (!is.null(attribute)) { if (is.null(object[[attribute]])) stop( - "The attribute ", sQuote(attribute), + "The attribute ", dQuote(attribute), " doesn't exist in the nodeset." ) @@ -618,7 +619,7 @@ checkEvents.nodes.goldfish <- function( if (!all(checkClasses(object[[attribute]], classEven)) && !all(checkClasses(eventUpdate, classAttr))) stop( - "The type of the attribute ", sQuote(attribute), + "The type of the attribute ", dQuote(attribute), " is incompatible with the associated event list.", "\n\tattribute class: ", paste(classAttr, collapse = ", "), "\n\tevent (increment/replace) class: ", @@ -628,11 +629,11 @@ checkEvents.nodes.goldfish <- function( # if (all(events$node %in% object$label) && is.integer(events$node) && # (min(events$node) < 1 || max(events$node) > dim(object)[1])) # stop( - # "Nodes indexes for the attribute ", sQuote(attribute), " are incorrect." + # "Nodes indexes for the attribute ", dQuote(attribute), " are incorrect." # ) if (!all(events$node %in% object$label)) stop( - "Nodes labels for the attribute ", sQuote(attribute), " are incorrect." + "Nodes labels for the attribute ", dQuote(attribute), " are incorrect." ) return(TRUE) diff --git a/R/functions_data.R b/R/functions_data.R index ae13cf1..bd76b97 100644 --- a/R/functions_data.R +++ b/R/functions_data.R @@ -788,21 +788,26 @@ defineGlobalAttribute <- function(global) { #' callNetwork <- linkEvents( #' x = callNetwork, changeEvent = calls, nodes = actors #' ) -linkEvents <- function(x, ...) +linkEvents <- function(x, ...) { UseMethod("linkEvents", x) +} #' @rdname linkEvents #' @export linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { # check input types if (!(is.character(attribute) && length(attribute) == 1)) - stop("Invalid argument attributes: this function expects a character attribute value.") - if (!is.data.frame(changeEvents)) stop("Invalid argument changeEvents: this function expects a data frame.") + stop("Invalid argument attributes:", + " this function expects a character attribute value.") + + if (!is.data.frame(changeEvents)) + stop("Invalid argument changeEvents: this function expects a data frame.") # data frame has to be passed as a variable name linkEnvir <- environment() if (!is.name(substitute(changeEvents, linkEnvir))) - stop("Parameter change events has to be the name of a data frame (rather than a data frame)") + stop("Parameter change events has to be the name of a data frame", + " (rather than a data frame)") # link data # initial <- object @@ -810,7 +815,8 @@ linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { objEventCurr <- as.character(substitute(changeEvents, linkEnvir)) if (length(objEventsPrev) > 0 && objEventCurr %in% objEventsPrev) { - warning("The event ", sQuote(objEventCurr), " were already linked to this object.") + warning("The event ", dQuote(objEventCurr), + " were already linked to this object.") return(x) } @@ -837,19 +843,25 @@ linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { linkEvents.network.goldfish <- function(x, changeEvents, nodes = NULL, nodes2 = NULL, ...) { # check input types - if (is.null(nodes)) stop("Invalid argument nodes: a network is specified, this function expects an argument nodes.") - if (!is.data.frame(changeEvents)) stop("Invalid argument changeEvents: this function expects a data frame.") + if (is.null(nodes)) + stop("Invalid argument nodes: a network is specified,", + "this function expects an argument nodes.") + if (!is.data.frame(changeEvents)) + stop("Invalid argument changeEvents: this function expects a data frame.") isTwoMode <- !is.null(nodes2) if (!is.data.frame(nodes)) - stop("Invalid argument nodes: this function expects a nodeset (data frame or nodes.goldfish object).") + stop("Invalid argument nodes: this function expects a nodeset", + " (data frame or nodes.goldfish object).") if (isTwoMode && !is.data.frame(nodes2)) - stop("Invalid argument nodes2: this function expects a nodeset (data frame or nodes.goldfish object).") + stop("Invalid argument nodes2: this function expects a nodeset", + " (data frame or nodes.goldfish object).") # data frame has to be passed as a variable name linkEnvir <- environment() if (!is.name(substitute(changeEvents, linkEnvir))) - stop("Parameter change events has to be the name of a data frame (rather than a data frame)") + stop("Parameter change events has to be the name of a data frame", + " (rather than a data frame)") # link data # initial <- x @@ -857,7 +869,8 @@ linkEvents.network.goldfish <- function(x, changeEvents, objEventCurr <- as.character(substitute(changeEvents, linkEnvir)) if (length(objEventsPrev) > 0 && objEventCurr %in% objEventsPrev) { - warning("The event ", sQuote(objEventCurr), " were already linked to this object.") + warning("The event ", dQuote(objEventCurr), + " were already linked to this object.") return(x) } attr(x, "events") <- c(objEventsPrev, objEventCurr) @@ -879,6 +892,9 @@ linkEvents.network.goldfish <- function(x, changeEvents, #' @rdname linkEvents #' @export -linkEvents.default <- function(x, ...) +linkEvents.default <- function(x, ...) { if (!any(checkClasses(x, c("nodes.goldfish", "network.goldfish")))) - stop('Invalid argument object: this function expects either a "nodes.goldfish" or a "network.goldfish" object.') + stop("Invalid argument object: this function expects either a ", + dQuote("nodes.goldfish"), " or a ", dQuote("network.goldfish"), + " object.") +} diff --git a/R/functions_effects_DyNAM_choice.R b/R/functions_effects_DyNAM_choice.R index 4b838de..09c7898 100644 --- a/R/functions_effects_DyNAM_choice.R +++ b/R/functions_effects_DyNAM_choice.R @@ -1,8 +1,9 @@ # define methods ---------------------------------------------------------- # init the statistical matrix: list(cache = NULL||list, stat = matrix) init_DyNAM_choice <- function(effectFun, network, attribute, n1, n2, - cache = NULL) + cache = NULL) { UseMethod("init_DyNAM_choice") +} # default ----------------------------------------------------------------- init_DyNAM_choice.default <- function( @@ -14,7 +15,8 @@ init_DyNAM_choice.default <- function( # print(match.call()) if (is.null(network) && is.null(attribute)) { # this check could be unnecessary - stop("the effect function doesn't specify neither a network nor an attribute as argument") + stop("the effect function doesn't specify neither a network", + " nor an attribute as argument") } # if multiple networks, attributes or combination of both are specified. @@ -273,20 +275,22 @@ update_DyNAM_choice_tie <- function( } # inertia ----------------------------------------------------------------- -init_DyNAM_choice.inertia <- function(effectFun, network, window, n1, n2) +init_DyNAM_choice.inertia <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.tie(effectFun = effectFun, network = network, window = window, n1 = n1, n2 = n2) +} #' @aliases inertia update_DyNAM_choice_inertia <- function( network, sender, receiver, replace, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, weighted = weighted, transformFun = transformFun ) +} # indeg ------------------------------------------------------------------- #' init stat matrix indegree using cache alter @@ -370,13 +374,14 @@ update_DyNAM_choice_indeg <- function( sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_REM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun, type = "alter" ) +} # outdeg ------------------------------------------------------------------- #' init stat matrix outdegree using cache alter @@ -461,14 +466,14 @@ update_DyNAM_choice_outdeg <- function( sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_REM_choice_outdeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun, type = "alter" ) - +} # recip ------------------------------------------------------------------- #' init stat matrix reciprocity @@ -624,12 +629,13 @@ update_DyNAM_choice_nodeTrans <- function( cache, n1, n2, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_REM_choice_nodeTrans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, transformFun = transformFun, type = "alter") +} # Closure effects -------------------------------------------------------------- # trans ------------------------------------------------------------------- @@ -2402,7 +2408,7 @@ update_DyNAM_choice_tertius <- function( isTwoMode = FALSE, n1 = n1, n2 = n2, transformFun = identity, - aggregateFun = function(x) mean(x, na.rm = TRUE)) + aggregateFun = function(x) mean(x, na.rm = TRUE)) { update_REM_choice_tertius( network = network, attribute = attribute, @@ -2416,6 +2422,8 @@ update_DyNAM_choice_tertius <- function( transformFun = transformFun, aggregateFun = aggregateFun, type = "alter" ) +} + # tertiusDiff ---------------------------------------------------------------- #' init stat matrix tertius-diff using cache #' @@ -2657,7 +2665,7 @@ update_DyNAM_choice_tertiusDiff <- function( rbind, lapply( nodesChange, - function(x) + \(x) { cbind( node1 = if (isTwoMode) seq_len(n1) else third(n1, x), node2 = x, @@ -2666,6 +2674,7 @@ update_DyNAM_choice_tertiusDiff <- function( transformFun, (if (isTwoMode) attribute else attribute[-x]) - cache[x]) ) + } ) ) ) diff --git a/R/functions_effects_DyNAM_choice_coordination.R b/R/functions_effects_DyNAM_choice_coordination.R index 13d12d0..dc2f684 100644 --- a/R/functions_effects_DyNAM_choice_coordination.R +++ b/R/functions_effects_DyNAM_choice_coordination.R @@ -1,8 +1,9 @@ # define methods ---------------------------------------------------------- # init the statistical matrix init_DyNAM_choice_coordination <- function( - effectFun, network, attribute, n1, n2, cache = NULL) + effectFun, network, attribute, n1, n2, cache = NULL) { UseMethod("init_DyNAM_choice", effectFun) +} # Structural effects ------------------------------------------------------ # tie --------------------------------------------------------------------- @@ -10,38 +11,39 @@ init_DyNAM_choice_coordination <- function( update_DyNAM_choice_coordination_tie <- function( network, sender, receiver, replace, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, weighted = weighted, transformFun = transformFun ) - +} # inertia ----------------------------------------------------------------- update_DyNAM_choice_coordination_inertia <- function( network, sender, receiver, replace, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_coordination_tie( network = network, sender = sender, receiver = receiver, replace = replace, weighted = weighted, transformFun = transformFun ) - +} # indeg ------------------------------------------------------------------- update_DyNAM_choice_coordination_indeg <- function( network, sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun ) +} # outdeg ------------------------------------------------------------------- # update_DyNAM_choice_coordination_outdeg <- function( @@ -64,13 +66,13 @@ update_DyNAM_choice_coordination_trans <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_DyNAM_choice_trans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, isTwoMode = isTwoMode, transformFun = transformFun ) - +} # mixedTrans -------------------------------------------------------------- update_DyNAM_choice_coordination_mixedTrans <- function( @@ -79,13 +81,14 @@ update_DyNAM_choice_coordination_mixedTrans <- function( receiver, replace, netUpdate, cache, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_DyNAM_choice_mixedTrans( network = network, sender = sender, receiver = receiver, replace = replace, netUpdate = netUpdate, cache = cache, isTwoMode = isTwoMode, transformFun = transformFun ) +} # four -------------------------------------------------------------------- update_DyNAM_choice_coordination_four <- function( @@ -93,7 +96,7 @@ update_DyNAM_choice_coordination_four <- function( sender, receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_DyNAM_choice_four( network = network, sender = sender, receiver = receiver, replace = replace, @@ -101,33 +104,35 @@ update_DyNAM_choice_coordination_four <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} # tertius ---------------------------------------------------------------- update_DyNAM_choice_coordination_tertius <- function( - network, - attribute, - sender = NULL, - receiver = NULL, - node = NULL, - replace, - cache, - isTwoMode = FALSE, - n1 = n1, n2 = n2, - transformFun = identity, - aggregateFun = function(x) mean(x, na.rm = TRUE)) -update_DyNAM_choice_tertius( - network = network, - attribute = attribute, - sender = sender, - receiver = receiver, - node = node, - replace = replace, - cache = cache, - isTwoMode = isTwoMode, - n1 = n1, n2 = n2, - transformFun = transformFun, - aggregateFun = aggregateFun -) + network, + attribute, + sender = NULL, + receiver = NULL, + node = NULL, + replace, + cache, + isTwoMode = FALSE, + n1 = n1, n2 = n2, + transformFun = identity, + aggregateFun = function(x) mean(x, na.rm = TRUE)) { + update_DyNAM_choice_tertius( + network = network, + attribute = attribute, + sender = sender, + receiver = receiver, + node = node, + replace = replace, + cache = cache, + isTwoMode = isTwoMode, + n1 = n1, n2 = n2, + transformFun = transformFun, + aggregateFun = aggregateFun + ) +} # tertiusDiff ---------------------------------------------------------------- #' update stat transitivity using cache @@ -195,7 +200,7 @@ update_DyNAM_choice_coordination_tertiusDiff <- function( isTwoMode = FALSE, n1 = n1, n2 = n2, transformFun = abs, - aggregateFun = function(x) mean(x, na.rm = TRUE)) + aggregateFun = function(x) mean(x, na.rm = TRUE)) { update_DyNAM_choice_tertiusDiff( network = network, attribute = attribute, @@ -208,6 +213,7 @@ update_DyNAM_choice_tertiusDiff( n1 = n1, n2 = n2, transformFun = transformFun, aggregateFun = aggregateFun) +} # nodeTrans ------------------------------------------------------------------ update_DyNAM_choice_coordination_nodeTrans <- function( @@ -218,13 +224,13 @@ update_DyNAM_choice_coordination_nodeTrans <- function( cache, n1, n2, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_DyNAM_choice_nodeTrans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, transformFun = transformFun) - +} # Covariate effects ------------------------------------------------------- # alter ------------------------------------------------------------------- @@ -232,33 +238,33 @@ update_DyNAM_choice_coordination_alter <- function( attribute, node, replace, n1, n2, - isTwoMode = FALSE) + isTwoMode = FALSE) { update_DyNAM_choice_alter( attribute = attribute, node = node, replace = replace, n1 = n1, n2 = n2, isTwoMode = isTwoMode ) - +} # same -------------------------------------------------------------------- update_DyNAM_choice_coordination_same <- function( attribute, node, replace, - isTwoMode = FALSE) + isTwoMode = FALSE) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, isTwoMode = isTwoMode ) - +} # diff -------------------------------------------------------------------- update_DyNAM_choice_coordination_diff <- function( attribute, node, replace, n1, n2, isTwoMode = FALSE, - transformFun = abs) + transformFun = abs) { update_DyNAM_choice_diff( attribute = attribute, node = node, replace = replace, @@ -266,15 +272,14 @@ update_DyNAM_choice_coordination_diff <- function( isTwoMode = isTwoMode, transformFun = transformFun ) - - +} # sim --------------------------------------------------------------------- update_DyNAM_choice_coordination_sim <- function( attribute, node, replace, n1, n2, isTwoMode = FALSE, - transformFun = abs) + transformFun = abs) { update_DyNAM_choice_sim( attribute = attribute, node = node, replace = replace, @@ -282,6 +287,7 @@ update_DyNAM_choice_coordination_sim <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} # ego alter interaction --------------------------------------------------- update_DyNAM_choice_coordination_egoAlterInt <- function( @@ -289,7 +295,7 @@ update_DyNAM_choice_coordination_egoAlterInt <- function( attUpdate, n1, n2, isTwoMode = FALSE, - transformFun = identity) + transformFun = identity) { update_DyNAM_choice_egoAlterInt( attribute = attribute, node = node, replace = replace, @@ -298,3 +304,4 @@ update_DyNAM_choice_coordination_egoAlterInt <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} diff --git a/R/functions_effects_DyNAM_rate.R b/R/functions_effects_DyNAM_rate.R index 8e84c7f..cc12f6f 100644 --- a/R/functions_effects_DyNAM_rate.R +++ b/R/functions_effects_DyNAM_rate.R @@ -1,21 +1,26 @@ # define methods ---------------------------------------------------------- # init the statistical matrix -init_DyNAM_rate <- function(effectFun, network, attribute, n1, n2, cache = NULL) +init_DyNAM_rate <- function( + effectFun, network, attribute, n1, n2, cache = NULL + ) { UseMethod("init_DyNAM_rate", effectFun) - +} # default ----------------------------------------------------------------- -init_DyNAM_rate.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) +init_DyNAM_rate.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 ------------------------------------------------------ # indeg ------------------------------------------------------------------- #' init stat matrix indegree using cache @@ -100,22 +105,26 @@ init_DyNAM_rate.indeg <- function(effectFun, network, window, n1, n2) { #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' cache <- c(2, 7, 0, 1, 7) -#' update_DyNAM_rate_indeg(network, -#' 1, 2, 3, -#' cache, 5, 5, -#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt) -#' +#' update_DyNAM_rate_indeg( +#' network, +#' 1, 2, 3, +#' cache, 5, 5, +#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt +#' ) #' } -update_DyNAM_rate_indeg <- function(network, - sender, receiver, replace, cache, - n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) +update_DyNAM_rate_indeg <- function( + network, + sender, receiver, replace, cache, + n1, n2, isTwoMode = FALSE, + weighted = FALSE, transformFun = identity +) { update_REM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun, type = "ego" ) +} # outdeg --------------------------------------------------------------- init_DyNAM_rate.outdeg <- function(effectFun, network, window, n1, n2) { @@ -126,16 +135,19 @@ init_DyNAM_rate.outdeg <- function(effectFun, network, window, n1, n2) { } -update_DyNAM_rate_outdeg <- function(network, - sender, receiver, replace, cache, - n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) +update_DyNAM_rate_outdeg <- function( + network, + sender, receiver, replace, cache, + n1, n2, isTwoMode = FALSE, + weighted = FALSE, transformFun = identity +) { update_REM_choice_outdeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun, type = "ego" ) +} # nodeTrans ------------------------------------------------------------------ init_DyNAM_rate.nodeTrans <- function(effectFun, network, window, n1, n2) { @@ -145,38 +157,46 @@ init_DyNAM_rate.nodeTrans <- function(effectFun, network, window, n1, n2) { window = window, n1 = n1, n2 = n2) } -update_DyNAM_rate_nodeTrans <- function(network, - sender, - receiver, - replace, - cache, - n1, n2, - isTwoMode = FALSE, - transformFun = identity) +update_DyNAM_rate_nodeTrans <- function( + network, + sender, + receiver, + replace, + cache, + n1, n2, + isTwoMode = FALSE, + transformFun = identity +) { update_REM_choice_nodeTrans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, - transformFun = transformFun, type = "ego") + transformFun = transformFun, type = "ego" + ) +} # tertius ---------------------------------------------------------------- -init_DyNAM_rate.tertius <- function(effectFun, network, attribute, window, n1, n2) { +init_DyNAM_rate.tertius <- function( + effectFun, network, attribute, window, n1, n2 + ) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) init_REM_choice.tertius(effectFun = effectFun, network = network, attribute = attribute, window = window, n1 = n1, n2 = n2) } -update_DyNAM_rate_tertius <- function(network, - attribute, - sender = NULL, - receiver = NULL, - node = NULL, - replace, - cache, - isTwoMode = FALSE, - n1 = n1, n2 = n2, - transformFun = identity, - aggregateFun = function(x) mean(x, na.rm = TRUE)) +update_DyNAM_rate_tertius <- function( + network, + attribute, + sender = NULL, + receiver = NULL, + node = NULL, + replace, + cache, + isTwoMode = FALSE, + n1 = n1, n2 = n2, + transformFun = identity, + aggregateFun = function(x) mean(x, na.rm = TRUE) +) { update_REM_choice_tertius( network = network, attribute = attribute, @@ -190,17 +210,25 @@ update_DyNAM_rate_tertius <- function(network, transformFun = transformFun, aggregateFun = aggregateFun, type = "ego" ) +} + # Covariate effects ------------------------------------------------------- # ego --------------------------------------------------------------------- -init_DyNAM_rate.ego <- function(effectFun, attribute, n1, n2) +init_DyNAM_rate.ego <- function(effectFun, attribute, n1, n2) { init_REM_choice.ego(effectFun = effectFun, attribute = attribute, n1 = n1, n2 = n2) +} -update_DyNAM_rate_ego <- function(attribute, - node, replace, - n1, n2, - isTwoMode = FALSE) - update_REM_choice_ego(attribute = attribute, - node = node, replace = replace, - n1 = n1, n2 = n2, - isTwoMode = isTwoMode) +update_DyNAM_rate_ego <- function( + attribute, + node, replace, + n1, n2, + isTwoMode = FALSE +) { + update_REM_choice_ego( + attribute = attribute, + node = node, replace = replace, + n1 = n1, n2 = n2, + isTwoMode = isTwoMode + ) +} diff --git a/R/functions_effects_DyNAMi_choice.R b/R/functions_effects_DyNAMi_choice.R index d22092f..0e7c26d 100644 --- a/R/functions_effects_DyNAMi_choice.R +++ b/R/functions_effects_DyNAMi_choice.R @@ -1,7 +1,8 @@ # define methods ---------------------------------------------------------- # init cache data structure: vector or matrix -init_DyNAMi_choice <- function(effectFun, network, attribute) +init_DyNAMi_choice <- function(effectFun, network, attribute) { UseMethod("init_DyNAMi_choice", effectFun) +} # default ----------------------------------------------------------------- diff --git a/R/functions_effects_DyNAMi_rate.R b/R/functions_effects_DyNAMi_rate.R index 74c4585..d4aa73c 100644 --- a/R/functions_effects_DyNAMi_rate.R +++ b/R/functions_effects_DyNAMi_rate.R @@ -1,7 +1,8 @@ # define methods ---------------------------------------------------------- # init cache data structure: vector or matrix -init_DyNAMi_rate <- function(effectFun, network, attribute) +init_DyNAMi_rate <- function(effectFun, network, attribute) { UseMethod("init_DyNAMi_rate", effectFun) +} # default ----------------------------------------------------------------- init_DyNAMi_rate.default <- function(effectFun, diff --git a/R/functions_effects_REM.R b/R/functions_effects_REM.R index 2cfd1dd..2244a6b 100644 --- a/R/functions_effects_REM.R +++ b/R/functions_effects_REM.R @@ -1,8 +1,10 @@ # define methods ---------------------------------------------------------- # init the statistical matrix -init_REM_choice <- function(effectFun, network, attribute, n1, n2, cache = NULL) +init_REM_choice <- function( + effectFun, network, attribute, n1, n2, cache = NULL +) { UseMethod("init_REM_choice", effectFun) - +} # default ----------------------------------------------------------------- init_REM_choice.default <- function( @@ -19,50 +21,53 @@ init_REM_choice.default <- function( # Structural effects ------------------------------------------------------ # tie --------------------------------------------------------------------- -init_REM_choice.tie <- function(effectFun, network, window, n1, n2) +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) + 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.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) + 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_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) + transformFun = identity) { update_DyNAM_choice_recip( network = network, sender = sender, receiver = receiver, replace = replace, @@ -70,6 +75,7 @@ update_REM_choice_recip <- function( weighted = weighted, transformFun = transformFun ) +} # indeg ------------------------------------------------------------------- #' init stat matrix indegree using cache @@ -452,11 +458,12 @@ update_REM_choice_outdeg <- function( } # trans ------------------------------------------------------------------- -init_REM_choice.trans <- function(effectFun, network, window, n1, n2) +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, @@ -464,20 +471,22 @@ update_REM_choice_trans <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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, @@ -485,20 +494,22 @@ update_REM_choice_cycle <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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, @@ -506,20 +517,22 @@ update_REM_choice_commonReceiver <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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, @@ -527,21 +540,22 @@ update_REM_choice_commonSender <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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, @@ -549,20 +563,22 @@ update_REM_choice_mixedTrans <- function( receiver, replace, netUpdate, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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, @@ -570,21 +586,23 @@ update_REM_choice_mixedCycle <- function( receiver, replace, netUpdate, cache, isTwoMode = FALSE, - transformFun = identity) + 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) + window, n1, n2) { init_DyNAM_choice.mixedCommonReceiver( effectFun = effectFun, network = network, window = window, n1 = n1, n2 = n2) +} update_REM_choice_mixedCommonReceiver <- function( network, @@ -592,21 +610,23 @@ update_REM_choice_mixedCommonReceiver <- function( receiver, replace, netUpdate, cache, isTwoMode = FALSE, - transformFun = identity) + 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) + window, n1, n2) { init_DyNAM_choice.mixedCommonSender( effectFun = effectFun, network = network, window = window, n1 = n1, n2 = n2) +} update_REM_choice_mixedCommonSender <- function( network, @@ -614,27 +634,29 @@ update_REM_choice_mixedCommonSender <- function( receiver, replace, netUpdate, cache, isTwoMode = FALSE, - transformFun = identity) + 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_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) + transformFun = identity) { update_DyNAM_choice_four( network = network, sender = sender, receiver = receiver, replace = replace, @@ -642,6 +664,8 @@ update_REM_choice_four <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} + # tertius ---------------------------------------------------------------- #' init stat matrix tertius using cache #' @@ -877,12 +901,13 @@ update_REM_choice_tertius <- function( rbind, lapply( nodesChange, - function(x) + \(x) { cbind( node1 = if (isTwoMode) seq_len(n1) else third(n1, x), node2 = x, replace = forceAndCall(1, transformFun, cache[x]) ) + } ) ) } else if (type == "ego") { @@ -891,12 +916,13 @@ update_REM_choice_tertius <- function( rbind, lapply( nodesChange, - function(x) + \(x) { cbind( node1 = x, node2 = if (isTwoMode) seq_len(n1) else third(n1, x), replace = forceAndCall(1, transformFun, cache[x]) ) + } ) ) } @@ -913,12 +939,13 @@ update_REM_choice_tertius <- function( rbind, lapply( toImpute, - function(x) + \(x) { cbind( node1 = if (isTwoMode) seq_len(n1) else third(n1, x), node2 = x, replace = forceAndCall(1, transformFun, imputeVal) ) + } ) ) ) @@ -930,12 +957,13 @@ update_REM_choice_tertius <- function( rbind, lapply( toImpute, - function(x) + \(x) { cbind( node1 = x, node2 = if (isTwoMode) seq_len(n1) else third(n1, x), replace = forceAndCall(1, transformFun, imputeVal) ) + } ) ) ) @@ -978,12 +1006,13 @@ update_REM_choice_tertius <- function( #' init_REM_choice.tertiusDiff(effectFUN, network, attribute) #' } init_REM_choice.tertiusDiff <- function(effectFun, network, attribute, - window, n1, n2) + window, n1, n2) { init_DyNAM_choice.tertiusDiff( effectFun = effectFun, network = network, attribute = attribute, window = window, n1 = n1, n2 = n2) +} #' update stat transitivity using cache #' @@ -1050,7 +1079,7 @@ update_REM_choice_tertiusDiff <- function( isTwoMode = FALSE, n1 = n1, n2 = n2, transformFun = abs, - aggregateFun = function(x) mean(x, na.rm = TRUE)) + aggregateFun = function(x) mean(x, na.rm = TRUE)) { update_DyNAM_choice_tertiusDiff( network = network, attribute = attribute, @@ -1063,7 +1092,7 @@ update_REM_choice_tertiusDiff <- function( n1 = n1, n2 = n2, transformFun = transformFun, aggregateFun = aggregateFun) - +} # nodeTrans ------------------------------------------------------------------ @@ -1250,7 +1279,7 @@ update_REM_choice_nodeTrans <- function( rbind, lapply( seq_along(commonSenders), - function(x) + \(x) { if (type == "ego") { cbind( node1 = commonSenders[x], @@ -1264,6 +1293,7 @@ update_REM_choice_nodeTrans <- function( replace = replaceValues[x] ) } + } ) ) ) @@ -1321,45 +1351,50 @@ update_REM_choice_ego <- function( } # alter ------------------------------------------------------------------- -init_REM_choice.alter <- function(effectFun, attribute, n1, n2) +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) + 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_REM_choice.same <- function(effectFun, attribute) { init_DyNAM_choice.same(effectFun = effectFun, attribute = attribute) +} update_REM_choice_same <- function( attribute, node, replace, - isTwoMode = FALSE) + isTwoMode = FALSE) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, isTwoMode = isTwoMode ) +} # diff -------------------------------------------------------------------- -init_REM_choice.diff <- function(effectFun, attribute) +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) + transformFun = abs) { update_DyNAM_choice_diff( attribute = attribute, node = node, replace = replace, @@ -1367,16 +1402,18 @@ update_REM_choice_diff <- function( n1 = n1, n2 = n2, transformFun = transformFun ) +} # sim --------------------------------------------------------------------- -init_REM_choice.sim <- function(effectFun, attribute) +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) + transformFun = abs) { update_DyNAM_choice_sim( attribute = attribute, node = node, replace = replace, @@ -1384,18 +1421,19 @@ update_REM_choice_sim <- function( isTwoMode = isTwoMode, transformFun = transformFun ) - +} # ego alter interaction --------------------------------------------------- -init_REM_choice.egoAlterInt <- function(effectFun, attribute) +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) + transformFun = identity) { update_DyNAM_choice_egoAlterInt( attribute = attribute, node = node, replace = replace, @@ -1404,3 +1442,4 @@ update_REM_choice_egoAlterInt <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} diff --git a/R/functions_estimation.R b/R/functions_estimation.R index f449e35..b2e6427 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -264,9 +264,9 @@ estimate <- function( preprocessingInit = NULL, preprocessingOnly = FALSE, progress = getOption("progress"), - verbose = getOption("verbose")) + verbose = getOption("verbose")) { UseMethod("estimate", x) - +} # First estimation from a formula: can return either a preprocessed object or a # result object @@ -769,14 +769,18 @@ estimate.formula <- function( "estimate_c_int", args = c(argsEstimation, list(engine = engine)) ), - error = function(e) stop("Error in ", model, " ", subModel, - " estimation: ", e, call. = FALSE) + error = \(e) { + stop("Error in ", model, " ", subModel, + " estimation: ", e, call. = FALSE) + } ) } else { tryCatch( result <- do.call("estimate_int", args = argsEstimation), - error = function(e) stop("Error in ", model, " ", subModel, - " estimation: ", e, call. = FALSE) + error = \(e) { + stop("Error in ", model, " ", subModel, + " estimation: ", e, call. = FALSE) + } ) } diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 2b88645..f073f90 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -667,9 +667,10 @@ getInformationMatrixREM <- function(eventProbabilities, firstDerivatives) { values <- colSums(apply( indexes, 1, - function(ind) + \(ind) { firstDerivatives[, , ind[1]] * firstDerivatives[, , ind[2]] * eventProbabilities + } )) information <- matrix(values, nParams, nParams) # symmetrize @@ -1029,9 +1030,10 @@ getMultinomialInformationMatrix <- function(likelihoods, derivatives) { values <- apply( indexes, 1, - function(ind) + \(ind) { sum(derivatives[, , ind[1]] * derivatives[, , ind[2]] * likelihoodsTriangle) + } ) informationMatrix <- matrix(values, nParams, nParams, byrow = FALSE) @@ -1050,9 +1052,10 @@ getMultinomialInformationMatrixM <- function( temp <- apply( indexes, 1, - function(ind) + \(ind) { firstDerivatives[, ind[1]] * firstDerivatives[, ind[2]] * eventProbabilities + } ) if (!is.null(dim(temp))) { values <- colSums(temp) diff --git a/R/functions_parsing.R b/R/functions_parsing.R index 522ed96..808f7c2 100644 --- a/R/functions_parsing.R +++ b/R/functions_parsing.R @@ -8,9 +8,11 @@ #' parse formula #' A valid formula should have: #' - on the left side a list of dependent events -#' - on the right side a list of names that correspond to effects we have in our pre-defined functions +#' - on the right side a list of names that correspond to effects +#' we have in our pre-defined functions #' - parameters for the effects that are coherent with the documentation -#' on top of this, we parse the formula to the right format for the rest of the estimation +#' on top of this, we parse the formula to the right format +#' for the rest of the estimation #' @param formula a class \code{formula} object that defines the model #' #' @return a list with parsed values needed in the next steps @@ -72,7 +74,8 @@ parseFormula <- function(formula, envir = new.env()) { ignoreRepParameter <- mult[[2]] # check mismatch with default parameter if (any(unlist(ignoreRepParameter)) && is.null(defaultNetworkName)) { - stop("No default network defined, thus ", sQuote("ignoreRep = TRUE"), " effects cannot be used.", call. = FALSE) + stop("No default network defined, thus ", dQuote("ignoreRep = TRUE"), + " effects cannot be used.", call. = FALSE) } # check right side: weighted parameter weightedParameter <- lapply(rhsNames, function(x) { @@ -127,18 +130,25 @@ parseFormula <- function(formula, envir = new.env()) { # Comparison of two parsed formulas for preprocessingInit -# throws errors when: dependent events or default network are not the same, when there is righ-censoring +# throws errors when: dependent events or default network are not the same, +# when there is righ-censoring # for one and not the other -# returns: a list of the size of the new formula, with zeros when the effects are new, and with the -# the index of the effect in the old formula if the effect was already there -compareFormulas <- function(oldparsedformula, newparsedformula, model, subModel) { +# returns: a list of the size of the new formula, with zeros when the effects +# are new, and with the +# the index of the effect in the old formula if the effect was already there +compareFormulas <- function( + oldparsedformula, newparsedformula, model, subModel +) { # test dependent events and default network if (oldparsedformula$depName != newparsedformula$depName) { stop("The dependent events in the formula are not the ones used in", " the preprocessed object given in preprocessingInit.") } - if (!identical(oldparsedformula$defaultNetworkName, newparsedformula$defaultNetworkName)) { + if (!identical( + oldparsedformula$defaultNetworkName, + newparsedformula$defaultNetworkName + )) { stop("The default network in the formula is not the one used in", " the preprocessed object given in preprocessingInit.") } @@ -147,7 +157,8 @@ compareFormulas <- function(oldparsedformula, newparsedformula, model, subModel) # we would need go in the details of the RC intervals and updates oldhasIntercept <- oldparsedformula$hasIntercept newhasIntercept <- newparsedformula$hasIntercept - if (model %in% "DyNAM" && subModel %in% c("choice", "choice_coordination") && oldhasIntercept) { + if (model %in% "DyNAM" && subModel %in% c("choice", "choice_coordination") + && oldhasIntercept) { oldhasIntercept <- FALSE newhasIntercept <- FALSE } @@ -156,14 +167,18 @@ compareFormulas <- function(oldparsedformula, newparsedformula, model, subModel) " with the right-censored intervals that this formula requires.") } if (!oldhasIntercept && newhasIntercept) { - stop("The preprocessing for the object in preprocessingInit was done", - " with right-censored intervals and this formula does not include those.") + stop( + "The preprocessing for the object in preprocessingInit was done", + " with right-censored intervals and this formula does not include those." + ) } - # counters for remembering which of the old effects are found in the new formula + # counters for remembering which of the old effects + # are found in the new formula sizeold <- length(oldparsedformula$rhsNames) sizenew <- length(newparsedformula$rhsNames) effectsindexes <- rep(0, sizenew) - # go through all new effects to check whether they already existed in the old formula + # go through all new effects to check whether they already existed + # in the old formula for (i in seq.int(sizenew)) { effectname <- newparsedformula$rhsNames[[i]][[1]] effectobject <- newparsedformula$rhsNames[[i]][[2]] @@ -185,7 +200,9 @@ compareFormulas <- function(oldparsedformula, newparsedformula, model, subModel) next } # 4 check other parameters - if (!identical(oldparsedformula$ignoreRepParameter[[j]], effectignorerep)) { + if (!identical( + oldparsedformula$ignoreRepParameter[[j]], effectignorerep + )) { next } if (!identical(oldparsedformula$weightedParameter[[j]], effectweighted)) { @@ -203,7 +220,8 @@ compareFormulas <- function(oldparsedformula, newparsedformula, model, subModel) # Creation of the different effects with the right parameters -# in which the first empty parameters are replaced with the ones found in effectInit +# in which the first empty parameters are replaced with +# the ones found in effectInit # ignores parameters that are not used in the updates computation (parmsIgnore) createEffectsFunctions <- function(effectInit, model, subModel, envir = environment()) { @@ -235,7 +253,8 @@ createEffectsFunctions <- function(effectInit, model, subModel, envir = envir) } - # Update signatures of the effects based on default parameters and above specified parameters + # Update signatures of the effects based on default parameters + # and above specified parameters .signature <- formals(FUN) .argsNames <- names(.signature) parmsToSet <- x[-1] @@ -243,12 +262,15 @@ createEffectsFunctions <- function(effectInit, model, subModel, if (is.null(names(parmsToSet))) { namedParams <- rep(FALSE, length(parmsToSet)) } else { - namedParams <- unlist(lapply(names(parmsToSet), function(v) is.character(v) && v != "")) + namedParams <- unlist(lapply( + names(parmsToSet), + \(v) is.character(v) && v != "" + )) } # change parameter type from character to an expression nameArg <- parmsToSet[[1]] - parmsToSet <- lapply(parmsToSet, function(s) call("eval", parse(text = s))) + parmsToSet <- lapply(parmsToSet, \(s) call("eval", parse(text = s))) # replace named and unnamed parameters .argsReplace <- pmatch(names(parmsToSet), .argsNames) @@ -256,13 +278,16 @@ createEffectsFunctions <- function(effectInit, model, subModel, names <- names(parmsToSet)[namedParams] # replace named args in formals .signature[na.omit(.argsReplace)] <- parmsToSet[!is.na(.argsReplace)] - isCondition <- isReservedElementName(.argsNames) & !(.argsNames %in% names) + isCondition <- isReservedElementName(.argsNames) & + !(.argsNames %in% names) .signature[isCondition] <- parmsToSet[!namedParams] # set isTwoMode parameter, checking if different if ("network" %in% .argsNames && "isTwoMode" %in% .argsNames) { # cat(x[[1]], is.null(parmsToSet[["isTwoMode"]])) - isTwoMode <- length(attr(eval(.signature[["network"]], envir = envir), "nodes")) > 1 + isTwoMode <- length(attr( + eval(.signature[["network"]], envir = envir), "nodes" + )) > 1 if (!is.null(parmsToSet[["isTwoMode"]]) && eval(parmsToSet[["isTwoMode"]], envir = envir) != isTwoMode) { warning( @@ -272,21 +297,29 @@ createEffectsFunctions <- function(effectInit, model, subModel, x[[2]], "'", call. = FALSE, immediate. = TRUE) } else if (isTwoMode && is.null(parmsToSet[["isTwoMode"]])) { .signature[["isTwoMode"]] <- isTwoMode - warning("Setting 'isTwoMode' parameter in effect ", x[[1]], - " to TRUE for network '", x[[2]], "'", call. = FALSE, immediate. = TRUE) + warning( + "Setting 'isTwoMode' parameter in effect ", x[[1]], + " to TRUE for network '", x[[2]], "'", + call. = FALSE, immediate. = TRUE + ) } } # if ("network2" %in% .argsNames && "isTwoMode" %in% .argsNames) { - # isTwoMode <- length(attr(eval(.signature[["network2"]], envir = envir), "nodes")) > 2 - # if (!is.null(parmsToSet[["isTwoMode"]]) && eval(parmsToSet[["isTwoMode"]]) != isTwoMode) { + # isTwoMode <- length(attr( + # eval(.signature[["network2"]], envir = envir), "nodes" + # )) > 1 + # if (!is.null(parmsToSet[["isTwoMode"]]) && + # eval(parmsToSet[["isTwoMode"]]) != isTwoMode) { # warning( - # "The 'isTwoMode' parameter in effect ", x[[1]], " has a diferent value than the network argument", + # "The 'isTwoMode' parameter in effect ", x[[1]], + # " has a diferent value than the network argument", # .signature[["network2"]] # ) # } else if (isTwoMode) .signature[["isTwoMode"]] <- isTwoMode # } - # if(inherits(.signature, "matrix")) .signature <- apply(.signature, 2, invisible) + # if(inherits(.signature, "matrix")) + # .signature <- apply(.signature, 2, invisible) # Assign signatures with default values to generic functions formals(FUN) <- .signature @@ -347,12 +380,14 @@ extractFormulaTerms <- function(rhs) { getDependentName <- function(formula) { dep <- list(formula[[2]]) - depName <- unlist(lapply(dep, deparse)) + unlist(lapply(dep, deparse)) } -getEventsAndObjectsLink <- function(depName, rhsNames, nodes = NULL, nodes2 = NULL, - envir = environment()) { +getEventsAndObjectsLink <- function( + depName, rhsNames, nodes = NULL, nodes2 = NULL, + envir = environment() +) { # Find objects (irrespective of where they occur) objectNames <- getDataObjects(rhsNames) @@ -443,8 +478,10 @@ getEventsAndObjectsLink <- function(depName, rhsNames, nodes = NULL, nodes2 = NU getEventsEffectsLink <- function(events, rhsNames, eventsObjectsLink) { eventsEffectsLink <- matrix( data = NA, nrow = length(events), ncol = length(rhsNames), - dimnames = list(names(events), - vapply(rhsNames, FUN = "[[", FUN.VALUE = character(1), i = 1)) + dimnames = list( + names(events), + vapply(rhsNames, FUN = "[[", FUN.VALUE = character(1), i = 1) + ) ) for (i in seq_along(rhsNames)) { # objects of effect @@ -502,7 +539,9 @@ parseIntercept <- function(rhsNames) { # Figures out which effect is a multiple effect # then finds a network object from the other parameters that this is related to # unless a network name is passed to the multiple attribute -parseMultipleEffects <- function(rhsNames, default = FALSE, envir = environment()) { +parseMultipleEffects <- function( + rhsNames, default = FALSE, envir = environment() +) { multiple <- list() multipleNames <- character(0) for (i in seq_along(rhsNames)) { @@ -521,7 +560,8 @@ parseMultipleEffects <- function(rhsNames, default = FALSE, envir = environment( name <- table[netIds, "name"][1] # take first network # apply(getDataObjects(rhsNames) # netIds <- sapply(, function(x) "network.goldfish" %in% class(get(x))) - # name <- getDataObjects(rhsNames)$object[netIds][[1]] # get the first network item + # # get the first network item + # name <- getDataObjects(rhsNames)$object[netIds][[1]] } if (is.character(multipleParam)) { name <- multipleParam @@ -604,11 +644,11 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { if (grepl("week", window)) { window <- as.numeric(strsplit(window, " ")[[1]][1]) * 604800 } - if (grepl("month", window)) { - window <- as.numeric(strsplit(window, " ")[[1]][1]) * 2629800 # lubridate approximation + if (grepl("month", window)) { # lubridate approximation + window <- as.numeric(strsplit(window, " ")[[1]][1]) * 2629800 } - if (grepl("year", window)) { - window <- as.numeric(strsplit(window, " ")[[1]][1]) * 31557600 # lubridate approximation + if (grepl("year", window)) { # lubridate approximation + window <- as.numeric(strsplit(window, " ")[[1]][1]) * 31557600 } } else if (is.numeric(window)) { # check numeric type @@ -638,7 +678,8 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { if (isAttribute) { - # get nodes & attribute, add new windowed attribute, get related events to be windowed later + # get nodes & attribute, add new windowed attribute, + # get related events to be windowed later nameNodes <- objects$nodeset nodes <- get(nameNodes, envir = envir) attribute <- objects$attribute @@ -651,7 +692,8 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { allEvents <- allEvents[allDynamicAttributes == attribute] } else { - # get network, create windowed network, get related events to be windowed later + # get network, create windowed network, get related events + # to be windowed later network <- get(name, envir = envir) newNetwork <- matrix(0, nrow = nrow(network), ncol = ncol(network)) diff --git a/R/functions_preprocessing.R b/R/functions_preprocessing.R index b23e420..4c144da 100644 --- a/R/functions_preprocessing.R +++ b/R/functions_preprocessing.R @@ -651,7 +651,7 @@ callFUN <- function( errorHandler <- function(e) { erro <- simpleError( paste0( - "Effect ", sQuote(effectLabel), + "Effect ", dQuote(effectLabel), " (", effectPos, ") ", textMss, e$message) ) stop(erro) diff --git a/R/testthat-helpers.R b/R/testthat-helpers.R index 4cf9d35..f6aee52 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -91,38 +91,49 @@ testAttr <- data.frame( ) # Effect Functions ------------------------------------------------- -effectFUN_tie <- function(network, - sender, receiver, replace, - weighted = FALSE, transformFun = identity) +effectFUN_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 ) -effectFUN_tie_weighted <- function(network, - sender, receiver, replace, - weighted = TRUE, transformFun = identity) +} + +effectFUN_tie_weighted <- function( + network, + sender, receiver, replace, + weighted = TRUE, transformFun = identity +) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, weighted = weighted, transformFun = transformFun ) -effectFUN_same <- function(attribute, - node, replace, - isTwoMode = FALSE) +} + +effectFUN_same <- function( + attribute, + node, replace, + isTwoMode = FALSE +) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, isTwoMode = isTwoMode ) - +} effectFUN_indeg <- function( - network, - sender, receiver, replace, - cache, n1, n2, - isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) { + network, + sender, receiver, replace, + cache, n1, n2, + isTwoMode = FALSE, + weighted = FALSE, transformFun = identity +) { update_DyNAM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -131,55 +142,68 @@ effectFUN_indeg <- function( ) } -effectFUN_trans <- function(network, - sender, - receiver, - replace, cache, - isTwoMode = FALSE, - transformFun = identity) +effectFUN_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 ) +} + +effectFUN_tertius <- 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) +} -effectFUN_tertius <- 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) - -effectFUN_REM_ego <- function(attribute, - node, replace, - n1, n2, - isTwoMode = FALSE) - update_REM_choice_ego(attribute = attribute, - node = node, replace = replace, - n1 = n1, n2 = n2, - isTwoMode = isTwoMode) - -effectFUN_REM_diff <- function(attribute, node, replace, - n1, n2, - isTwoMode = FALSE, - transformFun = abs) +effectFUN_REM_ego <- function( + attribute, + node, replace, + n1, n2, + isTwoMode = FALSE +) { + update_REM_choice_ego( + attribute = attribute, + node = node, replace = replace, + n1 = n1, n2 = n2, + isTwoMode = isTwoMode) +} + +effectFUN_REM_diff <- function( + attribute, node, replace, + n1, n2, + isTwoMode = FALSE, + transformFun = abs +) { update_DyNAM_choice_diff( attribute = attribute, node = node, replace = replace, @@ -187,15 +211,19 @@ effectFUN_REM_diff <- function(attribute, node, replace, n1 = n1, n2 = n2, transformFun = transformFun ) +} -effectFUN_REM_sim <- function(attribute, - node, replace, - isTwoMode = FALSE) +effectFUN_REM_sim <- function( + attribute, + node, replace, + isTwoMode = FALSE +) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, isTwoMode = isTwoMode ) +} # Preprocessing DyNAM --------------------------------------------------------- # direct network diff --git a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R index 6e6d182..16726e9 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R @@ -148,25 +148,27 @@ test_that( estimationInit = list(startTime = 10, endTime = 30) ) statsChange <- ReducePreprocess(preproData) - expect_equal(preproData$initialStats[, , 1], - matrix(c( - 0, 4, 4, 4, 4, - 4, 0, 4, 4, 4, - 3, 3, 0, 3, 3, - 1, 1, 1, 0, 1, - 0, 0, 0, 0, 0 - ), 5, 5, TRUE), - label = "init outdeg stat matrix" + expect_equal( + preproData$initialStats[, , 1], + matrix(c( + 0, 4, 4, 4, 4, + 4, 0, 4, 4, 4, + 3, 3, 0, 3, 3, + 1, 1, 1, 0, 1, + 0, 0, 0, 0, 0 + ), 5, 5, TRUE), + label = "init outdeg stat matrix" ) - expect_equal(preproData$initialStats[, , 2], - matrix(c( - 0, 2, 2, 2, 2, - 5, 0, 5, 5, 5, - 0, 0, 0, 0, 0, - 1, 1, 1, 0, 1, - 0, 0, 0, 0, 0 - ), 5, 5, TRUE), - label = "init indeg stat matrix" + expect_equal( + preproData$initialStats[, , 2], + matrix(c( + 0, 2, 2, 2, 2, + 5, 0, 5, 5, 5, + 0, 0, 0, 0, 0, + 1, 1, 1, 0, 1, + 0, 0, 0, 0, 0 + ), 5, 5, TRUE), + label = "init indeg stat matrix" ) expect_equal( Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), @@ -179,8 +181,8 @@ test_that( expect_equal( statsChange[[1]][["dependent"]], fillChanges( - nodes = c( 2, 5, 1, 3, 3, 4), - replace = c( 5, 1, 6, 4, 5, 2), + nodes = c(2, 5, 1, 3, 3, 4), + replace = c(5, 1, 6, 4, 5, 2), time = c(15, 16, 19, 23, 28, 29), set = 1:5), label = "updating outdeg times with increment works" @@ -188,8 +190,8 @@ test_that( expect_equal( statsChange[[2]][["dependent"]], fillChanges( - nodes = c( 3, 1, 2, 5, 3, 5), - replace = c( 1, 5, 4, 1, 3, 4), + nodes = c(3, 1, 2, 5, 3, 5), + replace = c(1, 5, 4, 1, 3, 4), time = c(15, 16, 19, 19, 28, 28), set = 1:5), label = "updating indeg times with increment works" @@ -197,8 +199,8 @@ test_that( expect_equal( statsChange[[1]][["rightCensored"]], fillChanges( - nodes = c( 2, 1, 3, 2), - replace = c( 5, 6, 5, 6), + nodes = c(2, 1, 3, 2), + replace = c(5, 6, 5, 6), time = c(14, 18, 25, 30), set = 1:5), label = "updating outdeg times right censored" @@ -261,25 +263,27 @@ test_that( estimationInit = list(startTime = 6, endTime = 24) ) statsChange <- ReducePreprocess(preproData) - expect_equal(preproData$initialStats[, , 1], - matrix(c( - 0, 4, 4, 4, 4, - 3, 0, 3, 3, 3, - 1, 1, 0, 1, 1, - 1, 1, 1, 0, 1, - 0, 0, 0, 0, 0 - ), 5, 5, TRUE), - label = "init outdeg stat matrix" + expect_equal( + preproData$initialStats[, , 1], + matrix(c( + 0, 4, 4, 4, 4, + 3, 0, 3, 3, 3, + 1, 1, 0, 1, 1, + 1, 1, 1, 0, 1, + 0, 0, 0, 0, 0 + ), 5, 5, TRUE), + label = "init outdeg stat matrix" ) - expect_equal(preproData$initialStats[, , 2], - matrix(c( - 0, 2, 2, 2, 2, - 4, 0, 4, 4, 4, - 0, 0, 0, 0, 0, - 1, 1, 1, 0, 1, - 0, 0, 0, 0, 0 - ), 5, 5, TRUE), - label = "init indeg stat matrix" + expect_equal( + preproData$initialStats[, , 2], + matrix(c( + 0, 2, 2, 2, 2, + 4, 0, 4, 4, 4, + 0, 0, 0, 0, 0, + 1, 1, 1, 0, 1, + 0, 0, 0, 0, 0 + ), 5, 5, TRUE), + label = "init indeg stat matrix" ) expect_equal( Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), From 7aa5359e855907dcdf80e8351a2b39f7bc4c0884 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 21 Jun 2023 12:04:01 +0200 Subject: [PATCH 09/36] replace mapply by map and simplify --- R/functions_checks.R | 5 ++-- R/functions_preprocessing.R | 3 ++- R/functions_preprocessing_interaction.R | 36 ++++++++++++------------- 3 files changed, 22 insertions(+), 22 deletions(-) diff --git a/R/functions_checks.R b/R/functions_checks.R index 673fb95..1cdaae4 100644 --- a/R/functions_checks.R +++ b/R/functions_checks.R @@ -245,7 +245,7 @@ checkColumns <- function( !columnNames %in% c(mandatoryNames, incompatibleNames, optionalNames)] <- ".allow" - checked <- mapply( + checked <- Map( function(column, ct, name) { if (!any(checkClasses(column, classes[[ct]]))) stop("The column ", dQuote(name), " expects values of type ", @@ -255,7 +255,8 @@ checkColumns <- function( else TRUE }, inDataFrame, colType, columnNames - ) + ) |> + vapply(identity, logical(1)) return(all(checked)) } diff --git a/R/functions_preprocessing.R b/R/functions_preprocessing.R index 4c144da..27a010c 100644 --- a/R/functions_preprocessing.R +++ b/R/functions_preprocessing.R @@ -208,7 +208,8 @@ preprocess <- function( while (any(validPointers)) { iTotalEvents <- iTotalEvents + 1L # times: the timepoint for next events to update in all event lists - times <- mapply(function(e, p) e[p, ]$time, events, pointers) + times <- Map(function(e, p) e[p, ]$time, events, pointers) |> + vapply(identity, numeric(1)) nextEvent <- which(validPointers)[head(which.min(times[validPointers]), 1)] nextEventTime <- times[nextEvent] if (hasStartTime || hasEndTime) { diff --git a/R/functions_preprocessing_interaction.R b/R/functions_preprocessing_interaction.R index 150a146..c842e71 100644 --- a/R/functions_preprocessing_interaction.R +++ b/R/functions_preprocessing_interaction.R @@ -260,14 +260,8 @@ preprocessInteraction <- function( while (any(validPointers)) { # times: the timepoint for next events to update in all event lists - times <- mapply(function(e, p) e[p, ]$time, events, pointers) - increments <- mapply(function(e, p) { - if ("increment" %in% names(e)) { - e[p, ]$increment - } else { - 0 - } - }, events, pointers) + times <- Map(function(e, p) e[p, ]$time, events, pointers) |> + vapply(identity, numeric(1)) # added Marion: we set priority to dependent, # exogenous and past updates before anything else @@ -281,17 +275,21 @@ preprocessInteraction <- function( c(depindex, exoindex, pastindexes) ) if (length(prioritypointers) > 0) { - cpts <- mapply(function(p) { - if (p == depindex) { - return(deporder[pointers[p]]) - } - if (p == exoindex) { - return(exoorder[pointers[p]]) - } - if (p %in% pastindexes) { - return(pastorders[[which(pastindexes == p)]][pointers[p]]) - } - }, prioritypointers) + cpts <- Map( + \(p) { + if (p == depindex) { + return(deporder[pointers[p]]) + } + if (p == exoindex) { + return(exoorder[pointers[p]]) + } + if (p %in% pastindexes) { + return(pastorders[[which(pastindexes == p)]][pointers[p]]) + } + }, prioritypointers + ) |> + vapply(identity, numeric(1)) + if (max(cpts) == 0) { nextEvent <- prioritypointers[1] } else { From 2274cd3b447d1240685d11ab8b6c242b3c970e8f Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 21 Jun 2023 14:14:17 +0200 Subject: [PATCH 10/36] Comply 80-character lenght line for R code --- R/data_Fisheries_Treaties_6070.R | 62 +- R/data_RFID_Validity_Study.R | 46 +- R/data_Social_Evolution.R | 38 +- R/functions_diagnostics.R | 6 +- R/functions_effects_DyNAM_choice.R | 12 +- R/functions_effects_DyNAM_rate.R | 27 +- R/functions_effects_DyNAMi_choice.R | 234 ++++--- R/functions_effects_DyNAMi_rate.R | 602 ++++++++++++------ R/functions_effects_REM.R | 9 +- R/functions_estimation_engine.R | 6 +- R/functions_estimation_engine_c.r | 7 - R/functions_group_interaction_utility.R | 162 +++-- R/functions_output.R | 65 +- R/functions_postestimate.R | 4 +- R/functions_preprocessing_interaction.R | 4 +- R/goldfish-package.R | 21 +- man/Fisheries_Treaties_6070.Rd | 62 +- man/RFID_Validity_Study.Rd | 46 +- man/Social_Evolution.Rd | 38 +- man/estimate.Rd | 2 +- man/goldfish-package.Rd | 21 +- src/DyNAM_rate_default.cpp | 1 - src/gather_sender_model.cpp | 1 - .../test-effects_preprocessing_DyNAM_choice.R | 74 ++- ...test-effects_preprocessing_DyNAMi_choice.R | 73 ++- .../test-effects_preprocessing_DyNAMi_rate.R | 163 +++-- ...ctions_effects_DyNAM_choice-init_default.R | 29 +- ...ctions_effects_DyNAM_choice-update_alter.R | 28 +- ...-functions_effects_DyNAM_rate-update_ego.R | 3 +- 29 files changed, 1163 insertions(+), 683 deletions(-) diff --git a/R/data_Fisheries_Treaties_6070.R b/R/data_Fisheries_Treaties_6070.R index 6c7258d..eb6f818 100644 --- a/R/data_Fisheries_Treaties_6070.R +++ b/R/data_Fisheries_Treaties_6070.R @@ -4,8 +4,8 @@ #' including only bilateral agreements, fewer variables, #' and ranging only between 1960 and 1970 inclusive. #' This data set is only meant for testing, and not for inference. -#' It provides an example of an undirected, weighted (by integer/increment) network, -#' with composition change and both monadic and dyadic covariates. +#' It provides an example of an undirected, weighted (by integer/increment) +#' network, with composition change and both monadic and dyadic covariates. #' Monadic variables include the dates states gain or lose sovereign status, #' their polity score, and their GDP. #' Dyadic variables include bilateral fisheries agreements between states, @@ -24,38 +24,42 @@ #' See below for variables and formats. #' #' \tabular{lll}{ -#' \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -#' states$label \tab Node identifier labels \tab character \cr -#' states$present \tab Node present in dataset \tab boolean \cr -#' states$regime \tab Placeholder for regime variable \tab numeric (NA) \cr -#' states$gdp \tab Placeholder for GDP variable \tab numeric (NA) \cr -#' sovchanges$time \tab Date of state sovereignty update \tab POSIXct \cr -#' sovchanges$node \tab Node for state sovereignty update \tab integer \cr -#' sovchanges$replace \tab State sovereignty update \tab boolean \cr -#' regchanges$time \tab Date of regime update \tab POSIXct \cr -#' regchanges$node \tab Node for regime update \tab integer \cr -#' regchanges$replace \tab Regime update \tab integer (-10--10) \cr -#' gdpchanges$time \tab Date of GDP update \tab POSIXct \cr -#' gdpchanges$node \tab Node for GDP update \tab integer \cr -#' gdpchanges$replace \tab GDP update \tab numeric \cr -#' bilatchanges$time \tab Date of bilateral change \tab POSIXct \cr -#' bilatchanges$sender \tab First bilateral change node \tab integer \cr -#' bilatchanges$receiver \tab Second bilateral change node \tab integer \cr -#' bilatchanges$increment \tab Create or dissolve action \tab numeric (-1 or 1) \cr -#' contigchanges$time \tab Date of contiguity change \tab POSIXct \cr -#' contigchanges$sender \tab First contiguity change node \tab integer \cr -#' contigchanges$receiver \tab Second contiguity change node \tab integer \cr -#' contigchanges$replace \tab New contiguity value \tab numeric \cr +#' \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr +#' states$label \tab Node identifier labels \tab character \cr +#' states$present \tab Node present in dataset \tab boolean \cr +#' states$regime \tab Placeholder for regime variable \tab numeric (NA) \cr +#' states$gdp \tab Placeholder for GDP variable \tab numeric (NA) \cr +#' sovchanges$time \tab Date of state sovereignty update \tab POSIXct \cr +#' sovchanges$node \tab Node for state sovereignty update \tab integer \cr +#' sovchanges$replace \tab State sovereignty update \tab boolean \cr +#' regchanges$time \tab Date of regime update \tab POSIXct \cr +#' regchanges$node \tab Node for regime update \tab integer \cr +#' regchanges$replace \tab Regime update \tab integer (-10--10) \cr +#' gdpchanges$time \tab Date of GDP update \tab POSIXct \cr +#' gdpchanges$node \tab Node for GDP update \tab integer \cr +#' gdpchanges$replace \tab GDP update \tab numeric \cr +#' bilatchanges$time \tab Date of bilateral change \tab POSIXct \cr +#' bilatchanges$sender \tab First bilateral change node \tab integer \cr +#' bilatchanges$receiver \tab Second bilateral change node \tab integer \cr +#' bilatchanges$increment\tab Create or dissolve tie\tab numeric (-1 or 1)\cr +#' contigchanges$time \tab Date of contiguity change \tab POSIXct \cr +#' contigchanges$sender \tab First contiguity change node \tab integer \cr +#' contigchanges$receiver \tab Second contiguity change node \tab integer \cr +#' contigchanges$replace \tab New contiguity value \tab numeric \cr #' } #' #' @references -#' Hollway, James, and Johan Koskinen. 2016. Multilevel Embeddedness: The Case of the Global Fisheries -#' Governance Complex. \emph{Social Networks}, 44: 281-94. doi:10.1016/j.socnet.2015.03.001. +#' Hollway, James, and Johan Koskinen. 2016. +#' Multilevel Embeddedness: The Case of the Global Fisheries Governance Complex. +#' \emph{Social Networks}, 44: 281-94. \doi{10.1016/j.socnet.2015.03.001}. #' -#' Hollway, James, and Johan H Koskinen. 2016. Multilevel Bilateralism and Multilateralism: States' Bilateral and +#' Hollway, James, and Johan H Koskinen. 2016. +#' Multilevel Bilateralism and Multilateralism: States' Bilateral and #' Multilateral Fisheries Treaties and Their Secretariats. -#' In \emph{Multilevel Network Analysis for the Social Sciences}, edited by Emmanuel Lazega and Tom A B Snijders, -#' 315-32. Cham: Springer International Publishing. doi:10.1007/978-3-319-24520-1_13. +#' In \emph{Multilevel Network Analysis for the Social Sciences}, +#' edited by Emmanuel Lazega and Tom A B Snijders, +#' 315-32. Cham: Springer International Publishing. +#' \doi{10.1007/978-3-319-24520-1_13}. #' #' @keywords datasets dynamic political network states fisheries NULL diff --git a/R/data_RFID_Validity_Study.R b/R/data_RFID_Validity_Study.R index 6054fc2..5036af6 100644 --- a/R/data_RFID_Validity_Study.R +++ b/R/data_RFID_Validity_Study.R @@ -14,31 +14,39 @@ #' @docType data #' @usage data(RFID_Validity_Study) #' @format 3 dataframes: \cr -#' - participants (11 rows, 7 columns): attributes of the experiment's participants\cr -#' - rfid (1011 rows, 4 columns): dyadic interactions detected by the RFID badges (after data processing)\cr -#' - video (219 rows, 4 columns): dyadic interactions detected by the video rating\cr +#' - participants (11 rows, 7 columns): +#' attributes of the experiment's participants\cr +#' - rfid (1011 rows, 4 columns): dyadic interactions detected +#' by the RFID badges (after data processing)\cr +#' - video (219 rows, 4 columns): dyadic interactions detected +#' by the video rating\cr #' and one network:\cr #' - known.before (11 rows, 11 columns): network of previous acquaintances\cr #' See below for variables and formats.\cr #' #'\tabular{lll}{ #' \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -#' participants$actor \tab Identifier of the actor \tab integer \cr -#' participants$label \tab (Anonymized) name \tab Factor \cr -#' participants$present \tab Presence of the actor (all actors are present) \tab logical \cr -#' participants$age \tab Actor's age \tab integer \cr -#' participants$gender \tab Actor's gender (0: male, 1: female) \tab integer \cr -#' participants$group \tab Actor's group affiliation (groups have distinct ids) \tab integer \cr -#' participants$level \tab Actor's seniority (1: MSc student, 2: PhD student, 3: PostDoc, 4: Prof) -#' \tab integer \cr -#' rfid$NodeA \tab Identifier for the first actor \tab chr \cr -#' rfid$NodeB \tab Identifier for the second actor \tab chr \cr -#' rfid$Start \tab Time of the beginning of the dyadic interaction \tab integer \cr -#' rfid$End \tab Time of the end of the dyadic interaction \tab integer \cr -#' video$NodeA \tab Identifier for the first actor \tab chr \cr -#' video$NodeB \tab Identifier for the second actor \tab chr \cr -#' video$Start \tab Time of the beginning of the dyadic interaction \tab integer \cr -#' video$End \tab Time of the end of the dyadic interaction \tab integer \cr +#' participants$actor \tab Identifier of the actor \tab integer \cr +#' participants$label \tab (Anonymized) name \tab Factor \cr +#' participants$present \tab Presence of the actor (all actors are present) +#' \tab logical \cr +#' participants$age \tab Actor's age \tab integer \cr +#' participants$gender \tab Actor's gender (0: male, 1: female) +#' \tab integer \cr +#' participants$group +#' \tab Actor's group affiliation (groups have distinct ids) \tab integer \cr +#' participants$level \tab Actor's seniority +#' (1: MSc student, 2: PhD student, 3: PostDoc, 4: Prof) \tab integer \cr +#' rfid$NodeA \tab Identifier for the first actor \tab chr \cr +#' rfid$NodeB \tab Identifier for the second actor \tab chr \cr +#' rfid$Start \tab Time of the beginning of the dyadic interaction +#' \tab integer \cr +#' rfid$End \tab Time of the end of the dyadic interaction \tab integer \cr +#' video$NodeA \tab Identifier for the first actor \tab chr \cr +#' video$NodeB \tab Identifier for the second actor \tab chr \cr +#' video$Start \tab Time of the beginning of the dyadic interaction +#' \tab integer \cr +#' video$End \tab Time of the end of the dyadic interaction \tab integer \cr #' } #' #' @source \url{https://osf.io/rrhxe/} diff --git a/R/data_Social_Evolution.R b/R/data_Social_Evolution.R index 74afa6b..e4b1b07 100644 --- a/R/data_Social_Evolution.R +++ b/R/data_Social_Evolution.R @@ -10,29 +10,35 @@ #' @name Social_Evolution #' @docType data #' @usage data(Social_Evolution) -#' @format 3 dataframes: actors (84 rows, 4 columns), calls (439 rows, 4 columns), friendship (766 rows, 4 columns). +#' @format 3 dataframes: actors (84 rows, 4 columns), +#' calls (439 rows, 4 columns), friendship (766 rows, 4 columns). #' See below for variables and formats. #' #' \tabular{lll}{ -#' \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -#' actors$label \tab Actor identifier labels \tab character \cr -#' actors$present \tab Actor present in dataset \tab boolean \cr -#' actors$floor \tab Floor of residence actor lives on \tab numeric (1-9) \cr -#' actors$gradeType \tab Degree level \tab numeric (1-5) \cr -#' calls$time \tab Time and date of call \tab numeric from POSIXct \cr -#' calls$sender \tab Initiator of phone call \tab character \cr -#' calls$receiver \tab Recipient of phone call \tab character \cr -#' calls$increment \tab Indicates call number increment (all 1s) \tab numeric (1) \cr -#' friendship$time \tab Time and date of friend nomination \tab numeric from POSIXct \cr -#' friendship$sender \tab Nominator of friendship \tab character \cr -#' friendship$receiver \tab Nominee of friendship \tab character \cr -#' friendship$replace \tab Indicates friendship value at $time \tab numeric \cr +#' \strong{Object} \tab \strong{Description} \tab\strong{Format} \cr +#' actors$label \tab Actor identifier labels \tab character \cr +#' actors$present \tab Actor present in dataset \tab boolean \cr +#' actors$floor \tab Floor of residence actor lives on +#' \tab numeric (1-9) \cr +#' actors$gradeType \tab Degree level \tab numeric (1-5) \cr +#' calls$time \tab Time and date of call \tab numeric from POSIXct \cr +#' calls$sender \tab Initiator of phone call \tab character \cr +#' calls$receiver \tab Recipient of phone call \tab character \cr +#' calls$increment \tab Indicates call number increment (all 1s) +#' \tab numeric (1) \cr +#' friendship$time \tab Time and date of friend nomination +#' \tab numeric from POSIXct \cr +#' friendship$sender \tab Nominator of friendship \tab character \cr +#' friendship$receiver \tab Nominee of friendship \tab character \cr +#' friendship$replace \tab Indicates friendship value at $time +#' \tab numeric \cr #' } #' #' @source \url{http://realitycommons.media.mit.edu/socialevolution.html} #' @references -#' A. Madan, M. Cebrian, S. Moturu, K. Farrahi, A. Pentland (2012). Sensing the 'Health State' of a Community. -#' \emph{Pervasive Computing. 11}, 4, pp. 36-45. +#' A. Madan, M. Cebrian, S. Moturu, K. Farrahi, A. Pentland (2012). +#' Sensing the 'Health State' of a Community. +#' \emph{Pervasive Computing. 11}, 4, pp. 36-45. \doi{10.1109/MPRV.2011.79}. #' #' @keywords datasets social evolution network NULL diff --git a/R/functions_diagnostics.R b/R/functions_diagnostics.R index 7d4b5e7..1006593 100644 --- a/R/functions_diagnostics.R +++ b/R/functions_diagnostics.R @@ -120,8 +120,10 @@ examineOutliers <- function(x, if (length(outlierIndexes > 0)) { data$outlier[outlierIndexes] <- "YES" - data$label[outlierIndexes] <- paste(data$sender, - data$receiver, sep = "-")[outlierIndexes] + data$label[outlierIndexes] <- paste( + data$sender, + data$receiver, sep = "-" + )[outlierIndexes] } else { return(cat("No outliers found.")) } diff --git a/R/functions_effects_DyNAM_choice.R b/R/functions_effects_DyNAM_choice.R index 09c7898..b75fce9 100644 --- a/R/functions_effects_DyNAM_choice.R +++ b/R/functions_effects_DyNAM_choice.R @@ -1220,9 +1220,15 @@ init_DyNAM_choice.commonSender <- function(effectFun, network, window, n1, n2) { #' 0, 0, 1, 1, 2), #' nrow = 5, ncol = 5) #' -#' update_DyNAM_choice_commonSender(network, 1, 2, 5, cache, transformFun = sqrt) -#' update_DyNAM_choice_commonSender(network, 5, 1, 0, cache, transformFun = sqrt) -#' update_DyNAM_choice_commonSender(network, 2, 4, 5, cache, transformFun = sqrt) +#' update_DyNAM_choice_commonSender( +#' network, 1, 2, 5, cache, transformFun = sqrt +#' ) +#' update_DyNAM_choice_commonSender( +#' network, 5, 1, 0, cache, transformFun = sqrt +#' ) +#' update_DyNAM_choice_commonSender( +#' network, 2, 4, 5, cache, transformFun = sqrt +#' ) #' } update_DyNAM_choice_commonSender <- function( network, diff --git a/R/functions_effects_DyNAM_rate.R b/R/functions_effects_DyNAM_rate.R index cc12f6f..6759781 100644 --- a/R/functions_effects_DyNAM_rate.R +++ b/R/functions_effects_DyNAM_rate.R @@ -25,13 +25,15 @@ init_DyNAM_rate.default <- function( # indeg ------------------------------------------------------------------- #' init stat matrix indegree using cache #' -#' @param effectFun function with additional parameters weighted, isTwoMode, transformFun +#' @param effectFun function with additional parameters weighted, +#' isTwoMode, transformFun #' @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 +#' @return list with named components: cache numeric vector size n2, +#' stat matrix numeric n1*n2 #' @noRd #' #' @examples @@ -46,7 +48,9 @@ init_DyNAM_rate.default <- function( #' ), #' nrow = 5, ncol = 6, byrow = TRUE #' ) -#' effectFUN <- function(weighted = TRUE, isTwoMode = TRUE, transformFun = identity) +#' effectFUN <- function( +#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity +#' ) #' NULL #' init_REM_choice.indeg(effectFUN, network, 5, 6) #' network <- matrix( @@ -59,11 +63,16 @@ init_DyNAM_rate.default <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(weighted = TRUE, isTwoMode = FALSE, transformFun = identity) +#' effectFUN <- function( +#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity +#' ) #' NULL #' init_DyNAM_rate.indeg(effectFUN, network, NULL, 5, 5) #' -#' effectFUN <- function(weighted = TRUE, isTwoMode = FALSE, transformFun = identity, type = "alter") +#' effectFUN <- function( +#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity, +#' type = "alter" +#' ) #' NULL #' init_DyNAM_rate.indeg(effectFUN, network, NULL, 5, 5) #' } @@ -179,9 +188,11 @@ init_DyNAM_rate.tertius <- function( effectFun, network, attribute, window, n1, n2 ) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) - init_REM_choice.tertius(effectFun = effectFun, network = network, attribute = attribute, - window = window, - n1 = n1, n2 = n2) + init_REM_choice.tertius( + effectFun = effectFun, network = network, attribute = attribute, + window = window, + n1 = n1, n2 = n2 + ) } update_DyNAM_rate_tertius <- function( diff --git a/R/functions_effects_DyNAMi_choice.R b/R/functions_effects_DyNAMi_choice.R index 0e7c26d..0dc0200 100644 --- a/R/functions_effects_DyNAMi_choice.R +++ b/R/functions_effects_DyNAMi_choice.R @@ -17,7 +17,10 @@ init_DyNAMi_choice.default <- function(effectFun, # print(match.call()) if (is.null(network) && is.null(attribute)) { # this check could be unnecessary - stop("the effect function doesn't specify neither a network nor an attribute as argument") + stop( + "the effect function doesn't specify neither a network", + " nor an attribute as argument" + ) } # if multiple networks, attributes or combination of both are specified. @@ -35,13 +38,18 @@ init_DyNAMi_choice.default <- function(effectFun, # check if not empty network to initialize the statistical matrix # create a copy of the network to iterate over if (hasMultNets) { - areEmpty <- vapply(network, function(x) all(x[!is.na(x)] == 0), logical(1)) + areEmpty <- vapply( + network, + \(x) all(x[!is.na(x)] == 0), + logical(1) + ) if ((!is.null(window) && !is.infinite(window)) || any(areEmpty)) { return(stats) } netIter <- network[[1]] } else { - if ((!is.null(window) && !is.infinite(window)) || all(network[!is.na(network)] == 0)) { + if ((!is.null(window) && !is.infinite(window)) || + all(network[!is.na(network)] == 0)) { return(stats) } netIter <- network @@ -50,7 +58,11 @@ init_DyNAMi_choice.default <- function(effectFun, emptyObject <- array(0, dim = dim(netIter)) } else { if (hasMultAtt) { - areEmpty <- vapply(attribute, function(x) all(x[!is.na(x)] == 0), logical(1)) + areEmpty <- vapply( + attribute, + \(x) all(x[!is.na(x)] == 0), + logical(1) + ) if (any(areEmpty)) { return(stats) } @@ -145,11 +157,13 @@ init_DyNAMi_choice.default <- function(effectFun, # tie --------------------------------------------------------------------- # init_DyNAMi_choice_tie <- function() -update_DyNAMi_choice_tie <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "proportion") { +update_DyNAMi_choice_tie <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "proportion" +) { reptotal <- NULL @@ -206,11 +220,13 @@ update_DyNAMi_choice_tie <- function(network, # inertia ----------------------------------------------------------------- # init_DyNAMi_choice_inertia <- function() -update_DyNAMi_choice_inertia <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "proportion") { +update_DyNAMi_choice_inertia <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "proportion" +) { reptotal <- NULL @@ -271,11 +287,13 @@ update_DyNAMi_choice_inertia <- function(network, #' alterdeg effects DyNAM-i choice #' @importFrom stats sd #' @noRd -update_DyNAMi_choice_alterdeg <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "mean") { +update_DyNAMi_choice_alterdeg <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "mean" +) { reptotal <- NULL meandeg <- mean(rowSums(network)) @@ -309,7 +327,8 @@ update_DyNAMi_choice_alterdeg <- function(network, rep <- sum(network[smembers, ]) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 } if (subType == "min") { rep <- sum(network[smembers, ]) @@ -325,7 +344,9 @@ update_DyNAMi_choice_alterdeg <- function(network, rep <- mean(rowSums(network[smembers, ])) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg + else rep <- 0 } if (subType == "min") { rep <- min(rowSums(network[smembers, ])) @@ -350,27 +371,33 @@ update_DyNAMi_choice_alterdeg <- function(network, # alterpop ------------------------------------------------------------------- # init_DyNAMi_choice_alterpop <- function() -update_DyNAMi_choice_alterpop <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "mean_normalized") { -update_DyNAMi_choice_alterdeg(network = network, - groupsNetwork = groupsNetwork, - sender = sender, receiver = receiver, replace = replace, - n1 = n1, n2 = n2, statistics = statistics, - weighted = weighted, subType = subType) +update_DyNAMi_choice_alterpop <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "mean_normalized" +) { + update_DyNAMi_choice_alterdeg( + network = network, + groupsNetwork = groupsNetwork, + sender = sender, receiver = receiver, replace = replace, + n1 = n1, n2 = n2, statistics = statistics, + weighted = weighted, subType = subType + ) } # size ------------------------------------------------------------------- # init_DyNAMi_choice_size <- function() -update_DyNAMi_choice_size <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "identity") { +update_DyNAMi_choice_size <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "identity" +) { reptotal <- NULL @@ -408,11 +435,13 @@ update_DyNAMi_choice_size <- function(network, # dyad ------------------------------------------------------------------- # init_DyNAMi_choice_dyad <- function() -update_DyNAMi_choice_dyad <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "identity") { +update_DyNAMi_choice_dyad <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "identity" +) { reptotal <- NULL @@ -450,12 +479,14 @@ update_DyNAMi_choice_dyad <- function(network, # alter ------------------------------------------------------------------- # init_DyNAMi_choice_alter <- function() -update_DyNAMi_choice_alter <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "mean", - node = 0) { +update_DyNAMi_choice_alter <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "mean", + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) @@ -494,7 +525,8 @@ update_DyNAMi_choice_alter <- function(attribute, rep <- (mean(attribute[smembers]) - meanatt)^2 } if (subType == "mean_normalized") { - if (sdatt > 0) rep <- (mean(attribute[smembers]) - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) rep <- (mean(attribute[smembers]) - meanatt) / sdatt + else rep <- 0 } if (subType == "min") { rep <- min(attribute[smembers]) @@ -536,12 +568,14 @@ update_DyNAMi_choice_alter <- function(attribute, # same -------------------------------------------------------------------- # init_DyNAMi_choice_same <- function() -update_DyNAMi_choice_same <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "proportion", - node = 0) { +update_DyNAMi_choice_same <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "proportion", + node = 0 +) { reptotal <- NULL for (i in seq.int(n1)) { @@ -586,12 +620,14 @@ update_DyNAMi_choice_same <- function(attribute, # diff -------------------------------------------------------------------- # init_DyNAMi_choice_diff <- function() -update_DyNAMi_choice_diff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - node = 0) { +update_DyNAMi_choice_diff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + node = 0 +) { reptotal <- NULL for (i in seq.int(n1)) { @@ -649,12 +685,14 @@ update_DyNAMi_choice_diff <- function(attribute, # sim --------------------------------------------------------------------- # init_DyNAMi_choice_sim <- function() -update_DyNAMi_choice_sim <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - node = 0) { +update_DyNAMi_choice_sim <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + node = 0 +) { reptotal <- NULL for (i in seq.int(n1)) { @@ -704,12 +742,14 @@ update_DyNAMi_choice_sim <- function(attribute, # sizeXdiff --------------------------------------------------------------- # init_DyNAMi_choice_sizeXdiff <- function() -update_DyNAMi_choice_sizeXdiff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - node = 0) { +update_DyNAMi_choice_sizeXdiff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + node = 0 +) { reptotal <- NULL for (i in seq.int(n1)) { @@ -733,7 +773,8 @@ update_DyNAMi_choice_sizeXdiff <- function(attribute, } if (subType == "averaged_sum") { - rep <- snmembers * sum(abs(attribute[smembers] - attribute[i])) / snmembers + rep <- snmembers * sum(abs(attribute[smembers] - attribute[i])) / + snmembers } if (subType == "mean") { rep <- snmembers * abs(mean(attribute[smembers]) - attribute[i]) @@ -755,15 +796,17 @@ update_DyNAMi_choice_sizeXdiff <- function(attribute, } -# dyadXdiff --------------------------------------------------------------------- +# dyadXdiff ------------------------------------------------------------------- # init_DyNAMi_choice_dyadXdiff <- function() -update_DyNAMi_choice_dyadXdiff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - node = 0) { +update_DyNAMi_choice_dyadXdiff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + node = 0 +) { reptotal <- NULL for (i in seq.int(n1)) { @@ -817,12 +860,14 @@ update_DyNAMi_choice_dyadXdiff <- function(attribute, # sizeXego --------------------------------------------------------------- # init_DyNAMi_choice_sizeXego <- function() -update_DyNAMi_choice_sizeXego <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "identity", - node = 0) { +update_DyNAMi_choice_sizeXego <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "identity", + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -857,7 +902,8 @@ update_DyNAMi_choice_sizeXego <- function(attribute, rep <- snmembers * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) rep <- snmembers * (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) rep <- snmembers * (attribute[i] - meanatt) / sdatt + else rep <- 0 } if (statistics[i, j] != rep) { @@ -871,12 +917,14 @@ update_DyNAMi_choice_sizeXego <- function(attribute, # dyadXego --------------------------------------------------------------- # init_DyNAMi_choice_dyadXego <- function() -update_DyNAMi_choice_dyadXego <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "identity", - node = 0) { +update_DyNAMi_choice_dyadXego <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "identity", + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) diff --git a/R/functions_effects_DyNAMi_rate.R b/R/functions_effects_DyNAMi_rate.R index d4aa73c..076bba4 100644 --- a/R/functions_effects_DyNAMi_rate.R +++ b/R/functions_effects_DyNAMi_rate.R @@ -5,26 +5,32 @@ init_DyNAMi_rate <- function(effectFun, network, attribute) { } # default ----------------------------------------------------------------- -init_DyNAMi_rate.default <- function(effectFun, - network = NULL, attribute = NULL, - groupsNetwork, window, - n1, n2) { - init_DyNAMi_choice.default(effectFun = effectFun, - network = network, attribute = attribute, - groupsNetwork = groupsNetwork, window = window, - n1 = n1, n2 = n2) +init_DyNAMi_rate.default <- function( + effectFun, + network = NULL, attribute = NULL, + groupsNetwork, window, + n1, n2 +) { + init_DyNAMi_choice.default( + effectFun = effectFun, + network = network, attribute = attribute, + groupsNetwork = groupsNetwork, window = window, + n1 = n1, n2 = n2 + ) } # Structural effects ------------------------------------------------------ -# intercept --------------------------------------------------------------------- +# intercept ------------------------------------------------------------------- # initStat_DyNAMi_rate_intercept <- function() -update_DyNAMi_rate_intercept <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, - joining = 1) { +update_DyNAMi_rate_intercept <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, + joining = 1 +) { reptotal <- NULL @@ -34,16 +40,23 @@ update_DyNAMi_rate_intercept <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 1) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 1)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 1) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -55,16 +68,23 @@ update_DyNAMi_rate_intercept <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (isingroup) { if (statistics[i, 1] != 1) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 1)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 1) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -77,31 +97,35 @@ update_DyNAMi_rate_intercept <- function(network, # inertia --------------------------------------------------------------------- # initStat_DyNAMi_rate_inertia <- function() -update_DyNAMi_rate_inertia <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = TRUE, subType = "proportion", - joining = -1) { -update_DyNAMi_rate_tie(network = network, - groupsNetwork = groupsNetwork, - sender = sender, receiver = receiver, replace = replace, - n1 = n1, n2 = n2, statistics = statistics, - weighted = weighted, subType = subType, - joining = joining) +update_DyNAMi_rate_inertia <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = TRUE, subType = "proportion", + joining = -1 +) { + update_DyNAMi_rate_tie( + network = network, + groupsNetwork = groupsNetwork, + sender = sender, receiver = receiver, replace = replace, + n1 = n1, n2 = n2, statistics = statistics, + weighted = weighted, subType = subType, + joining = joining + ) } - - # tie --------------------------------------------------------------------- # initStat_DyNAMi_rate_tie <- function() -update_DyNAMi_rate_tie <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "proportion", - joining = -1) { +update_DyNAMi_rate_tie <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "proportion", + joining = -1 +) { reptotal <- NULL @@ -110,11 +134,15 @@ update_DyNAMi_rate_tie <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -144,7 +172,10 @@ update_DyNAMi_rate_tie <- function(network, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } } @@ -152,16 +183,17 @@ update_DyNAMi_rate_tie <- function(network, return(reptotal) } - # egodeg ------------------------------------------------------------------- # initStat_DyNAMi_rate_egodeg <- function() -update_DyNAMi_rate_egodeg <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = TRUE, subType = "identity", - joining = 1) { +update_DyNAMi_rate_egodeg <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = TRUE, subType = "identity", + joining = 1 +) { reptotal <- NULL meandeg <- mean(rowSums(network)) @@ -174,7 +206,8 @@ update_DyNAMi_rate_egodeg <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i,] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (subType == "identity") { @@ -184,16 +217,23 @@ update_DyNAMi_rate_egodeg <- function(network, rep <- sum(network[i, ]) - meandeg } if (subType == "normalized") { - if (sddeg > 0) rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -206,7 +246,8 @@ update_DyNAMi_rate_egodeg <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (isingroup) { if (subType == "identity") { @@ -216,16 +257,23 @@ update_DyNAMi_rate_egodeg <- function(network, rep <- sum(network[i, ]) - meandeg } if (subType == "normalized") { - if (sddeg > 0) rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -238,29 +286,35 @@ update_DyNAMi_rate_egodeg <- function(network, # egopop ------------------------------------------------------------------- # initStat_DyNAMi_rate_egopop <- function() -update_DyNAMi_rate_egopop <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = TRUE, subType = "normalized", - joining = 1) { - update_DyNAMi_rate_egodeg(network = network, - groupsNetwork = groupsNetwork, - sender = sender, receiver = receiver, replace = replace, - n1 = n1, n2 = n2, statistics = statistics, - weighted = weighted, subType = subType, - joining = joining) +update_DyNAMi_rate_egopop <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = TRUE, subType = "normalized", + joining = 1 +) { + update_DyNAMi_rate_egodeg( + network = network, + groupsNetwork = groupsNetwork, + sender = sender, receiver = receiver, replace = replace, + n1 = n1, n2 = n2, statistics = statistics, + weighted = weighted, subType = subType, + joining = joining + ) } # alterdeg ------------------------------------------------------------------- # initStat_DyNAMi_rate_alterdeg <- function() -update_DyNAMi_rate_alterdeg <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = TRUE, subType = "mean", - joining = -1) { +update_DyNAMi_rate_alterdeg <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = TRUE, subType = "mean", + joining = -1 +) { reptotal <- NULL meandeg <- mean(rowSums(network)) @@ -275,11 +329,15 @@ update_DyNAMi_rate_alterdeg <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -297,7 +355,8 @@ update_DyNAMi_rate_alterdeg <- function(network, rep <- sum(network[smembers, ]) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 } if (subType == "min") { rep <- sum(network[smembers, ]) @@ -313,7 +372,9 @@ update_DyNAMi_rate_alterdeg <- function(network, rep <- mean(rowSums(network[smembers, ])) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) + rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg + else rep <- 0 } if (subType == "min") { rep <- min(rowSums(network[smembers, ])) / maxdeg @@ -324,7 +385,10 @@ update_DyNAMi_rate_alterdeg <- function(network, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -336,29 +400,35 @@ update_DyNAMi_rate_alterdeg <- function(network, # alterpop ------------------------------------------------------------------- # initStat_DyNAMi_rate_alterpop <- function() -update_DyNAMi_rate_alterpop <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = TRUE, subType = "mean_normalized", - joining = -1) { - update_DyNAMi_rate_alterdeg(network = network, - groupsNetwork = groupsNetwork, - sender = sender, receiver = receiver, replace = replace, - n1 = n1, n2 = n2, statistics = statistics, - weighted = weighted, subType = subType, - joining = joining) +update_DyNAMi_rate_alterpop <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = TRUE, subType = "mean_normalized", + joining = -1 +) { + update_DyNAMi_rate_alterdeg( + network = network, + groupsNetwork = groupsNetwork, + sender = sender, receiver = receiver, replace = replace, + n1 = n1, n2 = n2, statistics = statistics, + weighted = weighted, subType = subType, + joining = joining + ) } # size ------------------------------------------------------------------- # initStat_DyNAMi_rate_size <- function() -update_DyNAMi_rate_size <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "identity", - joining = -1) { +update_DyNAMi_rate_size <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "identity", + joining = -1 +) { reptotal <- NULL @@ -370,11 +440,15 @@ update_DyNAMi_rate_size <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -393,7 +467,10 @@ update_DyNAMi_rate_size <- function(network, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -406,12 +483,14 @@ update_DyNAMi_rate_size <- function(network, # dyad ------------------------------------------------------------------- # initStat_DyNAMi_rate_dyad <- function() -update_DyNAMi_rate_dyad <- function(network, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - weighted = FALSE, subType = "identity", - joining = -1) { +update_DyNAMi_rate_dyad <- function( + network, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + weighted = FALSE, subType = "identity", + joining = -1 +) { reptotal <- NULL @@ -423,11 +502,15 @@ update_DyNAMi_rate_dyad <- function(network, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -444,7 +527,10 @@ update_DyNAMi_rate_dyad <- function(network, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -460,13 +546,15 @@ update_DyNAMi_rate_dyad <- function(network, # ego ------------------------------------------------------------------- # initStat_DyNAMi_rate_ego <- function() -update_DyNAMi_rate_ego <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "identity", - joining = 1, - node = 0) { +update_DyNAMi_rate_ego <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "identity", + joining = 1, + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) @@ -479,7 +567,8 @@ update_DyNAMi_rate_ego <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (subType == "identity") { @@ -492,16 +581,23 @@ update_DyNAMi_rate_ego <- function(attribute, rep <- attribute[i] - meanatt } if (subType == "normalized") { - if (sdatt > 0) rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) + rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -515,7 +611,8 @@ update_DyNAMi_rate_ego <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (isingroup) { if (subType == "identity") { @@ -528,16 +625,23 @@ update_DyNAMi_rate_ego <- function(attribute, rep <- attribute[i] - meanatt } if (subType == "normalized") { - if (sdatt > 0) rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) + rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -550,13 +654,15 @@ update_DyNAMi_rate_ego <- function(attribute, # alter ------------------------------------------------------------------- # initStat_DyNAMi_rate_alter <- function() -update_DyNAMi_rate_alter <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "mean", - joining = -1, - node = 0) { +update_DyNAMi_rate_alter <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "mean", + joining = -1, + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) @@ -570,11 +676,15 @@ update_DyNAMi_rate_alter <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -597,7 +707,8 @@ update_DyNAMi_rate_alter <- function(attribute, rep <- (mean(attribute[smembers]) - meanatt)^2 } if (subType == "mean_normalized") { - if (sdatt > 0) rep <- (mean(attribute[smembers]) - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) + rep <- (mean(attribute[smembers]) - meanatt) / sdatt else rep <- 0 } if (subType == "min") { rep <- min(attribute[smembers]) @@ -628,7 +739,10 @@ update_DyNAMi_rate_alter <- function(attribute, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -641,13 +755,15 @@ update_DyNAMi_rate_alter <- function(attribute, # same -------------------------------------------------------------------- # initStat_DyNAMi_rate_same <- function() -update_DyNAMi_rate_same <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "proportion", - joining = -1, - node = 0) { +update_DyNAMi_rate_same <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "proportion", + joining = -1, + node = 0 +) { reptotal <- NULL # LEAVING MODEL @@ -658,11 +774,15 @@ update_DyNAMi_rate_same <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -683,7 +803,10 @@ update_DyNAMi_rate_same <- function(attribute, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -695,13 +818,15 @@ update_DyNAMi_rate_same <- function(attribute, # diff -------------------------------------------------------------------- # initStat_DyNAMi_rate_diff <- function() -update_DyNAMi_rate_diff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - joining = -1, - node = 0) { +update_DyNAMi_rate_diff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + joining = -1, + node = 0 +) { reptotal <- NULL # LEAVING MODEL @@ -712,11 +837,15 @@ update_DyNAMi_rate_diff <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -749,7 +878,10 @@ update_DyNAMi_rate_diff <- function(attribute, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -762,13 +894,15 @@ update_DyNAMi_rate_diff <- function(attribute, # sim --------------------------------------------------------------------- # initStat_DyNAMi_rate_sim <- function() -update_DyNAMi_rate_sim <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - joining = -1, - node = 0) { +update_DyNAMi_rate_sim <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + joining = -1, + node = 0 +) { reptotal <- NULL # LEAVING MODEL @@ -779,11 +913,15 @@ update_DyNAMi_rate_sim <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -807,7 +945,10 @@ update_DyNAMi_rate_sim <- function(attribute, } if (statistics[i, 1] != 1) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -822,13 +963,15 @@ update_DyNAMi_rate_sim <- function(attribute, # sizeXdiff --------------------------------------------------------------- # initStat_DyNAMi_rate_sizeXdiff <- function() -update_DyNAMi_rate_sizeXdiff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - joining = -1, - node = 0) { +update_DyNAMi_rate_sizeXdiff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + joining = -1, + node = 0 +) { reptotal <- NULL # LEAVING MODEL @@ -839,11 +982,15 @@ update_DyNAMi_rate_sizeXdiff <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -854,7 +1001,8 @@ update_DyNAMi_rate_sizeXdiff <- function(attribute, snmembers <- length(smembers) if (subType == "averaged_sum") { - rep <- nmembers * sum(abs(attribute[smembers] - attribute[i])) / snmembers + rep <- nmembers * + sum(abs(attribute[smembers] - attribute[i])) / snmembers } if (subType == "mean") { rep <- nmembers * abs(mean(attribute[smembers]) - attribute[i]) @@ -867,7 +1015,10 @@ update_DyNAMi_rate_sizeXdiff <- function(attribute, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -880,13 +1031,15 @@ update_DyNAMi_rate_sizeXdiff <- function(attribute, # dyadXdiff --------------------------------------------------------------- # initStat_DyNAMi_rate_dyadXdiff <- function() -update_DyNAMi_rate_dyadXdiff <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "averaged_sum", - joining = -1, - node = 0) { +update_DyNAMi_rate_dyadXdiff <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "averaged_sum", + joining = -1, + node = 0 +) { reptotal <- NULL # LEAVING MODEL @@ -897,11 +1050,15 @@ update_DyNAMi_rate_dyadXdiff <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 if (!isingroup) { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } next } @@ -931,7 +1088,10 @@ update_DyNAMi_rate_dyadXdiff <- function(attribute, } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } } @@ -943,13 +1103,15 @@ update_DyNAMi_rate_dyadXdiff <- function(attribute, # sizeXego ------------------------------------------------------------------- # initStat_DyNAMi_rate_sizeXego <- function() -update_DyNAMi_rate_sizeXego <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "identity", - joining = -1, - node = 0) { +update_DyNAMi_rate_sizeXego <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "identity", + joining = -1, + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) @@ -962,7 +1124,8 @@ update_DyNAMi_rate_sizeXego <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 members <- which(groupsNetwork[, owngroup] == 1) nmembers <- length(members) @@ -980,16 +1143,23 @@ update_DyNAMi_rate_sizeXego <- function(attribute, rep <- nmembers * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) rep <- nmembers * (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) + rep <- nmembers * (attribute[i] - meanatt) / sdatt else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } @@ -1002,13 +1172,15 @@ update_DyNAMi_rate_sizeXego <- function(attribute, # dyadXego ------------------------------------------------------------------- # initStat_DyNAMi_rate_dyadXego <- function() -update_DyNAMi_rate_dyadXego <- function(attribute, - groupsNetwork, - sender, receiver, replace, - n1, n2, statistics, - subType = "identity", - joining = -1, - node = 0) { +update_DyNAMi_rate_dyadXego <- function( + attribute, + groupsNetwork, + sender, receiver, replace, + n1, n2, statistics, + subType = "identity", + joining = -1, + node = 0 +) { reptotal <- NULL meanatt <- mean(attribute) @@ -1021,7 +1193,8 @@ update_DyNAMi_rate_dyadXego <- function(attribute, for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + if (length(owngroup) == 1) + isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 members <- which(groupsNetwork[, owngroup] == 1) nmembers <- length(members) @@ -1045,16 +1218,23 @@ update_DyNAMi_rate_dyadXego <- function(attribute, rep <- m * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) rep <- m * (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) + rep <- m * (attribute[i] - meanatt) / sdatt else rep <- 0 } if (statistics[i, 1] != rep) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = rep)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = rep) + ) } next } else { if (statistics[i, 1] != 0) { - reptotal <- rbind(reptotal, cbind(node1 = i, node2 = seq.int(n2), replace = 0)) + reptotal <- rbind( + reptotal, + cbind(node1 = i, node2 = seq.int(n2), replace = 0) + ) } } } diff --git a/R/functions_effects_REM.R b/R/functions_effects_REM.R index 2244a6b..4edfb22 100644 --- a/R/functions_effects_REM.R +++ b/R/functions_effects_REM.R @@ -1097,14 +1097,17 @@ update_REM_choice_tertiusDiff <- function( # 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 +#' 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 +#' @return list with named components: cache numeric vector size n2, +#' stat matrix numeric n1*n2 #' @noRd #' #' @examples diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index f073f90..98dfd3d 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -1216,7 +1216,8 @@ reduceStatisticsList <- function( } # This part should be uncommented once we are sure about how to use - # these reductions through the whole estimation. For now we reduce at each step + # these reductions through the whole estimation. + # For now we reduce at each step # # reduce statistics matrix to a vector # if(reduceMatrixToVector) { @@ -1256,7 +1257,8 @@ reduceStatisticsList <- function( # drop statistics with a time span of zero if (dropZeroTimespans) { hasZeroTime <- which(statsList$intervals == 0) - statsList$dependentStatsChange <- statsList$dependentStatsChange[-hasZeroTime] + statsList$dependentStatsChange <- + statsList$dependentStatsChange[-hasZeroTime] statsList$intervals <- statsList$intervals[-hasZeroTime] hasZeroTime <- which(statsList$rightCensoredIntervals == 0) statsList$rightCensoredStatsChange <- diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index 0fda678..4f99349 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -542,13 +542,6 @@ estimate_c_int <- function( estimationResult } - - -########################################################################################### ### -# different implementation for different modelTypeCall - - - ## ESTIMATE FOR DIFFERENT MODELS estimate_ <- function( modelTypeCall, diff --git a/R/functions_group_interaction_utility.R b/R/functions_group_interaction_utility.R index 1b8ec0d..5f904b0 100644 --- a/R/functions_group_interaction_utility.R +++ b/R/functions_group_interaction_utility.R @@ -134,7 +134,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, } } - # STEP 2: go through all interactions recorded, and assign temporary groups to actors through all the times of events + # STEP 2: go through all interactions recorded, and assign temporary groups + # to actors through all the times of events uniqueevents <- unique(timesevents) # aggregate all events at the same time nevents <- length(uniqueevents) groupassignment <- matrix(0, nactors, nevents) # temporary assignment @@ -168,7 +169,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, areinteracting <- 0 if (length(inda1a2) > 0) { for (j in seq.int(length(inda1a2))) { - if (records$Start[inda1a2[j]] <= time && records$End[inda1a2[j]] > time) { + if (records$Start[inda1a2[j]] <= time && + records$End[inda1a2[j]] > time) { areinteracting <- 1 } } @@ -188,7 +190,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # are the others previously assigned? if (isinteracting && min(which(tempnet[a1, ] == 1)) < a1) { - groupassignment[a1, i] <- groupassignment[min(which(tempnet[a1, ] == 1)), i] + groupassignment[a1, i] <- + groupassignment[min(which(tempnet[a1, ] == 1)), i] } else { # if not, assign a new group groupassignment[a1, i] <- g g <- g + 1 @@ -208,24 +211,29 @@ defineGroups_interaction <- function(records, actors, seed.randomization, } } - # STEP 3: define the joining and leaving events from the start and end events and group assignments + # STEP 3: define the joining and leaving events from the start + # and end events and group assignments # # groups: data.frame(label, present) - # # composition.changes: data.frame(time = grouptimeevents, - # # node = groupevents, - # # replace = groupreplaceevents) +/-1 if creation/deletion + # # composition.changes: + # # data.frame(time = grouptimeevents, + # # node = groupevents, + # # replace = groupreplaceevents) +/-1 if creation/deletion # grouptimeevents <- numeric() # groupnodeevents <- numeric() # groupreplaceevents <- numeric() - # opportunity sets: a list containing which groups are available at each decision time - # opportunities$time: same times as the joining events (the ones used in the choice model) + # opportunity sets: a list containing which groups are available + # at each decision time + # opportunities$time: same times as the joining events + # (the ones used in the choice model) # opportunities$groups: vector of available groups opportunities <- list() # depending events: joining and leaving events to be modeled # replace = +/-1 if joining/leaving - # deporder: vector indicating the order of this event in the whole scheme of events + # deporder: vector indicating the order of this event + # in the whole scheme of events # (to be put as an attribute of the events) deptimeevents <- numeric() depsenderevents <- numeric() @@ -236,7 +244,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # exogenous events: joining and leaving events that are "structural" # (when an isolate "leaves" its group, or when an actor "joins" an isolate) # replace = +/-1 if joining/leaving - # exoorder: vector indicating the order of this event in the whole scheme of events + # exoorder: vector indicating the order of this event + # in the whole scheme of events # (to be put as an attribute of the events) exotimeevents <- numeric() exosenderevents <- numeric() @@ -245,8 +254,10 @@ defineGroups_interaction <- function(records, actors, seed.randomization, exoorder <- numeric() # interaction updates events: updates of the past interaction network - # a weight 1 is added between 2 actors when one joins the other in an interaction - # pastorder: vector indicating the order of this event in the whole scheme of events + # a weight 1 is added between 2 actors when one joins + # the other in an interaction + # pastorder: vector indicating the order of this event + # in the whole scheme of events # (to be put as an attribute of the events) pastsenderevents <- numeric() pastreceiverevents <- numeric() @@ -286,7 +297,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, pastreplaceevents_temp <- numeric() pastorder_temp <- numeric() - # INTERACTING ACTORS: for each group, update group events (groups are taken at random) + # INTERACTING ACTORS: for each group, update group events + # (groups are taken at random) numgroups <- 0 groups <- numeric() singletons <- numeric() @@ -306,7 +318,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, } # in case of merge and splits, we randomly pick the group to keep - # so we need to keep track of kept groups, and the ones that will need to be removed + # so we need to keep track of kept groups, and the ones + # that will need to be removed takengroups <- numeric() toberemovedgroups <- unique(currentgroups[currentgroups > 0]) @@ -323,10 +336,13 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # if some of them were interacting before, in one or several groups if (numpreviousgroups >= 1) { - # we randomly choose the group to keep, potentially create one more in the split case + # we randomly choose the group to keep, potentially + # create one more in the split case newkeptg <- FALSE if (length(intersect(previousgroups, takengroups)) > 0) { - topickfrom <- previousgroups[!previousgroups %in% intersect(previousgroups, takengroups)] + topickfrom <- previousgroups[ + !previousgroups %in% intersect(previousgroups, takengroups) + ] } else { topickfrom <- previousgroups } @@ -360,33 +376,46 @@ defineGroups_interaction <- function(records, actors, seed.randomization, toberemovedgroups <- toberemovedgroups[toberemovedgroups != keptg] if (newkeptg) { - for (g2 in seq.int(numpreviousgroups)) { + for (g2 in seq_len(numpreviousgroups)) { - # we check whether there are some other actors in the previous group + # we check whether there are some other actors + # in the previous group previousgroup <- previousgroups[g2] - previousgroupactors <- groupactors[which(currentgroups[groupactors] == previousgroup)] + previousgroupactors <- groupactors[ + which(currentgroups[groupactors] == previousgroup) + ] if (length(previousgroupactors) > 0) { - for (a2 in seq.int(length(previousgroupactors))) { + for (a2 in seq_along(previousgroupactors)) { # dependent leaving events for active actors in other groups # + exogenous joining events to intermediary singletons if (!previousgroup %in% singletons) { deptimeevents_temp <- c(deptimeevents_temp, time) - depsenderevents_temp <- c(depsenderevents_temp, previousgroupactors[a2]) - depreceiverevents_temp <- c(depreceiverevents_temp, previousgroup) + depsenderevents_temp <- c( + depsenderevents_temp, + previousgroupactors[a2] + ) + depreceiverevents_temp <- c( + depreceiverevents_temp, + previousgroup + ) depreplaceevents_temp <- c(depreplaceevents_temp, -1) cptorder <- cptorder + 1 deporder_temp <- c(deporder_temp, cptorder) # debug - # cat(paste("leaving event: ", previousgroupactors[a2],"to", previousgroup, "\n")) + # cat(paste("leaving event: ", + # previousgroupactors[a2],"to", previousgroup, "\n")) # We create a fake intermediary singleton! newg <- min(allactors[!allactors %in% currentgroups]) exotimeevents_temp <- c(exotimeevents_temp, time) - exosenderevents_temp <- c(exosenderevents_temp, previousgroupactors[a2]) + exosenderevents_temp <- c( + exosenderevents_temp, + previousgroupactors[a2] + ) exoreceiverevents_temp <- c(exoreceiverevents_temp, newg) exoreplaceevents_temp <- c(exoreplaceevents_temp, 1) @@ -397,47 +426,73 @@ defineGroups_interaction <- function(records, actors, seed.randomization, currentgroups[previousgroupactors[a2]] <- newg # debug - # cat(paste("(exo) joining event: ", previousgroupactors[a2],"to", newg, "\n")) + # cat(paste("(exo) joining event: ", + # previousgroupactors[a2],"to", newg, "\n")) } # dependent joining events for everyone deptimeevents_temp <- c(deptimeevents_temp, time) - depsenderevents_temp <- c(depsenderevents_temp, previousgroupactors[a2]) + depsenderevents_temp <- c( + depsenderevents_temp, + previousgroupactors[a2] + ) depreceiverevents_temp <- c(depreceiverevents_temp, keptg) depreplaceevents_temp <- c(depreplaceevents_temp, 1) - # store the information on which groups were available at the time of the joining + # store the information on which groups were available + # at the time of the joining cptopp <- cptopp + 1 opportunities[[cptopp]] <- unique(currentgroups) # debug - # cat(paste("opportunities: ", t(unique(currentgroups)), "\n")) + # cat(paste("opportunities: ", + # t(unique(currentgroups)), "\n")) cptorder <- cptorder + 1 deporder_temp <- c(deporder_temp, cptorder) # debug - # cat(paste("joining event: ", previousgroupactors[a2]," to ", keptg, "\n")) + # cat(paste("joining event: ", + # previousgroupactors[a2]," to ", keptg, "\n")) # update past interaction network othersingroups <- which(currentgroups == keptg) nothers <- length(othersingroups) - pasttimeevents_temp <- c(pasttimeevents_temp, rep(time, nothers)) - pastsenderevents_temp <- c(pastsenderevents_temp, rep(previousgroupactors[a2], nothers)) - pastreceiverevents_temp <- c(pastreceiverevents_temp, othersingroups) - pastreplaceevents_temp <- c(pastreplaceevents_temp, rep(1, nothers)) + pasttimeevents_temp <- c( + pasttimeevents_temp, + rep(time, nothers) + ) + pastsenderevents_temp <- c( + pastsenderevents_temp, + rep(previousgroupactors[a2], nothers) + ) + pastreceiverevents_temp <- c( + pastreceiverevents_temp, + othersingroups + ) + pastreplaceevents_temp <- c( + pastreplaceevents_temp, + rep(1, nothers) + ) cptorder <- cptorder + 1 - pastorder_temp <- c(pastorder_temp, cptorder:(cptorder + nothers - 1)) + pastorder_temp <- c( + pastorder_temp, + cptorder:(cptorder + nothers - 1) + ) cptorder <- cptorder + nothers - 1 # update current groups currentgroups[previousgroupactors[a2]] <- keptg # exogenous leaving events for everyone - # if the actor was in a real gorup, it leaves the fake intermediary singleton + # if the actor was in a real gorup, + # it leaves the fake intermediary singleton if (!previousgroup %in% singletons) { exotimeevents_temp <- c(exotimeevents_temp, time) - exosenderevents_temp <- c(exosenderevents_temp, previousgroupactors[a2]) + exosenderevents_temp <- c( + exosenderevents_temp, + previousgroupactors[a2] + ) exoreceiverevents_temp <- c(exoreceiverevents_temp, newg) exoreplaceevents_temp <- c(exoreplaceevents_temp, -1) @@ -445,20 +500,28 @@ defineGroups_interaction <- function(records, actors, seed.randomization, exoorder_temp <- c(exoorder_temp, cptorder) # debug - # cat(paste("(exo) leaving event: ", previousgroupactors[a2],"to", newg, "\n")) + # cat(paste("(exo) leaving event: ", + # previousgroupactors[a2],"to", newg, "\n")) } else { # if it was a singleton, it just leaves the singleton exotimeevents_temp <- c(exotimeevents_temp, time) - exosenderevents_temp <- c(exosenderevents_temp, previousgroupactors[a2]) - exoreceiverevents_temp <- c(exoreceiverevents_temp, previousgroup) + exosenderevents_temp <- c( + exosenderevents_temp, + previousgroupactors[a2] + ) + exoreceiverevents_temp <- c( + exoreceiverevents_temp, + previousgroup + ) exoreplaceevents_temp <- c(exoreplaceevents_temp, -1) cptorder <- cptorder + 1 exoorder_temp <- c(exoorder_temp, cptorder) # debug - # cat(paste("(exo) leaving event: ", previousgroupactors[a2],"to", previousgroup, "\n")) + # cat(paste("(exo) leaving event: ", + # previousgroupactors[a2],"to", previousgroup, "\n")) } } } @@ -471,9 +534,12 @@ defineGroups_interaction <- function(records, actors, seed.randomization, for (g2 in seq.int(numpreviousgroups)) { - # we check whether there are some other actors in the previous group + # we check whether there are some other actors + # in the previous group previousgroup <- previousgroups[g2] - previousgroupactors <- groupactors[which(currentgroups[groupactors] == previousgroup)] + previousgroupactors <- groupactors[ + which(currentgroups[groupactors] == previousgroup) + ] if (length(previousgroupactors) > 0) { for (a2 in seq.int(length(previousgroupactors))) { @@ -482,8 +548,14 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # + exogenous joining events to intermediary singletons if (!previousgroup %in% singletons) { deptimeevents_temp <- c(deptimeevents_temp, time) - depsenderevents_temp <- c(depsenderevents_temp, previousgroupactors[a2]) - depreceiverevents_temp <- c(depreceiverevents_temp, previousgroup) + depsenderevents_temp <- c( + depsenderevents_temp, + previousgroupactors[a2] + ) + depreceiverevents_temp <- c( + depreceiverevents_temp, + previousgroup + ) depreplaceevents_temp <- c(depreplaceevents_temp, -1) cptorder <- cptorder + 1 diff --git a/R/functions_output.R b/R/functions_output.R index cdfb05a..23c966c 100644 --- a/R/functions_output.R +++ b/R/functions_output.R @@ -309,8 +309,12 @@ print.dependent.goldfish <- function(x, ..., full = FALSE, n = 6) { #' @export #' @rdname print-method # -# @examples print(structure(list(formula = dep ~ inertia, dependentStatistics = numeric(20)), -# class = "preprocessed.goldfish")) +# @examples print( +# structure( +# list(formula = dep ~ inertia, dependentStatistics = numeric(20)), +# class = "preprocessed.goldfish" +# ) +# ) print.preprocessed.goldfish <- function(x, ..., width = getOption("width")) { cat("**Preprocess object for the model:**\n") print(x$formula) @@ -318,26 +322,35 @@ print.preprocessed.goldfish <- function(x, ..., width = getOption("width")) { # cat(" Model type:", result$model.type, "\n") cat("*The results are available in the following objects:*\n\n") + textNodes <- "A character with the name of the object of class nodes.goldfish" + description <- data.frame( - name = c("initialStats", "dependentStatsChange", "rightCensoredStatsChange", - "intervals", "rightCensoredIntervals", "orderEvents", "eventTime", - "eventSender", "eventReceiver", "startTime", "endTime", "formula", - "nodes", "nodes2"), - description = - c("Initial statistical matrices for the effects given previous history.", - "List: For each dependent event, a list with the change statistics for the given\n state of the process.", - "List: dependent change statistics for a given right-censored event.", - "Elapsed time between events.", - "List: updates statistics during the elapsed time between events.", - "Order of events.", - "Time of the event.", - "Event sender.", - "Event receiver.", - "Numeric time value of the initial time considered during estimation.", - "Numeric time value of the final time considered during estimation.", - "Formula of the model to estimate.", - "A character with the name of the object of class nodes.goldfish (rows/first-mode)", - "A character with the name of the object of class nodes.goldfish (cols/second-mode)"), + name = c( + "initialStats", "dependentStatsChange", "rightCensoredStatsChange", + "intervals", "rightCensoredIntervals", "orderEvents", "eventTime", + "eventSender", "eventReceiver", "startTime", "endTime", "formula", + "nodes", "nodes2" + ), + description = c( + "Initial statistical matrices for the effects given previous history.", + paste( + "List: For each dependent event,", + "a list with the change statistics for the given", + "\n state of the process." + ), + "List: dependent change statistics for a given right-censored event.", + "Elapsed time between events.", + "List: updates statistics during the elapsed time between events.", + "Order of events.", + "Time of the event.", + "Event sender.", + "Event receiver.", + "Numeric time value of the initial time considered during estimation.", + "Numeric time value of the final time considered during estimation.", + "Formula of the model to estimate.", + paste(textNodes, "(rows/first-mode)"), + paste(textNodes, "(cols/second-mode)") + ), stringsAsFactors = FALSE ) @@ -361,7 +374,8 @@ print.preprocessed.goldfish <- function(x, ..., width = getOption("width")) { #' @importFrom generics tidy #' @export generics::tidy -# tidy <- function(x) UseMethod("tidy") # just for testing, don't use because overwrites use in other packages +# tidy <- function(x) UseMethod("tidy") +# # just for testing, don't use because overwrites use in other packages #' @method tidy result.goldfish #' @export @@ -383,8 +397,8 @@ tidy.result.goldfish <- function( terms <- paste( x$names[, 1], rownames(x$names), - if (ncol(x$names) > 2) apply(x$names[, -1], 1, paste, collapse = " ") else - x$names[, -1] + if (ncol(x$names) > 2) apply(x$names[, -1], 1, paste, collapse = " ") + else x$names[, -1] ) terms <- trimws(terms) terms <- gsub("\\$"," ", terms) @@ -426,7 +440,8 @@ tidy.result.goldfish <- function( #' @importFrom generics glance #' @export generics::glance -# glance <- function(x) UseMethod("glance") # just for testing, don't use because overwrites use in other packages +# glance <- function(x) UseMethod("glance") +# just for testing, don't use because overwrites use in other packages #' @method glance result.goldfish #' @export diff --git a/R/functions_postestimate.R b/R/functions_postestimate.R index d88b180..2446023 100644 --- a/R/functions_postestimate.R +++ b/R/functions_postestimate.R @@ -2,8 +2,8 @@ #' Extract model coefficients from estimate output #' #' Return a named vector with the estimated coefficients returned by `estimate`. -#' The names just correspond to the short effect name. For a comprehensive output use -#' `summary()`. +#' The names just correspond to the short effect name. +#' For a comprehensive output use `summary()`. #' Note that while the output to the console is rounded, the returned vector #' is not. #' @param object an object of class `result.goldfish` output from an diff --git a/R/functions_preprocessing_interaction.R b/R/functions_preprocessing_interaction.R index c842e71..12a6e4d 100644 --- a/R/functions_preprocessing_interaction.R +++ b/R/functions_preprocessing_interaction.R @@ -289,7 +289,7 @@ preprocessInteraction <- function( }, prioritypointers ) |> vapply(identity, numeric(1)) - + if (max(cpts) == 0) { nextEvent <- prioritypointers[1] } else { @@ -557,7 +557,7 @@ preprocessInteraction <- function( pointers[nextEvent] <- 1 + pointers[nextEvent] - validPointers <- pointers <= sapply(events, nrow) + validPointers <- pointers <= vapply(events, nrow, numeric(1)) } if (progress && utils::getTxtProgressBar(pb) < nDependentEvents) { diff --git a/R/goldfish-package.R b/R/goldfish-package.R index 316b4f8..14ece27 100644 --- a/R/goldfish-package.R +++ b/R/goldfish-package.R @@ -1,14 +1,19 @@ ## usethis namespace: start #' goldfish package #' -#' The goldfish Project is an R package that allows to fit statistical network models +#' The goldfish Project is an R package that allows +#' to fit statistical network models #' (such as DyNAM and REM) to dynamic network data. #' #' The \href{https://sn.ethz.ch/research/goldfish.html}{goldfish} -#' package in R allows the study of time-stamped network data using a variety of models. -#' In particular, it implements different types of Dynamic Network Actor Models (DyNAMs), -#' a class of models that is tailored to the study of actor-oriented network processess through time. -#' Goldfish also implements different versions of the tie-oriented Relational Event Model by Carter Butts. +#' package in R allows the study of time-stamped network data +#' using a variety of models. +#' In particular, it implements different types of +#' Dynamic Network Actor Models (DyNAMs), +#' a class of models that is tailored to the study of +#' actor-oriented network processess through time. +#' Goldfish also implements different versions of +#' the tie-oriented Relational Event Model by Carter Butts. #' #' @seealso [estimate()] #' @references @@ -25,8 +30,10 @@ #' \emph{Sociological Methodology 47 (1)}. \doi{10.1177/0081175017709295} #' #' Hollway, J. (2020). -#' Network embeddedness and the rate of international water cooperation and conflict. -#' In \emph{Networks in Water Governance}, edited by Manuel Fischer and Karin Ingold. +#' Network embeddedness and the rate +#' of international water cooperation and conflict. +#' In \emph{Networks in Water Governance}, +#' edited by Manuel Fischer and Karin Ingold. #' London: Palgrave, pp. 87-113. #' #' Hoffman, M., Block P., Elmer T., and Stadtfeld C. (2020). diff --git a/man/Fisheries_Treaties_6070.Rd b/man/Fisheries_Treaties_6070.Rd index 9599bc0..a8cf236 100644 --- a/man/Fisheries_Treaties_6070.Rd +++ b/man/Fisheries_Treaties_6070.Rd @@ -23,28 +23,28 @@ contigchanges (139 rows, 4 columns, dyadic). See below for variables and formats. \tabular{lll}{ -\strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -states$label \tab Node identifier labels \tab character \cr -states$present \tab Node present in dataset \tab boolean \cr -states$regime \tab Placeholder for regime variable \tab numeric (NA) \cr -states$gdp \tab Placeholder for GDP variable \tab numeric (NA) \cr -sovchanges$time \tab Date of state sovereignty update \tab POSIXct \cr -sovchanges$node \tab Node for state sovereignty update \tab integer \cr -sovchanges$replace \tab State sovereignty update \tab boolean \cr -regchanges$time \tab Date of regime update \tab POSIXct \cr -regchanges$node \tab Node for regime update \tab integer \cr -regchanges$replace \tab Regime update \tab integer (-10--10) \cr -gdpchanges$time \tab Date of GDP update \tab POSIXct \cr -gdpchanges$node \tab Node for GDP update \tab integer \cr -gdpchanges$replace \tab GDP update \tab numeric \cr -bilatchanges$time \tab Date of bilateral change \tab POSIXct \cr -bilatchanges$sender \tab First bilateral change node \tab integer \cr -bilatchanges$receiver \tab Second bilateral change node \tab integer \cr -bilatchanges$increment \tab Create or dissolve action \tab numeric (-1 or 1) \cr -contigchanges$time \tab Date of contiguity change \tab POSIXct \cr -contigchanges$sender \tab First contiguity change node \tab integer \cr -contigchanges$receiver \tab Second contiguity change node \tab integer \cr -contigchanges$replace \tab New contiguity value \tab numeric \cr +\strong{Object} \tab \strong{Description} \tab \strong{Format} \cr +states$label \tab Node identifier labels \tab character \cr +states$present \tab Node present in dataset \tab boolean \cr +states$regime \tab Placeholder for regime variable \tab numeric (NA) \cr +states$gdp \tab Placeholder for GDP variable \tab numeric (NA) \cr +sovchanges$time \tab Date of state sovereignty update \tab POSIXct \cr +sovchanges$node \tab Node for state sovereignty update \tab integer \cr +sovchanges$replace \tab State sovereignty update \tab boolean \cr +regchanges$time \tab Date of regime update \tab POSIXct \cr +regchanges$node \tab Node for regime update \tab integer \cr +regchanges$replace \tab Regime update \tab integer (-10--10) \cr +gdpchanges$time \tab Date of GDP update \tab POSIXct \cr +gdpchanges$node \tab Node for GDP update \tab integer \cr +gdpchanges$replace \tab GDP update \tab numeric \cr +bilatchanges$time \tab Date of bilateral change \tab POSIXct \cr +bilatchanges$sender \tab First bilateral change node \tab integer \cr +bilatchanges$receiver \tab Second bilateral change node \tab integer \cr +bilatchanges$increment\tab Create or dissolve tie\tab numeric (-1 or 1)\cr +contigchanges$time \tab Date of contiguity change \tab POSIXct \cr +contigchanges$sender \tab First contiguity change node \tab integer \cr +contigchanges$receiver \tab Second contiguity change node \tab integer \cr +contigchanges$replace \tab New contiguity value \tab numeric \cr } An object of class \code{data.frame} with 77 rows and 4 columns. @@ -87,21 +87,25 @@ An abbreviated version of the international fisheries agreements dataset, including only bilateral agreements, fewer variables, and ranging only between 1960 and 1970 inclusive. This data set is only meant for testing, and not for inference. -It provides an example of an undirected, weighted (by integer/increment) network, -with composition change and both monadic and dyadic covariates. +It provides an example of an undirected, weighted (by integer/increment) +network, with composition change and both monadic and dyadic covariates. Monadic variables include the dates states gain or lose sovereign status, their polity score, and their GDP. Dyadic variables include bilateral fisheries agreements between states, and states' contiguity with one another over time. } \references{ -Hollway, James, and Johan Koskinen. 2016. Multilevel Embeddedness: The Case of the Global Fisheries -Governance Complex. \emph{Social Networks}, 44: 281-94. doi:10.1016/j.socnet.2015.03.001. +Hollway, James, and Johan Koskinen. 2016. +Multilevel Embeddedness: The Case of the Global Fisheries Governance Complex. +\emph{Social Networks}, 44: 281-94. \doi{10.1016/j.socnet.2015.03.001}. -Hollway, James, and Johan H Koskinen. 2016. Multilevel Bilateralism and Multilateralism: States' Bilateral and +Hollway, James, and Johan H Koskinen. 2016. +Multilevel Bilateralism and Multilateralism: States' Bilateral and Multilateral Fisheries Treaties and Their Secretariats. -In \emph{Multilevel Network Analysis for the Social Sciences}, edited by Emmanuel Lazega and Tom A B Snijders, -315-32. Cham: Springer International Publishing. doi:10.1007/978-3-319-24520-1_13. +In \emph{Multilevel Network Analysis for the Social Sciences}, +edited by Emmanuel Lazega and Tom A B Snijders, +315-32. Cham: Springer International Publishing. +\doi{10.1007/978-3-319-24520-1_13}. } \keyword{datasets} \keyword{dynamic} diff --git a/man/RFID_Validity_Study.Rd b/man/RFID_Validity_Study.Rd index 3bf3f9f..97c91b9 100644 --- a/man/RFID_Validity_Study.Rd +++ b/man/RFID_Validity_Study.Rd @@ -11,9 +11,12 @@ \format{ 3 dataframes: \cr \itemize{ -\item participants (11 rows, 7 columns): attributes of the experiment's participants\cr -\item rfid (1011 rows, 4 columns): dyadic interactions detected by the RFID badges (after data processing)\cr -\item video (219 rows, 4 columns): dyadic interactions detected by the video rating\cr +\item participants (11 rows, 7 columns): +attributes of the experiment's participants\cr +\item rfid (1011 rows, 4 columns): dyadic interactions detected +by the RFID badges (after data processing)\cr +\item video (219 rows, 4 columns): dyadic interactions detected +by the video rating\cr and one network:\cr \item known.before (11 rows, 11 columns): network of previous acquaintances\cr See below for variables and formats.\cr @@ -21,22 +24,27 @@ See below for variables and formats.\cr \tabular{lll}{ \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -participants$actor \tab Identifier of the actor \tab integer \cr -participants$label \tab (Anonymized) name \tab Factor \cr -participants$present \tab Presence of the actor (all actors are present) \tab logical \cr -participants$age \tab Actor's age \tab integer \cr -participants$gender \tab Actor's gender (0: male, 1: female) \tab integer \cr -participants$group \tab Actor's group affiliation (groups have distinct ids) \tab integer \cr -participants$level \tab Actor's seniority (1: MSc student, 2: PhD student, 3: PostDoc, 4: Prof) -\tab integer \cr -rfid$NodeA \tab Identifier for the first actor \tab chr \cr -rfid$NodeB \tab Identifier for the second actor \tab chr \cr -rfid$Start \tab Time of the beginning of the dyadic interaction \tab integer \cr -rfid$End \tab Time of the end of the dyadic interaction \tab integer \cr -video$NodeA \tab Identifier for the first actor \tab chr \cr -video$NodeB \tab Identifier for the second actor \tab chr \cr -video$Start \tab Time of the beginning of the dyadic interaction \tab integer \cr -video$End \tab Time of the end of the dyadic interaction \tab integer \cr +participants$actor \tab Identifier of the actor \tab integer \cr +participants$label \tab (Anonymized) name \tab Factor \cr +participants$present \tab Presence of the actor (all actors are present) +\tab logical \cr +participants$age \tab Actor's age \tab integer \cr +participants$gender \tab Actor's gender (0: male, 1: female) +\tab integer \cr +participants$group +\tab Actor's group affiliation (groups have distinct ids) \tab integer \cr +participants$level \tab Actor's seniority +(1: MSc student, 2: PhD student, 3: PostDoc, 4: Prof) \tab integer \cr +rfid$NodeA \tab Identifier for the first actor \tab chr \cr +rfid$NodeB \tab Identifier for the second actor \tab chr \cr +rfid$Start \tab Time of the beginning of the dyadic interaction +\tab integer \cr +rfid$End \tab Time of the end of the dyadic interaction \tab integer \cr +video$NodeA \tab Identifier for the first actor \tab chr \cr +video$NodeB \tab Identifier for the second actor \tab chr \cr +video$Start \tab Time of the beginning of the dyadic interaction +\tab integer \cr +video$End \tab Time of the end of the dyadic interaction \tab integer \cr } An object of class \code{data.frame} with 1011 rows and 4 columns. diff --git a/man/Social_Evolution.Rd b/man/Social_Evolution.Rd index ecddf14..908554a 100644 --- a/man/Social_Evolution.Rd +++ b/man/Social_Evolution.Rd @@ -8,23 +8,28 @@ \alias{friendship} \title{Social evolution of a university dormitory cohort} \format{ -3 dataframes: actors (84 rows, 4 columns), calls (439 rows, 4 columns), friendship (766 rows, 4 columns). +3 dataframes: actors (84 rows, 4 columns), +calls (439 rows, 4 columns), friendship (766 rows, 4 columns). See below for variables and formats. \tabular{lll}{ -\strong{Object} \tab \strong{Description} \tab \strong{Format} \cr -actors$label \tab Actor identifier labels \tab character \cr -actors$present \tab Actor present in dataset \tab boolean \cr -actors$floor \tab Floor of residence actor lives on \tab numeric (1-9) \cr -actors$gradeType \tab Degree level \tab numeric (1-5) \cr -calls$time \tab Time and date of call \tab numeric from POSIXct \cr -calls$sender \tab Initiator of phone call \tab character \cr -calls$receiver \tab Recipient of phone call \tab character \cr -calls$increment \tab Indicates call number increment (all 1s) \tab numeric (1) \cr -friendship$time \tab Time and date of friend nomination \tab numeric from POSIXct \cr -friendship$sender \tab Nominator of friendship \tab character \cr -friendship$receiver \tab Nominee of friendship \tab character \cr -friendship$replace \tab Indicates friendship value at $time \tab numeric \cr +\strong{Object} \tab \strong{Description} \tab\strong{Format} \cr +actors$label \tab Actor identifier labels \tab character \cr +actors$present \tab Actor present in dataset \tab boolean \cr +actors$floor \tab Floor of residence actor lives on +\tab numeric (1-9) \cr +actors$gradeType \tab Degree level \tab numeric (1-5) \cr +calls$time \tab Time and date of call \tab numeric from POSIXct \cr +calls$sender \tab Initiator of phone call \tab character \cr +calls$receiver \tab Recipient of phone call \tab character \cr +calls$increment \tab Indicates call number increment (all 1s) +\tab numeric (1) \cr +friendship$time \tab Time and date of friend nomination +\tab numeric from POSIXct \cr +friendship$sender \tab Nominator of friendship \tab character \cr +friendship$receiver \tab Nominee of friendship \tab character \cr +friendship$replace \tab Indicates friendship value at $time +\tab numeric \cr } An object of class \code{data.frame} with 84 rows and 4 columns. @@ -54,8 +59,9 @@ which the student resides, and the grade type of each student including freshmen, sophomore, junior, senior, or graduate tutors. } \references{ -A. Madan, M. Cebrian, S. Moturu, K. Farrahi, A. Pentland (2012). Sensing the 'Health State' of a Community. -\emph{Pervasive Computing. 11}, 4, pp. 36-45. +A. Madan, M. Cebrian, S. Moturu, K. Farrahi, A. Pentland (2012). +Sensing the 'Health State' of a Community. +\emph{Pervasive Computing. 11}, 4, pp. 36-45. \doi{10.1109/MPRV.2011.79}. } \keyword{datasets} \keyword{evolution} diff --git a/man/estimate.Rd b/man/estimate.Rd index 1960696..99d114d 100644 --- a/man/estimate.Rd +++ b/man/estimate.Rd @@ -244,7 +244,7 @@ createBilat <- defineDependentEvents( events = bilatchanges[bilatchanges$increment == 1, ], nodes = states, defaultNetwork = bilatnet ) - + partnerModel <- estimate( createBilat ~ inertia(bilatnet) + diff --git a/man/goldfish-package.Rd b/man/goldfish-package.Rd index 455d7e9..5550c14 100644 --- a/man/goldfish-package.Rd +++ b/man/goldfish-package.Rd @@ -6,15 +6,20 @@ \alias{goldfish} \title{goldfish package} \description{ -The goldfish Project is an R package that allows to fit statistical network models +The goldfish Project is an R package that allows +to fit statistical network models (such as DyNAM and REM) to dynamic network data. } \details{ The \href{https://sn.ethz.ch/research/goldfish.html}{goldfish} -package in R allows the study of time-stamped network data using a variety of models. -In particular, it implements different types of Dynamic Network Actor Models (DyNAMs), -a class of models that is tailored to the study of actor-oriented network processess through time. -Goldfish also implements different versions of the tie-oriented Relational Event Model by Carter Butts. +package in R allows the study of time-stamped network data +using a variety of models. +In particular, it implements different types of +Dynamic Network Actor Models (DyNAMs), +a class of models that is tailored to the study of +actor-oriented network processess through time. +Goldfish also implements different versions of +the tie-oriented Relational Event Model by Carter Butts. } \references{ Stadtfeld, C. (2012). Events in Social Networks: A Stochastic @@ -30,8 +35,10 @@ Dynamic Network Actor Models: Investigating Coordination Ties Through Time. \emph{Sociological Methodology 47 (1)}. \doi{10.1177/0081175017709295} Hollway, J. (2020). -Network embeddedness and the rate of international water cooperation and conflict. -In \emph{Networks in Water Governance}, edited by Manuel Fischer and Karin Ingold. +Network embeddedness and the rate +of international water cooperation and conflict. +In \emph{Networks in Water Governance}, +edited by Manuel Fischer and Karin Ingold. London: Palgrave, pp. 87-113. Hoffman, M., Block P., Elmer T., and Stadtfeld C. (2020). diff --git a/src/DyNAM_rate_default.cpp b/src/DyNAM_rate_default.cpp index d5bdfd6..0b8d237 100644 --- a/src/DyNAM_rate_default.cpp +++ b/src/DyNAM_rate_default.cpp @@ -201,4 +201,3 @@ inline arma::mat reduce_mat_to_vector( } return reduced_data_mat; } - \ No newline at end of file diff --git a/src/gather_sender_model.cpp b/src/gather_sender_model.cpp index fa0fbbc..2542a23 100644 --- a/src/gather_sender_model.cpp +++ b/src/gather_sender_model.cpp @@ -203,4 +203,3 @@ inline arma::mat reduce_mat_to_vector( } return reduced_data_mat; } - \ No newline at end of file diff --git a/tests/testthat/test-effects_preprocessing_DyNAM_choice.R b/tests/testthat/test-effects_preprocessing_DyNAM_choice.R index a1d3344..f4e012b 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAM_choice.R +++ b/tests/testthat/test-effects_preprocessing_DyNAM_choice.R @@ -257,42 +257,46 @@ test_that( ) outDependentStatChange <- ReducePreprocess(preproData) eventsIncrementSubset <- subset(eventsIncrement, time >= 10 & time <= 30) - expect_equal(preproData$initialStats[, , 1], - matrix(c( - 0, 4, 0, 0, 0, - 1, 0, 2, 1, 0, - 0, 2, 0, 1, 0, - 0, 0, 1, 0, 0, - 0, 0, 0, 0, 0 - ), 5, 5, TRUE), - label = "initialization of the statistics matrix" - ) - expect_equal(preproData$initialStats[, , 2], - matrix(c( - 0, 0, 0, 1, 0, - 0, 0, 0, 0, 0, - 0, 2, 0, 0, 0, - 1, 1, 0, 0, 0, - 1, 2, 0, 0, 0 - ), 5, 5, TRUE), - label = "initialization of the statistics matrix" - ) - expect_equal(Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), - cbind( - node1 = c(2, 5, 1, 3, 3, 4), - node2 = c(3, 1, 5, 4, 4, 2), - replace = c(3, 1, 2, 2, 3, 1) - ), - label = "updating with increment works" + expect_equal( + preproData$initialStats[, , 1], + matrix(c( + 0, 4, 0, 0, 0, + 1, 0, 2, 1, 0, + 0, 2, 0, 1, 0, + 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0 + ), 5, 5, TRUE), + label = "initialization of the statistics matrix" + ) + expect_equal( + preproData$initialStats[, , 2], + matrix(c( + 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, + 0, 2, 0, 0, 0, + 1, 1, 0, 0, 0, + 1, 2, 0, 0, 0 + ), 5, 5, TRUE), + label = "initialization of the statistics matrix" + ) + expect_equal( + Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), + cbind( + node1 = c(2, 5, 1, 3, 3, 4), + node2 = c(3, 1, 5, 4, 4, 2), + replace = c(3, 1, 2, 2, 3, 1) + ), + label = "updating with increment works" ) # n-1 updates - expect_equal(outDependentStatChange[[2]], - cbind( - time = c(15, 16, 19, 19, 28, 28), - node1 = c(2, 5, 4, 4, 1, 3), - node2 = c(3, 1, 2, 5, 3, 5), - replace = c(1, 4, 0, 1, 2, 3) - ), - label = "updating with increment works" + expect_equal( + outDependentStatChange[[2]], + cbind( + time = c(15, 16, 19, 19, 28, 28), + node1 = c(2, 5, 4, 4, 1, 3), + node2 = c(3, 1, 2, 5, 3, 5), + replace = c(1, 4, 0, 1, 2, 3) + ), + label = "updating with increment works" ) expect_equal( preproData$rightCensoredStatsChange, diff --git a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R index bf3d462..bbbc8ec 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R @@ -3,7 +3,7 @@ # test inertia and tie with different subtypes ---- test_that( - "inertia/tie compute correct preprocessing objects weighted with all possible options", + "inertia/tie with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -24,7 +24,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -126,7 +127,8 @@ test_that( ) - # Final stats for other inertia effects: proportion, presence, min, mean, mean + # Final stats for other inertia effects: + # proportion, presence, min, mean, mean stat <- preproData$initialStats[, , 3] for (t in 1:4) { change <- preproData$dependentStatsChange[[t]][[3]] @@ -279,7 +281,8 @@ test_that( "inertia computes correct preprocessing objects with window", { preproData <- estimate( - dependent.depevents_DyNAMi ~ inertia(past_network_DyNAMi, weighted = TRUE) + + dependent.depevents_DyNAMi ~ + inertia(past_network_DyNAMi, weighted = TRUE) + inertia(past_network_DyNAMi, window = 2, weighted = TRUE) + inertia(past_network_DyNAMi, window = 7, weighted = TRUE), model = "DyNAMi", subModel = "choice", @@ -287,7 +290,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -382,26 +386,31 @@ test_that( # test alterpop and alterdeg ---- test_that( - "alterpop/alterdeg compute correct preprocessing objects weighted with all possible options", + "alterpop/alterdeg with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean_normalized") + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean_normalized") + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean_normalized") + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean_normalized") + alterpop(past_network_DyNAMi, weighted = TRUE, subType = "min") + alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "min") + alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean") + alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean") + alterpop(past_network_DyNAMi, weighted = TRUE, subType = "max") + alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "max") + - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean_centered") + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean_centered"), + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean_centered") + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean_centered"), model = "DyNAMi", subModel = "choice", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -515,7 +524,8 @@ test_that( - # Final stats for other inertia effects: mean_normalized, min, max, mean_centered + # Final stats for other inertia effects: + # mean_normalized, min, max, mean_centered stat <- preproData$initialStats[, , 1] for (t in 1:4) { change <- preproData$dependentStatsChange[[t]][[1]] @@ -634,7 +644,7 @@ test_that( # test size ---- test_that( - "size computes correct preprocessing objects weighted with all possible options", + "size with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -645,7 +655,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -745,7 +756,7 @@ test_that( # test alter ---- test_that( - "alter computes correct preprocessing objects weighted with all possible options", + "alter with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ alter(actors_DyNAMi$attr1, subType = "mean") @@ -760,7 +771,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -869,7 +881,8 @@ test_that( ) - # Final stats for other alter effects: mean_normalized, mean_squared, min, max, range, mean_centered + # Final stats for other alter effects: + # mean_normalized, mean_squared, min, max, range, mean_centered stat <- preproData$initialStats[, , 2] for (t in 1:4) { change <- preproData$dependentStatsChange[[t]][[2]] @@ -962,26 +975,28 @@ test_that( # test same/diff/sim ---- test_that( - "same/diff/sim compute correct preprocessing objects weighted with all possible options", + "same/diff/sim with objects weighted with all possible options", { preproData <- estimate( - dependent.depevents_DyNAMi ~ same(actors_DyNAMi$attr2, subType = "proportion") + dependent.depevents_DyNAMi ~ + same(actors_DyNAMi$attr2, subType = "proportion") + same(actors_DyNAMi$attr2, subType = "count") - + same(actors_DyNAMi$attr2, subType = "presence") - + diff(actors_DyNAMi$attr1, subType = "averaged_sum") - + diff(actors_DyNAMi$attr1, subType = "mean") - + diff(actors_DyNAMi$attr1, subType = "min") - + diff(actors_DyNAMi$attr1, subType = "max") - + sim(actors_DyNAMi$attr1, subType = "averaged_sum") - + sim(actors_DyNAMi$attr1, subType = "mean") - + sim(actors_DyNAMi$attr1, subType = "min") - + sim(actors_DyNAMi$attr1, subType = "max"), + + same(actors_DyNAMi$attr2, subType = "presence") + + diff(actors_DyNAMi$attr1, subType = "averaged_sum") + + diff(actors_DyNAMi$attr1, subType = "mean") + + diff(actors_DyNAMi$attr1, subType = "min") + + diff(actors_DyNAMi$attr1, subType = "max") + + sim(actors_DyNAMi$attr1, subType = "averaged_sum") + + sim(actors_DyNAMi$attr1, subType = "mean") + + sim(actors_DyNAMi$attr1, subType = "min") + + sim(actors_DyNAMi$attr1, subType = "max"), model = "DyNAMi", subModel = "choice", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } diff --git a/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R index 067ff7b..f080f8f 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R @@ -3,16 +3,18 @@ # test interecept leaving ---- test_that( - "intercept computes correct preprocessing objects weighted with all possible options", + "intercept with objects weighted with all possible options", { preproData <- estimate( - dependent.depevents_DyNAMi ~ 1 + intercept(interaction_network_DyNAMi, joining = -1), + dependent.depevents_DyNAMi ~ 1 + + intercept(interaction_network_DyNAMi, joining = -1), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -112,28 +114,41 @@ test_that( # test inertia with different subtypes ---- test_that( - "inertia/tie compute correct preprocessing objects weighted with all possible options", + "inertia/tie with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ - inertia(past_network_DyNAMi, weighted = TRUE, subType = "count", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "count", joining = -1) + - inertia(past_network_DyNAMi, weighted = TRUE, subType = "proportion", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "proportion", joining = -1) + - inertia(past_network_DyNAMi, weighted = TRUE, subType = "presence", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "presence", joining = -1) + - inertia(past_network_DyNAMi, weighted = TRUE, subType = "min", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "min", joining = -1) + - inertia(past_network_DyNAMi, weighted = TRUE, subType = "mean", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "mean", joining = -1) + - inertia(past_network_DyNAMi, weighted = TRUE, subType = "max", joining = -1) + - tie(covnetwork_DyNAMi, weighted = TRUE, subType = "max", joining = -1), + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "count", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "proportion", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "proportion", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "presence", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "presence", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "min", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "min", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "mean", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "max", joining = -1) + + tie(covnetwork_DyNAMi, + weighted = TRUE, subType = "max", joining = -1), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -323,7 +338,8 @@ test_that( - # Final stats for other inertia effects: proportion, presence, min, mean, max + # Final stats for other inertia effects: + # proportion, presence, min, mean, max for (i in c(3, 5, 7, 9, 11)) { stat <- preproData$initialStats[, , i] for (t in 1:8) { @@ -341,7 +357,8 @@ test_that( ) } - # Final stats for other tie effects: proportion, presence, min, mean, mean + # Final stats for other tie effects: + # proportion, presence, min, mean, mean for (i in c(4, 6, 8, 10, 12)) { stat <- preproData$initialStats[, , i] for (t in 1:8) { @@ -368,15 +385,19 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - inertia(past_network_DyNAMi, weighted = TRUE, subType = "count", joining = -1) - + inertia(past_network_DyNAMi, weighted = TRUE, subType = "count", joining = -1, window = 2) - + inertia(past_network_DyNAMi, weighted = TRUE, subType = "count", joining = -1, window = 7), + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1, window = 2) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1, window = 7), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -638,28 +659,41 @@ test_that( # test egopop with different subtypes ---- test_that( - "egopop/egodeg for joining and leaving compute correct preprocessing objects weighted with all possible options", + "egopop/egodeg for joining and leaving", { preproData <- estimate( dependent.depevents_DyNAMi ~ - egopop(past_network_DyNAMi, weighted = TRUE, subType = "identity", joining = 1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "identity", joining = 1) + - egopop(past_network_DyNAMi, weighted = TRUE, subType = "normalized", joining = 1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "normalized", joining = 1) + - egopop(past_network_DyNAMi, weighted = TRUE, subType = "identity", joining = -1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "identity", joining = -1) + - egopop(past_network_DyNAMi, weighted = TRUE, subType = "normalized", joining = -1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "normalized", joining = -1) + - egopop(past_network_DyNAMi, weighted = TRUE, subType = "centered", joining = 1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "centered", joining = 1) + - egopop(past_network_DyNAMi, weighted = TRUE, subType = "centered", joining = -1) + - egodeg(covnetwork_DyNAMi, weighted = TRUE, subType = "centered", joining = -1), + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "identity", joining = 1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "identity", joining = 1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "normalized", joining = 1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "normalized", joining = 1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "identity", joining = -1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "identity", joining = -1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "normalized", joining = -1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "normalized", joining = -1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "centered", joining = 1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "centered", joining = 1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "centered", joining = -1) + + egodeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "centered", joining = -1), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -1081,26 +1115,37 @@ test_that( # test alterpop with different subtypes ---- test_that( - "alterpop/alterdeg for leaving compute correct preprocessing objects weighted with all possible options", + "alterpop/alterdeg for leaving objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean", joining = -1) + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean", joining = -1) + - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean_normalized", joining = -1) + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean_normalized", joining = -1) + - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "min", joining = -1) + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "min", joining = -1) + - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "max", joining = -1) + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "max", joining = -1) + - alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean_centered", joining = -1) + - alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "mean_centered", joining = -1), + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean", joining = -1) + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean", joining = -1) + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean_normalized", joining = -1) + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean_normalized", joining = -1) + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "min", joining = -1) + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "min", joining = -1) + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "max", joining = -1) + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "max", joining = -1) + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean_centered", joining = -1) + + alterdeg(covnetwork_DyNAMi, + weighted = TRUE, subType = "mean_centered", joining = -1), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -1418,7 +1463,7 @@ test_that( # test ego with different subtypes ---- test_that( - "ego for joining and leaving compute correct preprocessing objects weighted with all possible options", + "ego for joining and leaving objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -1435,7 +1480,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -1757,7 +1803,7 @@ test_that( # test alter with different subtypes ---- test_that( - "alter for leaving compute correct preprocessing objects weighted with all possible options", + "alter for leaving with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -1772,7 +1818,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -1969,7 +2016,7 @@ test_that( # test same with different subtypes ---- test_that( - "same for leaving compute correct preprocessing objects weighted with all possible options", + "same for leaving with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -1981,7 +2028,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } @@ -2114,7 +2162,7 @@ test_that( # test diff with different subtypes ---- test_that( - "diff for leaving compute correct preprocessing objects weighted with all possible options", + "diff for leaving with objects weighted with all possible options", { preproData <- estimate( dependent.depevents_DyNAMi ~ @@ -2127,7 +2175,8 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] return(stat) } diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R b/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R index 0ec1989..209cde7 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R @@ -1,26 +1,40 @@ test_that("DyNAM default and tie init return the same result", { expect_equal( init_DyNAM_choice.tie(effectFUN_tie, m1, NULL, 5, 5), - init_DyNAM_choice.default(effectFUN_tie, network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5) + init_DyNAM_choice.default( + effectFUN_tie, network = m1, attribute = NULL, window = NULL, + n1 = 5, n2 = 5 + ) ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie, m1, 1, 5, 5), - init_DyNAM_choice.default(effectFUN_tie, network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5), + init_DyNAM_choice.default( + effectFUN_tie, network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5 + ), label = "when window is not NULL" ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m1, NULL, 5, 5), - init_DyNAM_choice.default(effectFUN_tie_weighted, network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5), + init_DyNAM_choice.default( + effectFUN_tie_weighted, network = m1, attribute = NULL, window = NULL, + n1 = 5, n2 = 5 + ), label = "when weighted is TRUE" ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m1, 1, 5, 5), - init_DyNAM_choice.default(effectFUN_tie_weighted, network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5), + init_DyNAM_choice.default( + effectFUN_tie_weighted, network = m1, attribute = NULL, window = 1, + n1 = 5, n2 = 5 + ), label = "when weighted is TRUE and window is not NULL" ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m0, NULL, 5, 5), - init_DyNAM_choice.default(effectFUN_tie_weighted, network = m0, attribute = NULL, window = NULL, n1 = 5, n2 = 5), + init_DyNAM_choice.default( + effectFUN_tie_weighted, network = m0, attribute = NULL, window = NULL, + n1 = 5, n2 = 5 + ), label = "when weighted is TRUE and there are no ties in the network" ) }) @@ -47,7 +61,10 @@ test_that("DyNAM default and indeg init return the same result", { test_that("DyNAM default and trans init return the same result", { expect_equal( init_DyNAM_choice.trans(effectFUN_trans, m1, NULL, 5, 5), - init_DyNAM_choice.default(effectFUN_trans, network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5) + init_DyNAM_choice.default( + effectFUN_trans, network = m1, attribute = NULL, window = NULL, + n1 = 5, n2 = 5 + ) ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R index 3bb1347..bc4341e 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R @@ -1,11 +1,15 @@ test_that("alter returns a valid object on update", { expect_type( - update_DyNAM_choice_alter(attribute = testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0), + update_DyNAM_choice_alter( + attribute = testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0 + ), "list" ) expect_true( inherits( - update_DyNAM_choice_alter(attribute = testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0)$changes, + update_DyNAM_choice_alter( + attribute = testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0 + )$changes, "matrix" ), label = "it doesn't return a matrix" @@ -14,26 +18,36 @@ test_that("alter returns a valid object on update", { test_that("alter returns NULL if there is no change", { expect_null( - update_DyNAM_choice_alter(testAttr$fishingSkill, node = 1, replace = 10, n1 = 8, n2 = 0)$changes + update_DyNAM_choice_alter( + testAttr$fishingSkill, node = 1, replace = 10, n1 = 8, n2 = 0 + )$changes ) expect_null( - update_DyNAM_choice_alter(testAttr$fishingSkill, node = 2, replace = NA, n1 = 8, n2 = 0)$changes, + update_DyNAM_choice_alter( + testAttr$fishingSkill, node = 2, replace = NA, n1 = 8, n2 = 0 + )$changes, label = "when previous value and replace are NA" ) }) test_that("alter returns correct attributes on update", { expect_equal( - update_DyNAM_choice_alter(testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0)$changes, + update_DyNAM_choice_alter( + testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0 + )$changes, cbind(node1 = 2:8, node2 = rep(1, 7), replace = rep(1, 7)) ) expect_equal( - update_DyNAM_choice_alter(testAttr$fishingSkill, node = 1, replace = 0, n1 = 8, n2 = 0)$changes, + update_DyNAM_choice_alter( + testAttr$fishingSkill, node = 1, replace = 0, n1 = 8, n2 = 0 + )$changes, cbind(node1 = 2:8, node2 = rep(1, 7), replace = rep(0, 7)), label = "when replace is 0" ) expect_equal( - update_DyNAM_choice_alter(testAttr$fishingSkill, node = 8, replace = 1, n1 = 8, n2 = 0)$changes, + update_DyNAM_choice_alter( + testAttr$fishingSkill, node = 8, replace = 1, n1 = 8, n2 = 0 + )$changes, cbind(node1 = 1:7, node2 = rep(8, 7), replace = rep(1, 7)), label = "when previous value was NA" ) diff --git a/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R b/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R index 44c7521..42bf027 100644 --- a/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R +++ b/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R @@ -42,7 +42,8 @@ test_that("ego returns correct attributes on update", { node = 1, replace = NA, n1 = 8, n2 = 8, isTwoMode = FALSE )$changes, - cbind(node1 = rep(1, 7), node2 = 2:8, replace = rep(6.8, 7)), # replace by average + # replace by average + cbind(node1 = rep(1, 7), node2 = 2:8, replace = rep(6.8, 7)), label = "when replace is NA" ) expect_equal( From 62fa143ecb0f085c0d2d72828226bb6a4470c6e5 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 21 Jun 2023 15:33:37 +0200 Subject: [PATCH 11/36] Run styler to the code --- R/data_RFID_Validity_Study.R | 2 +- R/functions_checks.R | 405 ++++++----- R/functions_data.R | 283 +++++--- R/functions_diagnostics.R | 55 +- R/functions_effects_DyNAM_choice.R | 641 +++++++++++------- ...ctions_effects_DyNAM_choice_coordination.R | 162 ++--- R/functions_effects_DyNAM_rate.R | 63 +- R/functions_effects_DyNAMi_choice.R | 96 ++- R/functions_effects_DyNAMi_rate.R | 208 +++--- R/functions_effects_REM.R | 316 +++++---- R/functions_estimation.R | 217 +++--- R/functions_estimation_engine.R | 238 ++++--- R/functions_estimation_engine_c.r | 147 ++-- R/functions_gather.R | 89 ++- R/functions_group_interaction_utility.R | 31 +- R/functions_output.R | 94 ++- R/functions_parsing.R | 132 ++-- R/functions_postestimate.R | 16 +- R/functions_preprocessing.R | 381 ++++++----- R/functions_preprocessing_interaction.R | 125 ++-- R/functions_utility.R | 52 +- R/testthat-helpers.R | 187 ++--- R/zzz.R | 10 +- tests/testthat/test-effects_preprocessing.R | 9 +- .../test-effects_preprocessing_DyNAM_rate.R | 96 +-- ...test-effects_preprocessing_DyNAMi_choice.R | 56 +- .../test-effects_preprocessing_DyNAMi_rate.R | 156 +++-- ...ctions_effects_DyNAM_choice-init_default.R | 18 +- ...ctions_effects_DyNAM_choice-update_alter.R | 15 +- ...nctions_effects_DyNAM_choice-update_diff.R | 97 +-- ...nctions_effects_DyNAM_choice-update_four.R | 85 +-- ...ctions_effects_DyNAM_choice-update_indeg.R | 198 +++--- ...ions_effects_DyNAM_choice-update_inertia.R | 92 ++- ...ctions_effects_DyNAM_choice-update_recip.R | 111 +-- ...nctions_effects_DyNAM_choice-update_same.R | 39 +- ...unctions_effects_DyNAM_choice-update_sim.R | 115 ++-- ...ctions_effects_DyNAM_choice-update_trans.R | 65 +- ...-functions_effects_DyNAM_rate-update_ego.R | 1 - .../test-functions_estimation_engine_c.R | 6 +- tests/testthat/test-functions_postestimate.R | 18 +- vignettes/goldfishEffects.Rmd | 82 ++- 41 files changed, 3037 insertions(+), 2172 deletions(-) diff --git a/R/data_RFID_Validity_Study.R b/R/data_RFID_Validity_Study.R index 5036af6..40680bd 100644 --- a/R/data_RFID_Validity_Study.R +++ b/R/data_RFID_Validity_Study.R @@ -24,7 +24,7 @@ #' - known.before (11 rows, 11 columns): network of previous acquaintances\cr #' See below for variables and formats.\cr #' -#'\tabular{lll}{ +#' \tabular{lll}{ #' \strong{Object} \tab \strong{Description} \tab \strong{Format} \cr #' participants$actor \tab Identifier of the actor \tab integer \cr #' participants$label \tab (Anonymized) name \tab Factor \cr diff --git a/R/functions_checks.R b/R/functions_checks.R index 1cdaae4..ff64a82 100644 --- a/R/functions_checks.R +++ b/R/functions_checks.R @@ -15,7 +15,7 @@ ## Find composition changes events for one nodeset findPresence <- function(nodes) { if (!is.null(attr(nodes, "dynamicAttributes")) && - "present" %in% attr(nodes, "dynamicAttributes")) { + "present" %in% attr(nodes, "dynamicAttributes")) { compositionChanges <- attr(nodes, "events")[ which(attr(nodes, "dynamicAttributes") == "present") ] @@ -157,12 +157,14 @@ checkClasses <- function(object, classes) { #' #' @examples #' assignCatToObject( -#' list(logical(2), numeric(4), integer(3), -#' matrix(FALSE, 2, 2), matrix(0L, 1, 1), matrix(0, 2, 2)) +#' list( +#' logical(2), numeric(4), integer(3), +#' matrix(FALSE, 2, 2), matrix(0L, 1, 1), matrix(0, 2, 2) +#' ) #' ) assignCatToObject <- function( object, - classes = c("matrix", "Matrix", "numeric", "character", "logical"), + classes = c("matrix", "Matrix", "numeric", "character", "logical"), category = c("network", "network", "attribute", "attribute", "attribute")) { stopifnot(length(classes) == length(category)) objectClasses <- vapply( @@ -205,58 +207,64 @@ assignCatToObject <- function( #' receiver = c("character", "numeric"), #' time = c("POSIXct", "numeric"), #' .allow = c("character", "numeric", "logical") -#' )) +#' ) +#' ) checkColumns <- function( - inDataFrame, - mandatoryNames = NULL, - incompatibleNames = NULL, - optionalNames = NULL, - classes = NULL -) { + inDataFrame, + mandatoryNames = NULL, + incompatibleNames = NULL, + optionalNames = NULL, + classes = NULL) { columnNames <- colnames(inDataFrame) if (!is.null(mandatoryNames) && !all(mandatoryNames %in% columnNames)) { stop("Missing columns ", - paste( - mandatoryNames[which(!(mandatoryNames %in% columnNames))], - collapse = ", " - ), - call. = FALSE) + paste( + mandatoryNames[which(!(mandatoryNames %in% columnNames))], + collapse = ", " + ), + call. = FALSE + ) } if (!is.null(incompatibleNames) && !any(columnNames %in% incompatibleNames)) { stop("Missing column that should be either ", - paste(incompatibleNames, collapse = " or "), - call. = FALSE) + paste(incompatibleNames, collapse = " or "), + call. = FALSE + ) } if (!is.null(incompatibleNames) && - sum(colnames(inDataFrame) %in% incompatibleNames) > 1) { + sum(colnames(inDataFrame) %in% incompatibleNames) > 1) { stop("Incompatible columns", - paste( - incompatibleNames[ - which((incompatibleNames %in% colnames(inDataFrame))) - ], - collapse = ", " - ), - call. = FALSE) + paste( + incompatibleNames[ + which((incompatibleNames %in% colnames(inDataFrame))) + ], + collapse = ", " + ), + call. = FALSE + ) } # # vector helper to define types colType <- columnNames colType[ - !columnNames %in% c(mandatoryNames, incompatibleNames, optionalNames)] <- + !columnNames %in% c(mandatoryNames, incompatibleNames, optionalNames) + ] <- ".allow" checked <- Map( function(column, ct, name) { - if (!any(checkClasses(column, classes[[ct]]))) + if (!any(checkClasses(column, classes[[ct]]))) { stop("The column ", dQuote(name), " expects values of type ", - paste(classes[[ct]], collapse = ", "), ".", - call. = FALSE + paste(classes[[ct]], collapse = ", "), ".", + call. = FALSE ) - else TRUE + } else { + TRUE + } }, inDataFrame, colType, columnNames ) |> - vapply(identity, logical(1)) + vapply(identity, logical(1)) return(all(checked)) } @@ -293,7 +301,7 @@ checkNodes <- function(nodes) { # columns names and types tryCatch( checkColumns( - inDataFrame = nodes, + inDataFrame = nodes, mandatoryNames = "label", optionalNames = "present", classes = list( @@ -303,17 +311,20 @@ checkNodes <- function(nodes) { ) ) # special case of labels - if (anyNA(as.vector(nodes$label))) + if (anyNA(as.vector(nodes$label))) { stop("Labels column cannot have missing values.", call. = FALSE) - if (anyDuplicated(as.vector(nodes$label))) + } + if (anyDuplicated(as.vector(nodes$label))) { stop("Labels should not be redundant (duplicate values).", .call = FALSE) + } # events attribute - if (!is.null(attr(nodes, "events")) && !is.character(attr(nodes, "events"))) + if (!is.null(attr(nodes, "events")) && !is.character(attr(nodes, "events"))) { stop( "The nodeset attribute ", dQuote("events"), " should be a character vector.", call. = FALSE ) + } return(TRUE) } @@ -360,68 +371,90 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { # stop("A network should be a matrix.", call. = FALSE) # network class (here this class is mandatory) if (!inherits(matrix, "network.goldfish")) { - stop("A network should be of the class network.goldfish.", - " Please use the function \"defineNetwork\".") + stop( + "A network should be of the class network.goldfish.", + " Please use the function \"defineNetwork\"." + ) } # events, nodes, directed attributes - if (!is.null(attr(matrix, "events")) && !is.character(attr(matrix, "events"))) + if (!is.null(attr(matrix, "events")) && + !is.character(attr(matrix, "events"))) { # styler: off stop("The network attribute \"events\" should be a character vector.") - if (is.null(attr(matrix, "nodes"))) - stop("The network attribute \"nodes\" should contain", - " the name of one or two nodesets.") + } + if (is.null(attr(matrix, "nodes"))) { + stop( + "The network attribute \"nodes\" should contain", + " the name of one or two nodesets." + ) + } if (!is.character(attr(matrix, "nodes")) && - !length(attr(matrix, "nodes")) %in% c(1, 2)) - stop("The network attribute \"nodes\" should contain", - "the name of one or two nodesets.") - if (!is.logical(attr(matrix, "directed"))) + !length(attr(matrix, "nodes")) %in% c(1, 2)) { # styler: off + stop( + "The network attribute \"nodes\" should contain", + "the name of one or two nodesets." + ) + } + if (!is.logical(attr(matrix, "directed"))) { stop("The network attribute \"directed\" should be a boolean.") - if (any(attr(matrix, "nodes") != nodesName)) + } + if (any(attr(matrix, "nodes") != nodesName)) { stop("The nodesets associated to this network were mispecified.") + } # validity of nodes isTwoMode <- !is.null(nodes2) if (!(inherits(nodes, "nodes.goldfish") && - isTwoMode && !inherits(nodes2, "nodes.goldfish"))) - tryCatch({ - checkNodes(nodes) - if (isTwoMode) checkNodes(nodes2) - }, error = function(e) { - e$message <- paste("Invalid nodeset(s): ", e$message) - stop(e) - }) + isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { + tryCatch( + { + checkNodes(nodes) + if (isTwoMode) checkNodes(nodes2) + }, + error = function(e) { + e$message <- paste("Invalid nodeset(s): ", e$message) + stop(e) + } + ) + } # compatibility between nodes and matrix - if (!isTwoMode && !all(dim(matrix) == nrow(nodes))) + if (!isTwoMode && !all(dim(matrix) == nrow(nodes))) { stop("The matrix dimensions are not coherent with the nodeset size.") + } if (isTwoMode && any(dim(matrix)[1] != nrow(nodes) && - dim(matrix)[2] != nrow(nodes2))) + dim(matrix)[2] != nrow(nodes2))) { stop("The matrix dimensions are not coherent with the nodesets sizes.") + } # labels when present agree if (!is.null(dimnames(matrix))) { dimNames <- dimnames(matrix) rowIn <- dimNames[[1]] %in% nodes$label - if (!all(rowIn)) - stop("Some row node labels are not in nodes data frame: ", - paste(dimNames[[1]][!rowIn], collapse = ", ")) + if (!all(rowIn)) { + stop( + "Some row node labels are not in nodes data frame: ", + paste(dimNames[[1]][!rowIn], collapse = ", ") + ) + } colIn <- dimNames[[2]] %in% if (!isTwoMode) nodes$label else nodes2$label - if (!all(colIn)) + if (!all(colIn)) { stop( "Some column node labels are not in nodes", ifelse(isTwoMode, "2", ""), " data frame: ", paste(dimNames[[2]][!colIn], collapse = ", ") ) + } if (!all(dimNames[[1]] == nodes$label) || - !all(dimNames[[2]] == if (!isTwoMode) nodes$label else nodes2$label)) + !all(dimNames[[2]] == if (!isTwoMode) nodes$label else nodes2$label)) { stop( "The order of nodes in either row or columns is", "not the same as in \"nodes\"", - ifelse(isTwoMode, "and \"nodes2\"", ""), " data frame", + ifelse(isTwoMode, "and \"nodes2\"", ""), " data frame", ifelse(isTwoMode, "s", "") ) - + } } else { warning( dQuote("matrix"), " object doesn't have a \"dimnames\" attribute. ", @@ -445,31 +478,39 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { checkDependentEvents <- function(events, eventsName, nodes, nodes2, defaultNetwork, environment) { - # check whether there's a column increment/replace or not (optional) updateColumn <- any(c("increment", "replace") %in% names(events)) # check content if ("node" %in% names(events)) { - tryCatch({ - checkEvents( - nodes, events, eventsName, - updateColumn = updateColumn, - environment = environment - ) - }, error = function(e) { - stop("These events were assumed to be monadic events.", e$message) - }) + tryCatch( + { + checkEvents( + nodes, events, eventsName, + updateColumn = updateColumn, + environment = environment + ) + }, + error = function(e) { + stop("These events were assumed to be monadic events.", e$message) + } + ) } else if (all(c("sender", "receiver") %in% names(events))) { - tryCatch({ - checkEvents(defaultNetwork, events, eventsName, nodes, nodes2, - updateColumn = updateColumn, environment = environment) - }, error = function(e) { - stop("These events were assumed to be dyadic events.", e$message) - }) + tryCatch( + { + checkEvents(defaultNetwork, events, eventsName, nodes, nodes2, + updateColumn = updateColumn, environment = environment + ) + }, + error = function(e) { + stop("These events were assumed to be dyadic events.", e$message) + } + ) } else { - stop("Invalid event list: missing one column node or two columns", - "sender and receiver.") + stop( + "Invalid event list: missing one column node or two columns", + "sender and receiver." + ) } return(TRUE) @@ -525,37 +566,41 @@ checkEvents <- function(object, ...) { # that these events are not related to attributes. checkEvents.nodes.goldfish <- function( - object, events, eventsName, - attribute = NULL, updateColumn = TRUE, environment = environment()) { + object, events, eventsName, + attribute = NULL, updateColumn = TRUE, environment = environment()) { # check attributes if (!is.data.frame(events)) stop("An event list should be a data frame.") if (!is.null(attribute)) { - if (!(is.character(attribute) && length(attribute) == 1)) + if (!(is.character(attribute) && length(attribute) == 1)) { stop("An attribute should be a character object.") + } if (is.null(attr(object, "dynamicAttributes")) || - !(attribute %in% attr(object, "dynamicAttributes"))) + !(attribute %in% attr(object, "dynamicAttributes"))) { stop("The dynamic attributes for this nodeset were mispecified.") + } if (!eventsName %in% - attr(object, "events")[ - which(attr(object, "dynamicAttributes") == attribute) - ]) + attr(object, "events")[ + which(attr(object, "dynamicAttributes") == attribute) + ]) { stop( "The events related to the dynamic attributes of this nodeset", " were mispecified." ) + } } else if (!is.null(attr(object, "events")) && - eventsName %in% attr(object, "events")) { - if (is.null(attr(object, "dynamicAttributes")) || - is.na(attr(object, "dynamicAttributes")[ - which(attr(object, "events") == eventsName) - ])) - stop( - "The events related to the dynamic attributes of this nodeset", - "were mispecified." - ) - attribute <- attr(object, "dynamicAttributes")[ + eventsName %in% attr(object, "events")) { + if (is.null(attr(object, "dynamicAttributes")) || + is.na(attr(object, "dynamicAttributes")[ which(attr(object, "events") == eventsName) - ] + ])) { + stop( + "The events related to the dynamic attributes of this nodeset", + "were mispecified." + ) + } + attribute <- attr(object, "dynamicAttributes")[ + which(attr(object, "events") == eventsName) + ] } # check classes and names of columns in events data.frame @@ -570,33 +615,42 @@ checkEvents.nodes.goldfish <- function( stop(e) } if (!(attribute == "present")) { - if (updateColumn) + if (updateColumn) { tryCatch( checkColumns(events, - mandatoryNames = c("time", "node"), - incompatibleNames = c("increment", "replace"), - classes = classesToCheck), - error = errorMessage) - else tryCatch( - checkColumns(events, - mandatoryNames = c("time", "node"), - classes = classesToCheck), - error = errorMessage) + mandatoryNames = c("time", "node"), + incompatibleNames = c("increment", "replace"), + classes = classesToCheck + ), + error = errorMessage + ) + } else { + tryCatch( + checkColumns(events, + mandatoryNames = c("time", "node"), + classes = classesToCheck + ), + error = errorMessage + ) + } } else if (attribute == "present") { classesToCheck["replace"] <- "logical" tryCatch( checkColumns(events, - mandatoryNames = c("time", "node", "replace"), - classes = classesToCheck), - error = errorMessage) + mandatoryNames = c("time", "node", "replace"), + classes = classesToCheck + ), + error = errorMessage + ) } - if (is.unsorted(events$time)) + if (is.unsorted(events$time)) { stop("Invalid events list: Events should be ordered by time.") + } # check presence of nodes compositionChanges <- findPresence(object) - if (!is.null(compositionChanges) && attribute != "present") + if (!is.null(compositionChanges) && attribute != "present") { tryCatch( checkPresence( events, @@ -604,21 +658,26 @@ checkEvents.nodes.goldfish <- function( get(compositionChanges, envir = environment) ) ) + } # check attributes compatibility if (!is.null(attribute)) { - if (is.null(object[[attribute]])) + if (is.null(object[[attribute]])) { stop( "The attribute ", dQuote(attribute), " doesn't exist in the nodeset." ) + } classAttr <- class(object[[attribute]]) - eventUpdate <- if (!is.null(events$replace)) events$replace - else events$increment + eventUpdate <- if (!is.null(events$replace)) { + events$replace + } else { + events$increment + } classEven <- class(eventUpdate) if (!all(checkClasses(object[[attribute]], classEven)) && - !all(checkClasses(eventUpdate, classAttr))) + !all(checkClasses(eventUpdate, classAttr))) { stop( "The type of the attribute ", dQuote(attribute), " is incompatible with the associated event list.", @@ -626,16 +685,18 @@ checkEvents.nodes.goldfish <- function( "\n\tevent (increment/replace) class: ", paste(classEven, collapse = ", ") ) + } } # if (all(events$node %in% object$label) && is.integer(events$node) && # (min(events$node) < 1 || max(events$node) > dim(object)[1])) # stop( # "Nodes indexes for the attribute ", dQuote(attribute), " are incorrect." # ) - if (!all(events$node %in% object$label)) + if (!all(events$node %in% object$label)) { stop( "Nodes labels for the attribute ", dQuote(attribute), " are incorrect." ) + } return(TRUE) } @@ -648,10 +709,9 @@ checkEvents.nodes.goldfish <- function( # If the network is not specified, less checks are possible !!! checkEvents.network.goldfish <- function( - object, events, eventsName, - nodes, nodes2 = NULL, - updateColumn = TRUE, environment = environment() -) { + object, events, eventsName, + nodes, nodes2 = NULL, + updateColumn = TRUE, environment = environment()) { # get data frames of presence events over the nodes sets isTwoMode <- !is.null(nodes2) nodesName <- c( @@ -659,25 +719,31 @@ checkEvents.network.goldfish <- function( as.character(substitute(nodes2, environment)) ) compositionChanges <- findPresence(nodes) - if (!is.null(compositionChanges)) + if (!is.null(compositionChanges)) { compositionChanges <- get(compositionChanges, envir = environment) + } if (isTwoMode) { compositionChanges2 <- findPresence(nodes2) - if (!is.null(compositionChanges2)) + if (!is.null(compositionChanges2)) { compositionChanges2 <- get(compositionChanges2, envir = environment) + } } if (!is.data.frame(events)) stop("An event list should be a data frame.") # check nodeset type if (!inherits(nodes, "nodes.goldfish") || - (isTwoMode && !inherits(nodes2, "nodes.goldfish"))) - tryCatch({ - checkNodes(nodes) - if (isTwoMode) checkNodes(nodes2) - }, error = function(e) { - e$message <- paste("Invalid nodeset(s): ", e$message) - stop(e) - }) + (isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { + tryCatch( + { + checkNodes(nodes) + if (isTwoMode) checkNodes(nodes2) + }, + error = function(e) { + e$message <- paste("Invalid nodeset(s): ", e$message) + stop(e) + } + ) + } classesToCheck <- list( time = c("POSIXlt", "POSIXct", "POSIXt", "numeric"), @@ -689,16 +755,16 @@ checkEvents.network.goldfish <- function( if (updateColumn) { tryCatch( checkColumns(events, - mandatoryNames = c("time", "sender", "receiver"), - incompatibleNames = c("increment", "replace"), - classes = classesToCheck + mandatoryNames = c("time", "sender", "receiver"), + incompatibleNames = c("increment", "replace"), + classes = classesToCheck ) ) } else { tryCatch( checkColumns(events, - mandatoryNames = c("time", "sender", "receiver"), - classes = classesToCheck + mandatoryNames = c("time", "sender", "receiver"), + classes = classesToCheck ) ) } @@ -706,8 +772,9 @@ checkEvents.network.goldfish <- function( if (is.unsorted(events$time)) stop("Events should be ordered by time.") # self-directed event - if (any(events[, "sender"] == events[, "receiver"])) + if (any(events[, "sender"] == events[, "receiver"])) { warning("At least one self-directed event in data.") + } # other checks # if (is.null(attr(object, "events")) || @@ -719,18 +786,21 @@ checkEvents.network.goldfish <- function( # "\nevents being checked: ", paste(eventsName, collapse = "") # ) if (is.null(attr(object, "nodes")) || - !all(nodesName %in% attr(object, "nodes"))) + !all(nodesName %in% attr(object, "nodes"))) { stop("The nodeset(s) associated to this network were mispecified.") + } # check presence of nodes - if (!is.null(compositionChanges)) + if (!is.null(compositionChanges)) { tryCatch( checkPresence(events, nodes, compositionChanges, onlyReceiver = FALSE) ) - if (isTwoMode && !is.null(compositionChanges2)) + } + if (isTwoMode && !is.null(compositionChanges2)) { tryCatch( checkPresence(events, nodes2, compositionChanges2, onlyReceiver = TRUE) ) + } # check attributes compatibility if (!isTwoMode) nodes2 <- nodes @@ -740,14 +810,19 @@ checkEvents.network.goldfish <- function( # if (!all(events$receiver %in% nodes2$label) && is.integer(events$receiver) # && (min(events$receiver) < 1 || max(events$receiver) > dim(nodes2)[1])) # stop("Nodes indexes in the receiver column are incorrect.") - if (!all(events$sender %in% nodes$label)) + if (!all(events$sender %in% nodes$label)) { stop("Nodes labels for the sender column are incorrect.") - if (!all(events$receiver %in% nodes2$label)) + } + if (!all(events$receiver %in% nodes2$label)) { stop("Nodes labels for the receiver column are incorrect.") + } - eventUpdate <- if (!is.null(events$replace)) events$replace - else events$increment - if (!all(checkClasses(eventUpdate, mode(object)))) + eventUpdate <- if (!is.null(events$replace)) { + events$replace + } else { + events$increment + } + if (!all(checkClasses(eventUpdate, mode(object)))) { stop( "The class of the associated event list is incompatible", " with the mode of the 'network.goldfish' object.", @@ -755,6 +830,7 @@ checkEvents.network.goldfish <- function( paste(class(eventUpdate), collapse = ", "), "\n\tmode network: ", paste(mode(object), collapse = ", ") ) + } return(TRUE) } @@ -766,10 +842,8 @@ checkEvents.network.goldfish <- function( # with the nodes presence specified in the nodeset(s) # this function doesn't check anything else than presence coherence! checkPresence <- function( - events, nodes, compositionChanges, onlyReceiver = FALSE -) { + events, nodes, compositionChanges, onlyReceiver = FALSE) { for (r in seq_len(nrow(events))) { - # find time and nodes for this event time <- events[r, ]["time"]$time if ("node" %in% names(events)) { @@ -788,9 +862,12 @@ checkPresence <- function( node <- eventNodes presence <- findLastPresence(node, time, nodes, compositionChanges) if (presence == -1) presence <- nodes$present[node] - if (!presence) - stop("Error in the events timestamps: the node ", - nodes$label[node], " is not present at time ", time) + if (!presence) { + stop( + "Error in the events timestamps: the node ", + nodes$label[node], " is not present at time ", time + ) + } } # check presence if it's a network event @@ -799,16 +876,22 @@ checkPresence <- function( node <- eventNodes[1] presence <- findLastPresence(node, time, nodes, compositionChanges) if (presence == -1) presence <- nodes$present[node] - if (!presence) - stop("Error in the events timestamps: the node ", nodes$label[node], - " is not present at time ", time) + if (!presence) { + stop( + "Error in the events timestamps: the node ", nodes$label[node], + " is not present at time ", time + ) + } } node <- eventNodes[2] presence <- findLastPresence(node, time, nodes, compositionChanges) if (presence == -1) presence <- nodes$present[node] - if (!presence) - stop("Error in the events timestamps: the node ", nodes$label[node], - " is not present at time ", time) + if (!presence) { + stop( + "Error in the events timestamps: the node ", nodes$label[node], + " is not present at time ", time + ) + } } } } @@ -829,7 +912,7 @@ checkPresence <- function( #' list( #' DyNAM = c("choice", "rate", "choice_coordination"), #' REM = c("choice") -#' ) +#' ) #' ) #' @noRd diff --git a/R/functions_data.R b/R/functions_data.R index bd76b97..2634ae3 100644 --- a/R/functions_data.R +++ b/R/functions_data.R @@ -39,7 +39,8 @@ #' bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) #' #' updateStates <- as.data.frame(states, -#' time = as.numeric(as.POSIXct("1965-12-31"))) +#' time = as.numeric(as.POSIXct("1965-12-31")) +#' ) #' #' #' updateNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1965-12-31"))) @@ -331,7 +332,7 @@ as.matrix.network.goldfish <- function(x, ..., time = -Inf, startTime = -Inf) { #' label = paste("Actor", 1:5), #' present = c(TRUE, FALSE, TRUE, TRUE, FALSE), #' gender = c(1, 2, 1, 1, 2) -#' ) +#' ) #' nodesAttr <- defineNodes(nodes = nodesAttr) #' #' # Social evolution nodes definition @@ -343,10 +344,13 @@ as.matrix.network.goldfish <- function(x, ..., time = -Inf, startTime = -Inf) { #' states <- defineNodes(states) defineNodes <- function(nodes) { # check input types - if (!is.data.frame(nodes)) - stop("Invalid argument ", dQuote("nodes"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), ".") + if (!is.data.frame(nodes)) { + stop( + "Invalid argument ", dQuote("nodes"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), "." + ) + } # define class class(nodes) <- unique(c("nodes.goldfish", class(nodes))) @@ -420,26 +424,34 @@ defineNodes <- function(nodes) { defineNetwork <- function( matrix = NULL, nodes, nodes2 = NULL, directed = TRUE, envir = environment()) { - # check input types isTwoMode <- !is.null(nodes2) nRow <- nrow(nodes) nCol <- ifelse(isTwoMode, nrow(nodes2), nrow(nodes)) - if (!any(checkClasses(nodes, c("data.frame", "nodes.goldfish")))) - stop("Invalid argument ", dQuote("nodes"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), ".") + if (!any(checkClasses(nodes, c("data.frame", "nodes.goldfish")))) { + stop( + "Invalid argument ", dQuote("nodes"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), "." + ) + } if (!is.null(nodes2) && - !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) - stop("Invalid argument ", dQuote("nodes2"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), ".") + !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { + stop( + "Invalid argument ", dQuote("nodes2"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), "." + ) + } - if (!is.logical(directed)) - stop("Invalid argument ", dQuote("directed"), ": ", - "this function expects a logical value.") + if (!is.logical(directed)) { + stop( + "Invalid argument ", dQuote("directed"), ": ", + "this function expects a logical value." + ) + } # Create empty matrix if needed if (is.null(matrix)) { @@ -451,14 +463,17 @@ defineNetwork <- function( ) ) } else if (is.table(matrix)) { - if (length(dim(matrix)) != 2) + if (length(dim(matrix)) != 2) { stop(dQuote("matrix"), ' object has an incorrect number of dimensions.", "Expected 2 dimensions') + } matrix <- structure(matrix, class = NULL, call = NULL) } else if (!any(checkClasses(matrix, c("matrix", "Matrix")))) { - stop("Invalid argument ", dQuote("matrix"), ": ", - "this function expects an objects of class ", - dQuote("matrix"), " or ", dQuote("Matrix"), ".") + stop( + "Invalid argument ", dQuote("matrix"), ": ", + "this function expects an objects of class ", + dQuote("matrix"), " or ", dQuote("Matrix"), "." + ) } # define class @@ -469,7 +484,8 @@ defineNetwork <- function( nodesName <- c( as.character(substitute(nodes, env = envir)), - as.character(substitute(nodes2, env = envir))) + as.character(substitute(nodes2, env = envir)) + ) attr(matrix, "nodes") <- nodesName attr(matrix, "directed") <- directed @@ -557,26 +573,39 @@ defineDependentEvents <- function(events, nodes, nodes2 = NULL, envir = environment()) { # check input types isTwoMode <- !is.null(nodes2) - if (!is.data.frame(events)) - stop("Invalid argument ", dQuote("events"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), ".") + if (!is.data.frame(events)) { + stop( + "Invalid argument ", dQuote("events"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), "." + ) + } - if (!any(checkClasses(nodes, c("data.frame", "nodes.goldfish")))) - stop("Invalid argument ", dQuote("nodes"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), ".") + if (!any(checkClasses(nodes, c("data.frame", "nodes.goldfish")))) { + stop( + "Invalid argument ", dQuote("nodes"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), "." + ) + } if (isTwoMode && - !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) - stop("Invalid argument ", dQuote("nodes2"), ": ", - "this function expects objects of class ", - dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), ".") + !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { + stop( + "Invalid argument ", dQuote("nodes2"), ": ", + "this function expects objects of class ", + dQuote("data.frame"), " or ", dQuote("nodes.goldfish"), "." + ) + } - if (!is.null(defaultNetwork) && !inherits(defaultNetwork, "network.goldfish")) - stop("Invalid argument ", dQuote("defaultNetwork"), ": ", - "this function expects objects of class ", - dQuote("network.goldfish"), ".") + if (!is.null(defaultNetwork) && + !inherits(defaultNetwork, "network.goldfish")) { # styler: off + stop( + "Invalid argument ", dQuote("defaultNetwork"), ": ", + "this function expects objects of class ", + dQuote("network.goldfish"), "." + ) + } # link objects nodesName <- c( @@ -593,21 +622,26 @@ defineDependentEvents <- function(events, nodes, nodes2 = NULL, # link events if defaultNetwork if (!is.null(defaultNetwork)) { - if (!all(attr(defaultNetwork, "nodes") == nodesName)) - stop("Node sets of default networks differ from", - " node sets of dependent event data frame.") + if (!all(attr(defaultNetwork, "nodes") == nodesName)) { + stop( + "Node sets of default networks differ from", + " node sets of dependent event data frame." + ) + } attr(events, "defaultNetwork") <- objDefNet attr(events, "type") <- "dyadic" # check defaultNetwork is defined with the same events - if (!any(objEvents %in% attr(defaultNetwork, "events"))) + if (!any(objEvents %in% attr(defaultNetwork, "events"))) { warning( "The events data frame is not linked to the defaultNetwork.", "\nEvents attached to the ", dQuote("defaultNetwork"), ": ", paste(attr(defaultNetwork, "events"), collapse = ", "), "\nDependent events: ", paste(objEvents, collapse = ""), - "\n") + "\n" + ) + } } else { attr(events, "type") <- "monadic" } @@ -617,15 +651,19 @@ defineDependentEvents <- function(events, nodes, nodes2 = NULL, checkDependentEvents( events = events, eventsName = objEvents, nodes = nodes, nodes2 = nodes2, - defaultNetwork = defaultNetwork, environment = envir), + defaultNetwork = defaultNetwork, environment = envir + ), error = function(e) { scalls <- sys.calls() e$call <- scalls[[1]] - e$message <- paste("The dependent events couldn't be constructed: ", - e$message) + e$message <- paste( + "The dependent events couldn't be constructed: ", + e$message + ) # events <- NA stop(e) - }) + } + ) return(events) } @@ -647,8 +685,9 @@ defineDependentEvents <- function(events, nodes, nodes2 = NULL, #' seasons <- defineGlobalAttribute(data.frame(time = 1:12, replace = 1:12)) defineGlobalAttribute <- function(global) { # check input types - if (!is.data.frame(global)) + if (!is.data.frame(global)) { stop("Invalid argument: this function expects a data frame.") + } # define class class(global) <- unique(c("global.goldfish", class(global))) @@ -659,11 +698,14 @@ defineGlobalAttribute <- function(global) { error = function(e) { scalls <- sys.calls() e$call <- scalls[[1]] - e$message <- paste("The global attribute couldn't be constructed: ", - e$message) + e$message <- paste( + "The global attribute couldn't be constructed: ", + e$message + ) # global <- NA stop(e) - }) + } + ) return(global) } @@ -796,18 +838,25 @@ linkEvents <- function(x, ...) { #' @export linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { # check input types - if (!(is.character(attribute) && length(attribute) == 1)) - stop("Invalid argument attributes:", - " this function expects a character attribute value.") + if (!(is.character(attribute) && length(attribute) == 1)) { + stop( + "Invalid argument attributes:", + " this function expects a character attribute value." + ) + } - if (!is.data.frame(changeEvents)) + if (!is.data.frame(changeEvents)) { stop("Invalid argument changeEvents: this function expects a data frame.") + } # data frame has to be passed as a variable name linkEnvir <- environment() - if (!is.name(substitute(changeEvents, linkEnvir))) - stop("Parameter change events has to be the name of a data frame", - " (rather than a data frame)") + if (!is.name(substitute(changeEvents, linkEnvir))) { + stop( + "Parameter change events has to be the name of a data frame", + " (rather than a data frame)" + ) + } # link data # initial <- object @@ -815,25 +864,32 @@ linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { objEventCurr <- as.character(substitute(changeEvents, linkEnvir)) if (length(objEventsPrev) > 0 && objEventCurr %in% objEventsPrev) { - warning("The event ", dQuote(objEventCurr), - " were already linked to this object.") - return(x) + warning( + "The event ", dQuote(objEventCurr), + " were already linked to this object." + ) + return(x) } attr(x, "events") <- c(objEventsPrev, objEventCurr) attr(x, "dynamicAttributes") <- c(attr(x, "dynamicAttributes"), attribute) # check format - tryCatch({ - checkEvents(object = x, events = changeEvents, eventsName = objEventCurr, - attribute = attribute, environment = linkEnvir) - }, error = function(e) { - scalls <- sys.calls() - e$call <- scalls[[1]] - e$message <- paste("The events couldn't be added: ", e$message) - # object <- initial - stop(e) - }) + tryCatch( + { + checkEvents( + object = x, events = changeEvents, eventsName = objEventCurr, + attribute = attribute, environment = linkEnvir + ) + }, + error = function(e) { + scalls <- sys.calls() + e$call <- scalls[[1]] + e$message <- paste("The events couldn't be added: ", e$message) + # object <- initial + stop(e) + } + ) return(x) } @@ -843,25 +899,38 @@ linkEvents.nodes.goldfish <- function(x, changeEvents, attribute, ...) { linkEvents.network.goldfish <- function(x, changeEvents, nodes = NULL, nodes2 = NULL, ...) { # check input types - if (is.null(nodes)) - stop("Invalid argument nodes: a network is specified,", - "this function expects an argument nodes.") - if (!is.data.frame(changeEvents)) + if (is.null(nodes)) { + stop( + "Invalid argument nodes: a network is specified,", + "this function expects an argument nodes." + ) + } + if (!is.data.frame(changeEvents)) { stop("Invalid argument changeEvents: this function expects a data frame.") + } isTwoMode <- !is.null(nodes2) - if (!is.data.frame(nodes)) - stop("Invalid argument nodes: this function expects a nodeset", - " (data frame or nodes.goldfish object).") - if (isTwoMode && !is.data.frame(nodes2)) - stop("Invalid argument nodes2: this function expects a nodeset", - " (data frame or nodes.goldfish object).") + if (!is.data.frame(nodes)) { + stop( + "Invalid argument nodes: this function expects a nodeset", + " (data frame or nodes.goldfish object)." + ) + } + if (isTwoMode && !is.data.frame(nodes2)) { + stop( + "Invalid argument nodes2: this function expects a nodeset", + " (data frame or nodes.goldfish object)." + ) + } # data frame has to be passed as a variable name linkEnvir <- environment() - if (!is.name(substitute(changeEvents, linkEnvir))) - stop("Parameter change events has to be the name of a data frame", - " (rather than a data frame)") + if (!is.name(substitute(changeEvents, linkEnvir))) { + stop( + "Parameter change events has to be the name of a data frame", + " (rather than a data frame)" + ) + } # link data # initial <- x @@ -869,23 +938,30 @@ linkEvents.network.goldfish <- function(x, changeEvents, objEventCurr <- as.character(substitute(changeEvents, linkEnvir)) if (length(objEventsPrev) > 0 && objEventCurr %in% objEventsPrev) { - warning("The event ", dQuote(objEventCurr), - " were already linked to this object.") - return(x) + warning( + "The event ", dQuote(objEventCurr), + " were already linked to this object." + ) + return(x) } attr(x, "events") <- c(objEventsPrev, objEventCurr) # check format - tryCatch({ - checkEvents(object = x, events = changeEvents, eventsName = objEventCurr, - nodes = nodes, nodes2 = nodes2, environment = linkEnvir) - }, error = function(e) { - scalls <- sys.calls() - e$call <- scalls[[1]] - e$message <- paste("The events couldn't be added: ", e$message) - # x <- initial - stop(e) - }) + tryCatch( + { + checkEvents( + object = x, events = changeEvents, eventsName = objEventCurr, + nodes = nodes, nodes2 = nodes2, environment = linkEnvir + ) + }, + error = function(e) { + scalls <- sys.calls() + e$call <- scalls[[1]] + e$message <- paste("The events couldn't be added: ", e$message) + # x <- initial + stop(e) + } + ) return(x) } @@ -893,8 +969,11 @@ linkEvents.network.goldfish <- function(x, changeEvents, #' @rdname linkEvents #' @export linkEvents.default <- function(x, ...) { - if (!any(checkClasses(x, c("nodes.goldfish", "network.goldfish")))) - stop("Invalid argument object: this function expects either a ", - dQuote("nodes.goldfish"), " or a ", dQuote("network.goldfish"), - " object.") + if (!any(checkClasses(x, c("nodes.goldfish", "network.goldfish")))) { + stop( + "Invalid argument object: this function expects either a ", + dQuote("nodes.goldfish"), " or a ", dQuote("network.goldfish"), + " object." + ) + } } diff --git a/R/functions_diagnostics.R b/R/functions_diagnostics.R index 1006593..f3cba83 100644 --- a/R/functions_diagnostics.R +++ b/R/functions_diagnostics.R @@ -30,8 +30,10 @@ #' } #' mod01 <- estimate(callsDependent ~ inertia + recip + trans, #' model = "DyNAM", subModel = "choice", -#' estimationInit = list(returnIntervalLogL = TRUE, -#' engine = "default_c") +#' estimationInit = list( +#' returnIntervalLogL = TRUE, +#' engine = "default_c" +#' ) #' ) #' #' examineOutliers(mod01) @@ -62,7 +64,6 @@ examineOutliers <- function(x, method = c("Hampel", "IQR", "Top"), parameter = 3, window = NULL) { - if (!"result.goldfish" %in% attr(x, "class")) { stop("Not a goldfish results object.") } @@ -97,8 +98,10 @@ examineOutliers <- function(x, if (method == "Top") { outlierIndexes <- order(data$intervalLogL)[1:parameter] } else if (method == "IQR") { - outlierIndexes <- which(data$intervalLogL < median(data$intervalLogL) - - (parameter / 2) * IQR(data$intervalLogL)) + outlierIndexes <- which( + data$intervalLogL < median(data$intervalLogL) - + (parameter / 2) * IQR(data$intervalLogL) + ) } else if (method == "Hampel") { if (is.null(window)) window <- (nrow(data) / 2) - 1 n <- length(data$intervalLogL) @@ -122,7 +125,8 @@ examineOutliers <- function(x, data$outlier[outlierIndexes] <- "YES" data$label[outlierIndexes] <- paste( data$sender, - data$receiver, sep = "-" + data$receiver, + sep = "-" )[outlierIndexes] } else { return(cat("No outliers found.")) @@ -132,11 +136,14 @@ examineOutliers <- function(x, ggplot2::geom_line() + ggplot2::geom_point(ggplot2::aes(color = .data$outlier)) + ggplot2::geom_text(ggplot2::aes(label = .data$label), - angle = 270, size = 2, - hjust = "outward", color = "red") + + angle = 270, size = 2, + hjust = "outward", color = "red" + ) + ggplot2::theme_minimal() + - ggplot2::scale_colour_manual(values = c("black","red"), - guide = "none") + + ggplot2::scale_colour_manual( + values = c("black", "red"), + guide = "none" + ) + ggplot2::xlab("") + ggplot2::ylab("Interval log likelihood") } @@ -172,7 +179,6 @@ examineChangepoints <- function(x, moment = c("mean", "variance"), method = c("PELT", "AMOC", "BinSeg"), window = NULL, ...) { - if (!methods::is(x, "result.goldfish")) { stop("Not a goldfish results object.", call. = FALSE) } @@ -208,31 +214,40 @@ examineChangepoints <- function(x, moment = c("mean", "variance"), if (moment == "mean") { cpt <- changepoint::cpt.mean(data$intervalLogL, - method = method, minseglen = window, ...) + method = method, minseglen = window, ... + ) } if (moment == "variance") { cpt <- changepoint::cpt.var(data$intervalLogL, - method = method, minseglen = window, ...) + method = method, minseglen = window, ... + ) } cpt.pts <- attributes(cpt)$cpts # cpt.mean <- attributes(cpt)$param.est$mean - if (anyDuplicated(data$time[cpt.pts])) + if (anyDuplicated(data$time[cpt.pts])) { cpt.pts <- cpt.pts[!duplicated(data$time[cpt.pts], - fromLast = TRUE)] - if (length(cpt.pts) == 1 && data$time[cpt.pts] == max(data$time)) + fromLast = TRUE + )] + } + if (length(cpt.pts) == 1 && data$time[cpt.pts] == max(data$time)) { return(cat("No regime changes found.")) + } ggplot2::ggplot(data, ggplot2::aes(x = .data$time, y = .data$intervalLogL)) + ggplot2::geom_line() + ggplot2::geom_point() + - ggplot2::geom_vline(xintercept = na.exclude(data$time[cpt.pts]), - color = "red") + + ggplot2::geom_vline( + xintercept = na.exclude(data$time[cpt.pts]), + color = "red" + ) + ggplot2::theme_minimal() + ggplot2::xlab("") + ggplot2::ylab("Interval log likelihood") + - ggplot2::scale_x_continuous(breaks = data$time[cpt.pts], - labels = data$time[cpt.pts]) + + ggplot2::scale_x_continuous( + breaks = data$time[cpt.pts], + labels = data$time[cpt.pts] + ) + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = 45, hjust = 1)) } diff --git a/R/functions_effects_DyNAM_choice.R b/R/functions_effects_DyNAM_choice.R index b75fce9..8fa7cbe 100644 --- a/R/functions_effects_DyNAM_choice.R +++ b/R/functions_effects_DyNAM_choice.R @@ -11,46 +11,56 @@ init_DyNAM_choice.default <- function( network = NULL, attribute = NULL, window, n1, n2) { - # print(match.call()) if (is.null(network) && is.null(attribute)) { # this check could be unnecessary - stop("the effect function doesn't specify neither a network", - " nor an attribute as argument") + stop( + "the effect function doesn't specify neither a network", + " nor an attribute as argument" + ) } # if multiple networks, attributes or combination of both are specified. # The initialization is done over the fist network # lenNetwork <- length(network) - hasNetwork <- length(network) >= 1 - hasMultNets <- length(network) >= 1 & is.list(network) - hasMultAtt <- length(attribute) >= 1 & is.list(attribute) + hasNetwork <- length(network) >= 1 + hasMultNets <- length(network) >= 1 & is.list(network) + hasMultAtt <- length(attribute) >= 1 & is.list(attribute) .argsNames <- names(formals(effectFun)) # if network inputs, just the first network is empty. stats <- matrix(0, nrow = n1, ncol = n2) # check for poss # init a generic cache object - if ("cache" %in% .argsNames) cache <- stats - else cache <- NULL + if ("cache" %in% .argsNames) { + cache <- stats + } else { + cache <- NULL + } if (hasNetwork) { # check if not empty network to initialize the statistical matrix # create a copy of the network to iterate over if (hasMultNets) { - areEmpty <- vapply(network, - function(x) all(x[!is.na(x)] == 0), - logical(1)) + areEmpty <- vapply( + network, + function(x) all(x[!is.na(x)] == 0), + logical(1) + ) if ((!is.null(window) && !is.infinite(window)) || any(areEmpty)) { - if (is.null(cache)) return(list(stat = stats)) - return(list(cache = cache, stat = stats)) + if (is.null(cache)) { + return(list(stat = stats)) + } + return(list(cache = cache, stat = stats)) } netIter <- network[[1]] } else { if ((!is.null(window) && !is.infinite(window)) || - all(network[!is.na(network)] == 0)) { - if (is.null(cache)) return(list(stat = stats)) - return(list(cache = cache, stat = stats)) + all(network[!is.na(network)] == 0)) { + if (is.null(cache)) { + return(list(stat = stats)) + } + return(list(cache = cache, stat = stats)) } netIter <- network } @@ -58,18 +68,24 @@ init_DyNAM_choice.default <- function( emptyObject <- array(0, dim = dim(netIter)) } else { if (hasMultAtt) { - areEmpty <- vapply(attribute, - function(x) all(x[!is.na(x)] == 0), - logical(1)) + areEmpty <- vapply( + attribute, + function(x) all(x[!is.na(x)] == 0), + logical(1) + ) if (any(areEmpty)) { - if (is.null(cache)) return(list(stat = stats)) - return(list(cache = cache, stat = stats)) + if (is.null(cache)) { + return(list(stat = stats)) + } + return(list(cache = cache, stat = stats)) } attIter <- attribute[[1]] } else { if (all(attribute[!is.na(attribute)] == 0)) { - if (is.null(cache)) return(list(stat = stats)) - return(list(cache = cache, stat = stats)) + if (is.null(cache)) { + return(list(stat = stats)) + } + return(list(cache = cache, stat = stats)) } attIter <- attribute } @@ -150,7 +166,9 @@ init_DyNAM_choice.default <- function( emptyObject[i] <- attIter[i] } } - if (is.null(cache)) return(list(stat = stats)) + if (is.null(cache)) { + return(list(stat = stats)) + } return(list(cache = cache, stat = stats)) } @@ -179,8 +197,9 @@ init_DyNAM_choice.default <- function( #' ), #' nrow = 5, ncol = 6, byrow = TRUE #' ) -#' effectFUN <- function(weighted = TRUE, transformFun = identity) +#' effectFUN <- function(weighted = TRUE, transformFun = identity) { #' NULL +#' } #' init_DyNAM_choice.tie(effectFUN, network) #' } init_DyNAM_choice.tie <- function(effectFun, network, window, n1, n2) { @@ -230,14 +249,14 @@ init_DyNAM_choice.tie <- function(effectFun, network, window, n1, n2) { #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' update_DyNAM_choice_tie(network, -#' 1, 2, 3, -#' weighted = TRUE, transformFun = sqrt) +#' 1, 2, 3, +#' weighted = TRUE, transformFun = sqrt +#' ) #' } update_DyNAM_choice_tie <- function( network, sender, receiver, replace, weighted = FALSE, transformFun = identity) { - # No change check, irrelevant for two-mode network # if(sender == receiver) return(NULL) @@ -267,8 +286,11 @@ update_DyNAM_choice_tie <- function( res$changes <- cbind( node1 = sender, node2 = receiver, - replace = if (!weighted) - 1 * (replace > 0) else forceAndCall(1, transformFun, replace) + replace = if (!weighted) { + 1 * (replace > 0) + } else { + forceAndCall(1, transformFun, replace) + } ) return(res) @@ -276,8 +298,10 @@ update_DyNAM_choice_tie <- function( # inertia ----------------------------------------------------------------- init_DyNAM_choice.inertia <- function(effectFun, network, window, n1, n2) { - init_DyNAM_choice.tie(effectFun = effectFun, network = network, - window = window, n1 = n1, n2 = n2) + init_DyNAM_choice.tie( + effectFun = effectFun, network = network, + window = window, n1 = n1, n2 = n2 + ) } #' @aliases inertia @@ -319,15 +343,18 @@ update_DyNAM_choice_inertia <- function( #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' effectFUN <- function(weighted = TRUE, isTwoMode = FALSE, -#' transformFun = identity) +#' transformFun = identity) { #' NULL +#' } #' init_DyNAM_choice.indeg(effectFUN, network, NULL, 5, 6) #' } init_DyNAM_choice.indeg <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "alter")) - init_REM_choice.indeg(effectFun = effectFun, network = network, - window = window, - n1 = n1, n2 = n2) + init_REM_choice.indeg( + effectFun = effectFun, network = network, + window = window, + n1 = n1, n2 = n2 + ) } @@ -366,8 +393,8 @@ init_DyNAM_choice.indeg <- function(effectFun, network, window, n1, n2) { #' network, #' 1, 2, 3, #' cache, 5, 6, -#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt) -#' +#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt +#' ) #' } update_DyNAM_choice_indeg <- function( network, @@ -411,15 +438,18 @@ update_DyNAM_choice_indeg <- function( #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' effectFUN <- function(weighted = TRUE, isTwoMode = FALSE, -#' transformFun = identity) +#' transformFun = identity) { #' NULL +#' } #' init_DyNAM_choice.outdeg(effectFUN, network, NULL, 5, 6) #' init_DyNAM_choice.outdeg(effectFUN, network, 1, 5, 6) #' } init_DyNAM_choice.outdeg <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "alter")) - init_REM_choice.outdeg(effectFun = effectFun, network = network, - window = window, n1 = n1, n2 = n2) + init_REM_choice.outdeg( + effectFun = effectFun, network = network, + window = window, n1 = n1, n2 = n2 + ) } @@ -458,8 +488,8 @@ init_DyNAM_choice.outdeg <- function(effectFun, network, window, n1, n2) { #' network, #' 1, 2, 3, #' cache, 5, 6, -#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt) -#' +#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt +#' ) #' } update_DyNAM_choice_outdeg <- function( network, @@ -501,8 +531,9 @@ update_DyNAM_choice_outdeg <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' effectFUN <- function(weighted = FALSE, isTwoMode = FALSE, -#' transformFun = sqrt) +#' transformFun = sqrt) { #' NULL +#' } #' #' init_DyNAM_choice.recip(effectFUN, network, NULL, 5, 5) #' } @@ -514,9 +545,10 @@ init_DyNAM_choice.recip <- function(effectFun, network, window, n1, n2) { if (isTwoMode) { stop(dQuote("recip"), - " effect must not be used when is a two-mode network", - " (isTwoMode = TRUE)", - call. = FALSE) + " effect must not be used when is a two-mode network", + " (isTwoMode = TRUE)", + call. = FALSE + ) } # has window or is empty initialize empty @@ -566,7 +598,8 @@ init_DyNAM_choice.recip <- function(effectFun, network, window, n1, n2) { #' update_DyNAM_choice_recip( #' network, #' 1, 2, 9, -#' weighted = TRUE, isTwoMode = FALSE, transformFun = sqrt) +#' weighted = TRUE, isTwoMode = FALSE, transformFun = sqrt +#' ) #' } update_DyNAM_choice_recip <- function( network, @@ -574,7 +607,6 @@ update_DyNAM_choice_recip <- function( weighted = FALSE, isTwoMode = FALSE, transformFun = identity) { - # init res res <- list(changes = NULL) @@ -606,8 +638,11 @@ update_DyNAM_choice_recip <- function( res$changes <- cbind( node1 = receiver, node2 = sender, - replace = if (!weighted) - 1 * (replace > 0) else forceAndCall(1, transformFun, replace) + replace = if (!weighted) { + 1 * (replace > 0) + } else { + forceAndCall(1, transformFun, replace) + } ) return(res) @@ -618,7 +653,8 @@ init_DyNAM_choice.nodeTrans <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "alter")) init_REM_choice.nodeTrans( effectFun = effectFun, network = network, - window = window, n1 = n1, n2 = n2) + window = window, n1 = n1, n2 = n2 + ) } update_DyNAM_choice_nodeTrans <- function( @@ -634,7 +670,8 @@ update_DyNAM_choice_nodeTrans <- function( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, - transformFun = transformFun, type = "alter") + transformFun = transformFun, type = "alter" + ) } # Closure effects -------------------------------------------------------------- @@ -664,8 +701,9 @@ update_DyNAM_choice_nodeTrans <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.trans(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_choice.trans <- function(effectFun, network, window, n1, n2) { @@ -676,8 +714,10 @@ init_DyNAM_choice.trans <- function(effectFun, network, window, n1, n2) { if (isTwoMode) { stop(dQuote("trans"), - " effect must not use when is a two-mode network", - " (isTwoMode = TRUE)", call. = FALSE) + " effect must not use when is a two-mode network", + " (isTwoMode = TRUE)", + call. = FALSE + ) } # has window or is empty initialize empty @@ -685,7 +725,7 @@ init_DyNAM_choice.trans <- function(effectFun, network, window, n1, n2) { return(list( cache = matrix(0, nrow = n1, ncol = n2), stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2) - )) + )) } # always weighted network <- sign(network) @@ -733,8 +773,10 @@ init_DyNAM_choice.trans <- function(effectFun, network, window, n1, n2) { #' 0, 0, 0, 0, 0, #' 0, 0, 0, 0, 0, #' 0, 0, 0, 1, 1, -#' 0, 0, 0, 0, 0), -#' nrow = 5, ncol = 5) +#' 0, 0, 0, 0, 0 +#' ), +#' nrow = 5, ncol = 5 +#' ) #' #' update_DyNAM_choice_trans(network, 4, 3, 5, cache, transformFun = sqrt) #' update_DyNAM_choice_trans(network, 1, 4, 0, cache, transformFun = sqrt) @@ -774,7 +816,7 @@ update_DyNAM_choice_trans <- function( inSender <- which(temp > 0) # when sender = i and receiver = k, constraint that i != k has been satisfied. temp <- network[receiver, ] - #temp[c(sender, receiver)] <- 0 # don't consider the cases with k = j + # temp[c(sender, receiver)] <- 0 # don't consider the cases with k = j temp[receiver] <- 0 # don't consider the cases with k = j outReceiver <- which(temp > 0) ids <- rbind( @@ -821,8 +863,9 @@ update_DyNAM_choice_trans <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.cycle(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_choice.cycle <- function(effectFun, network, window, n1, n2) { @@ -833,8 +876,10 @@ init_DyNAM_choice.cycle <- function(effectFun, network, window, n1, n2) { if (isTwoMode) { stop(dQuote("cycle"), - " effect must not use when is a two-mode network", - " (isTwoMode = TRUE)", call. = FALSE) + " effect must not use when is a two-mode network", + " (isTwoMode = TRUE)", + call. = FALSE + ) } # has window or is empty initialize empty @@ -890,8 +935,10 @@ init_DyNAM_choice.cycle <- function(effectFun, network, window, n1, n2) { #' 0, 0, 0, 0, 0, #' 0, 0, 0, 0, 0, #' 0, 0, 0, 1, 1, -#' 0, 0, 0, 0, 0), -#' nrow = 5, ncol = 5) +#' 0, 0, 0, 0, 0 +#' ), +#' nrow = 5, ncol = 5 +#' ) #' #' update_DyNAM_choice_cycle(network, 4, 3, 5, cache, transformFun = sqrt) #' update_DyNAM_choice_cycle(network, 1, 4, 0, cache, transformFun = sqrt) @@ -981,8 +1028,9 @@ update_DyNAM_choice_cycle <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.commonReceiver(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_choice.commonReceiver <- function(effectFun, network, @@ -996,13 +1044,15 @@ init_DyNAM_choice.commonReceiver <- function(effectFun, network, stop( "'commonReceiver' effect requeries that the dependent network", " is a one-mode network", - call. = FALSE) + call. = FALSE + ) } else { warning( " (isTwoMode = TRUE) \n has conformable dimensions with the", " dependent network, i.e.,\n the first mode nodes set is the same", " as the nodes set of the one-mode dependet network.", - call. = FALSE, immediate. = TRUE) + call. = FALSE, immediate. = TRUE + ) } if (isTwoMode) { @@ -1011,7 +1061,8 @@ init_DyNAM_choice.commonReceiver <- function(effectFun, network, " (isTwoMode = TRUE) \n has conformable dimensions with the", " dependent network, i.e.,\n the first mode nodes set is the same", " as the nodes set of the one-mode dependet network.", - call. = FALSE, immediate. = TRUE) + call. = FALSE, immediate. = TRUE + ) } # has window or is empty initialize empty @@ -1065,23 +1116,28 @@ init_DyNAM_choice.commonReceiver <- function(effectFun, network, #' 0, 0, 0, 0, 0, #' 0, 0, 1, 0, 1, #' 0, 0, 0, 1, 1, -#' 0, 0, 1, 1, 2), -#' nrow = 5, ncol = 5) +#' 0, 0, 1, 1, 2 +#' ), +#' nrow = 5, ncol = 5 +#' ) #' #' update_DyNAM_choice_commonReceiver(network, 2, 1, 5, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_commonReceiver(network, 3, 2, 0, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_commonReceiver(network, 2, 5, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' } update_DyNAM_choice_commonReceiver <- function( - network, - sender, - receiver, - replace, cache, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, + receiver, + replace, cache, + isTwoMode = FALSE, + transformFun = identity) { # only relevant for one-mode networks res <- list(cache = cache, changes = NULL) if (sender == receiver) { @@ -1154,8 +1210,9 @@ update_DyNAM_choice_commonReceiver <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.commonSender(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_choice.commonSender <- function(effectFun, network, window, n1, n2) { @@ -1217,26 +1274,31 @@ init_DyNAM_choice.commonSender <- function(effectFun, network, window, n1, n2) { #' 0, 0, 0, 0, 0, #' 0, 0, 1, 0, 1, #' 0, 0, 0, 1, 1, -#' 0, 0, 1, 1, 2), -#' nrow = 5, ncol = 5) +#' 0, 0, 1, 1, 2 +#' ), +#' nrow = 5, ncol = 5 +#' ) #' #' update_DyNAM_choice_commonSender( -#' network, 1, 2, 5, cache, transformFun = sqrt +#' network, 1, 2, 5, cache, +#' transformFun = sqrt #' ) #' update_DyNAM_choice_commonSender( -#' network, 5, 1, 0, cache, transformFun = sqrt +#' network, 5, 1, 0, cache, +#' transformFun = sqrt #' ) #' update_DyNAM_choice_commonSender( -#' network, 2, 4, 5, cache, transformFun = sqrt +#' network, 2, 4, 5, cache, +#' transformFun = sqrt #' ) #' } update_DyNAM_choice_commonSender <- function( - network, - sender, - receiver, - replace, cache, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, + receiver, + replace, cache, + isTwoMode = FALSE, + transformFun = identity) { # only relevant for one-mode networks res <- list(cache = cache, changes = NULL) if (sender == receiver) { @@ -1317,12 +1379,12 @@ update_DyNAM_choice_commonSender <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' networks <- list(net1, net2) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.mixedTrans(effectFUN, networks, NULL, 5, 5) #' init_DyNAM_choice.mixedTrans(effectFUN, networks, 1, 5, 5) #' } - init_DyNAM_choice.mixedTrans <- function(effectFun, network, window, n1, n2) { # Get arguments params <- formals(effectFun) @@ -1333,18 +1395,21 @@ init_DyNAM_choice.mixedTrans <- function(effectFun, network, window, n1, n2) { network2 <- sign(network[[2]]) network1 <- sign(network[[1]]) if (ncol(network1) != nrow(network2) || - nrow(network1) != n1 || ncol(network2) != n2) - stop("Non conformable dimensions sizes for effect ", dQuote("mixedTrans"), - ".\n\tnetwork 1: ", - paste(dim(network1), collapse = ", "), - "\n\tnetwork 2: ", paste(dim(network2), collapse = ", "), - "\n\tdependent network: ", n1, ", ", n2, - "\n\trows of network 1 and cols of network 2 must be the same size", - "\n\tas the correspondent dimension in the dependent network,", - "\n\tcols of network 1 must be the same size as rows of network2") + nrow(network1) != n1 || ncol(network2) != n2) { + stop( + "Non conformable dimensions sizes for effect ", dQuote("mixedTrans"), + ".\n\tnetwork 1: ", + paste(dim(network1), collapse = ", "), + "\n\tnetwork 2: ", paste(dim(network2), collapse = ", "), + "\n\tdependent network: ", n1, ", ", n2, + "\n\trows of network 1 and cols of network 2 must be the same size", + "\n\tas the correspondent dimension in the dependent network,", + "\n\tcols of network 1 must be the same size as rows of network2" + ) + } # has window or is empty initialize empty if ((!is.null(window) && !is.infinite(window)) || - all(network1 == 0) || all(network2 == 0)) { + all(network1 == 0) || all(network2 == 0)) { return(list( cache = matrix(0, nrow = n1, ncol = n2), stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2) @@ -1405,29 +1470,36 @@ init_DyNAM_choice.mixedTrans <- function(effectFun, network, window, n1, n2) { #' ) #' networks <- list(net1, net2) #' cache <- matrix( -#' c( -#' 1, 0, 0, 0, 0, -#' 0, 0, 0, 1, 0, -#' 1, 0, 0, 0, 0, -#' 0, 1, 0, 0, 0, -#' 1, 0, 0, 0, 0), -#' nrow = 5, ncol = 5, byrow = TRUE) +#' c( +#' 1, 0, 0, 0, 0, +#' 0, 0, 0, 1, 0, +#' 1, 0, 0, 0, 0, +#' 0, 1, 0, 0, 0, +#' 1, 0, 0, 0, 0 +#' ), +#' nrow = 5, ncol = 5, byrow = TRUE +#' ) #' update_DyNAM_choice_mixedTrans(networks, 4, 3, 5, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedTrans(networks, 4, 3, 5, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedTrans(networks, 2, 1, 0, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' } update_DyNAM_choice_mixedTrans <- function(network, sender, receiver, replace, netUpdate, cache, isTwoMode = FALSE, transformFun = identity) { - if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) + if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) { stop(dQuote("mixedTrans"), "receive a wrong ", - dQuote("netUpdate")," argument. ", - "Check you declare only two networks in network argument", - call. = FALSE) + dQuote("netUpdate"), " argument. ", + "Check you declare only two networks in network argument", + call. = FALSE + ) + } network2 <- network[[2]] network1 <- network[[1]] @@ -1539,12 +1611,12 @@ update_DyNAM_choice_mixedTrans <- function(network, sender, receiver, replace, #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' networks <- list(net1, net2) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.mixedCycle(effectFUN, networks, NULL, 5, 5) #' init_DyNAM_choice.mixedCycle(effectFUN, networks, 1, 5, 5) #' } - init_DyNAM_choice.mixedCycle <- function(effectFun, network, window, n1, n2) { # Get arguments params <- formals(effectFun) @@ -1556,17 +1628,20 @@ init_DyNAM_choice.mixedCycle <- function(effectFun, network, window, n1, n2) { network1 <- sign(network[[1]]) if (ncol(network1) != nrow(network2) || - nrow(network1) != n1 || ncol(network2) != n2) - stop("Non conformable dimensions sizes for effect ", dQuote("mixedCycle"), - ".\n\tnetwork 1: ", paste(dim(network1), collapse = ", "), - "\n\tnetwork 2: ", paste(dim(network2), collapse = ", "), - "\n\tdependent network: ", n1, ", ", n2, - "\n\trows of network 1 and cols of network 2 must be the same size", - "\n\tas cols and rows in dependent network respectively,", - "\n\tcols size of network 1 must be the same as rows size of network2") + nrow(network1) != n1 || ncol(network2) != n2) { + stop( + "Non conformable dimensions sizes for effect ", dQuote("mixedCycle"), + ".\n\tnetwork 1: ", paste(dim(network1), collapse = ", "), + "\n\tnetwork 2: ", paste(dim(network2), collapse = ", "), + "\n\tdependent network: ", n1, ", ", n2, + "\n\trows of network 1 and cols of network 2 must be the same size", + "\n\tas cols and rows in dependent network respectively,", + "\n\tcols size of network 1 must be the same as rows size of network2" + ) + } # has window or is empty initialize empty if ((!is.null(window) && !is.infinite(window)) || - all(network1 == 0) || all(network2 == 0)) { + all(network1 == 0) || all(network2 == 0)) { return(list( cache = matrix(0, nrow = n1, ncol = n2), stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2) @@ -1626,29 +1701,37 @@ init_DyNAM_choice.mixedCycle <- function(effectFun, network, window, n1, n2) { #' ) #' networks <- list(net1, net2) #' cache <- matrix( -#' c( -#' 1, 0, 0, 0, 0, -#' 0, 0, 0, 1, 0, -#' 1, 0, 0, 0, 0, -#' 0, 1, 0, 0, 0, -#' 1, 0, 0, 0, 0), -#' nrow = 5, ncol = 5, byrow = TRUE) +#' c( +#' 1, 0, 0, 0, 0, +#' 0, 0, 0, 1, 0, +#' 1, 0, 0, 0, 0, +#' 0, 1, 0, 0, 0, +#' 1, 0, 0, 0, 0 +#' ), +#' nrow = 5, ncol = 5, byrow = TRUE +#' ) #' update_DyNAM_choice_mixedCycle(networks, 4, 3, 5, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCycle(networks, 4, 3, 5, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCycle(networks, 2, 1, 0, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' } update_DyNAM_choice_mixedCycle <- function( network, sender, receiver, replace, netUpdate, cache, isTwoMode = FALSE, transformFun = identity) { - if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) + if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) { stop(dQuote("mixedCycle"), " receive a wrong ", - dQuote("netUpdate")," argument. ", - "Check that you only declare two networks as argument.", call. = FALSE) + dQuote("netUpdate"), " argument. ", + "Check that you only declare two networks as argument.", + call. = FALSE + ) + } network2 <- network[[2]] network1 <- network[[1]] @@ -1759,12 +1842,12 @@ update_DyNAM_choice_mixedCycle <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' networks <- list(net1, net2) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.mixedCommonReceiver(effectFUN, networks, NULL, 5, 5) #' init_DyNAM_choice.mixedCommonReceiver(effectFUN, networks, 1, 5, 5) #' } - init_DyNAM_choice.mixedCommonReceiver <- function(effectFun, network, window, n1, n2) { # Get arguments @@ -1773,15 +1856,16 @@ init_DyNAM_choice.mixedCommonReceiver <- function(effectFun, network, funApply <- eval(params[["transformFun"]]) if (isTwoMode) { stop(dQuote("mixedCommonReceiver"), - " effect must not use when is a two-mode network (isTwoMode = TRUE)", - call. = FALSE) + " effect must not use when is a two-mode network (isTwoMode = TRUE)", + call. = FALSE + ) } # always weighted, detach networks network2 <- sign(network[[2]]) network1 <- sign(network[[1]]) # has window or is empty initialize empty if ((!is.null(window) && !is.infinite(window)) || - all(network1 == 0) || all(network2 == 0)) { + all(network1 == 0) || all(network2 == 0)) { return(list( cache = matrix(0, nrow = n1, ncol = n2), stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2) @@ -1842,32 +1926,40 @@ init_DyNAM_choice.mixedCommonReceiver <- function(effectFun, network, #' ) #' networks <- list(net1, net2) #' cache <- matrix( -#' c(1, 0, 0, 0, 0, +#' c( +#' 1, 0, 0, 0, 0, #' 0, 1, 0, 0, 0, #' 0, 0, 1, 0, 1, #' 0, 1, 0, 0, 0, -#' 0, 1, 1, 0, 1), -#' nrow = 5, ncol = 5), -#' nrow = 5, ncol = 5, byrow = TRUE) +#' 0, 1, 1, 0, 1 +#' ), +#' nrow = 5, ncol = 5, byrow = TRUE +#' ) #' update_DyNAM_choice_mixedCommonReceiver(networks, 5, 1, 2, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonReceiver(networks, 5, 2, 0, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonReceiver(networks, 2, 3, 6, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonReceiver(networks, 4, 3, 6, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' } update_DyNAM_choice_mixedCommonReceiver <- function( - network, sender, receiver, replace, - netUpdate, - cache, isTwoMode = FALSE, - transformFun = identity) { - - if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) + network, sender, receiver, replace, + netUpdate, + cache, isTwoMode = FALSE, + transformFun = identity) { + if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) { stop(dQuote("mixedCommonReceiver"), - "receive a wrong ", dQuote("netUpdate")," argument. ", - "Check that you only declare two networks as argument", call. = FALSE) + "receive a wrong ", dQuote("netUpdate"), " argument. ", + "Check that you only declare two networks as argument", + call. = FALSE + ) + } network2 <- network[[2]] network1 <- network[[1]] @@ -1895,8 +1987,10 @@ update_DyNAM_choice_mixedCommonReceiver <- function( temp[c(sender, receiver)] <- 0 inReceiver <- which(temp > 0) if (length(inReceiver) > 0) { - ids <- rbind(cbind(sender, inReceiver), - cbind(inReceiver, sender)) + ids <- rbind( + cbind(sender, inReceiver), + cbind(inReceiver, sender) + ) replaceValues <- replace - oldValue + res$cache[cbind(ids[, 1], ids[, 2])] res$cache[cbind(ids[, 1], ids[, 2])] <- replaceValues res$changes <- cbind( @@ -1926,8 +2020,10 @@ update_DyNAM_choice_mixedCommonReceiver <- function( temp[c(sender, receiver)] <- 0 inReceiver <- which(temp > 0) if (length(inReceiver) > 0) { - ids <- rbind(cbind(inReceiver, sender), - cbind(sender, inReceiver)) + ids <- rbind( + cbind(inReceiver, sender), + cbind(sender, inReceiver) + ) replaceValues <- replace - oldValue + res$cache[cbind(ids[, 1], ids[, 2])] res$cache[cbind(ids[, 1], ids[, 2])] <- replaceValues res$changes <- cbind( @@ -1979,12 +2075,12 @@ update_DyNAM_choice_mixedCommonReceiver <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' networks <- list(net1, net2) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.mixedCommonSender(effectFUN, networks, NULL, 5, 5) #' init_DyNAM_choice.mixedCommonSender(effectFUN, networks, 1, 5, 5) #' } - init_DyNAM_choice.mixedCommonSender <- function(effectFun, network, window, n1, n2) { # Get arguments @@ -1993,15 +2089,16 @@ init_DyNAM_choice.mixedCommonSender <- function(effectFun, network, funApply <- eval(params[["transformFun"]]) if (isTwoMode) { stop(dQuote("mixedCommonSender"), - " effect must not use when is a two-mode network (isTwoMode = TRUE)", - call. = FALSE) + " effect must not use when is a two-mode network (isTwoMode = TRUE)", + call. = FALSE + ) } # always weighted, detach networks network2 <- sign(network[[2]]) network1 <- sign(network[[1]]) # has window or is empty initialize empty if ((!is.null(window) && !is.infinite(window)) || - all(network1 == 0) || all(network2 == 0)) { + all(network1 == 0) || all(network2 == 0)) { return(list( cache = matrix(0, nrow = n1, ncol = n2), stat = matrix(forceAndCall(1, funApply, 0), nrow = n1, ncol = n2) @@ -2062,32 +2159,40 @@ init_DyNAM_choice.mixedCommonSender <- function(effectFun, network, #' ) #' networks <- list(net1, net2) #' cache <- matrix( -#' c(1, 1, 1, 0, 0, +#' c( +#' 1, 1, 1, 0, 0, #' 0, 2, 0, 0, 0, #' 0, 0, 0, 0, 0, #' 0, 0, 0, 1, 0, -#' 0, 0, 0, 0, 0), -#' nrow = 5, ncol = 5) +#' 0, 0, 0, 0, 0 +#' ), +#' nrow = 5, ncol = 5 +#' ) #' update_DyNAM_choice_mixedCommonSender(networks, 3, 4, 2, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonSender(networks, 5, 3, 2, 2, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonSender(networks, 4, 3, 0, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' update_DyNAM_choice_mixedCommonSender(networks, 1, 4, 0, 1, cache, -#' transformFun = sqrt) +#' transformFun = sqrt +#' ) #' } update_DyNAM_choice_mixedCommonSender <- function( - network, sender, receiver, replace, - netUpdate, - cache, isTwoMode = FALSE, - transformFun = identity) { - - if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) + network, sender, receiver, replace, + netUpdate, + cache, isTwoMode = FALSE, + transformFun = identity) { + if (length(netUpdate) > 1 || !netUpdate %in% c(1, 2)) { stop(dQuote("mixedCommonSender"), - "receive a wrong ", dQuote("netUpdate")," argument. ", - "Check that only two networks are declared in the 'network' argument", - call. = FALSE) + "receive a wrong ", dQuote("netUpdate"), " argument. ", + "Check that only two networks are declared in the 'network' argument", + call. = FALSE + ) + } network2 <- network[[2]] network1 <- network[[1]] @@ -2115,8 +2220,10 @@ update_DyNAM_choice_mixedCommonSender <- function( temp[c(sender, receiver)] <- 0 outSender <- which(temp > 0) if (length(outSender) > 0) { - ids <- rbind(cbind(receiver, outSender), - cbind(outSender, receiver)) + ids <- rbind( + cbind(receiver, outSender), + cbind(outSender, receiver) + ) replaceValues <- replace - oldValue + res$cache[cbind(ids[, 1], ids[, 2])] res$cache[cbind(ids[, 1], ids[, 2])] <- replaceValues res$changes <- cbind( @@ -2146,8 +2253,10 @@ update_DyNAM_choice_mixedCommonSender <- function( temp[c(sender, receiver)] <- 0 outSender <- which(temp > 0) if (length(outSender) > 0) { - ids <- rbind(cbind(outSender, receiver), - cbind(receiver, outSender)) + ids <- rbind( + cbind(outSender, receiver), + cbind(receiver, outSender) + ) replaceValues <- replace - oldValue + res$cache[cbind(ids[, 1], ids[, 2])] res$cache[cbind(ids[, 1], ids[, 2])] <- replaceValues res$changes <- cbind( @@ -2188,8 +2297,9 @@ update_DyNAM_choice_mixedCommonSender <- function( #' ), #' nrow = 5, ncol = 5, byrow = TRUE #' ) -#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) +#' effectFUN <- function(isTwoMode = FALSE, transformFun = sqrt) { #' NULL +#' } #' init_DyNAM_choice.four(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_choice.four <- function(effectFun, network, window, n1, n2) { @@ -2278,10 +2388,11 @@ init_DyNAM_choice.four <- function(effectFun, network, window, n1, n2) { #' ) #' #' update_DyNAM_choice_four(network, -#' 3, 5, 2, -#' cache, -#' isTwoMode = TRUE, -#' transformFun = identity) +#' 3, 5, 2, +#' cache, +#' isTwoMode = TRUE, +#' transformFun = identity +#' ) #' } update_DyNAM_choice_four <- function( network, @@ -2304,7 +2415,9 @@ update_DyNAM_choice_four <- function( } if (is.na(oldValue)) oldValue <- 0 if (is.na(replace)) replace <- 0 - if (!isTwoMode && sender == receiver) return(res) + if (!isTwoMode && sender == receiver) { + return(res) + } # CALCULATE CHANGE # If isIncrease is 1, then the number of edges just from zero to nonzero, @@ -2385,7 +2498,8 @@ update_DyNAM_choice_four <- function( changes[, "replace"] <- forceAndCall( 1, transformFun, - ifelse(changes[, "replace"] >= 0, changes[, "replace"], 0)) + ifelse(changes[, "replace"] >= 0, changes[, "replace"], 0) + ) } return(list(cache = cache, changes = changes)) @@ -2397,10 +2511,12 @@ update_DyNAM_choice_four <- function( init_DyNAM_choice.tertius <- function(effectFun, network, attribute, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "alter")) - init_REM_choice.tertius(effectFun = effectFun, - network = network, attribute = attribute, - window = window, - n1 = n1, n2 = n2) + init_REM_choice.tertius( + effectFun = effectFun, + network = network, attribute = attribute, + window = window, + n1 = n1, n2 = n2 + ) } update_DyNAM_choice_tertius <- function( @@ -2460,8 +2576,9 @@ update_DyNAM_choice_tertius <- function( #' ) #' attribute <- c(1, 0, 1, 3, 1) #' effectFUN <- function(transformFun = abs, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' aggregateFun = function(x) median(x, na.rm = TRUE)) { #' NULL +#' } #' init_DyNAM_choice.tertiusDiff(effectFUN, network, attribute) #' } init_DyNAM_choice.tertiusDiff <- function(effectFun, network, attribute, @@ -2482,15 +2599,19 @@ init_DyNAM_choice.tertiusDiff <- function(effectFun, network, attribute, # always weighted network <- sign(unname(network)) # compute cache[j]: agg_{k \in N^-(j)}(z_k) || NA if N^-(j) == \empty - stat <- 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]) - }) + stat <- 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]) + } + ) stat2 <- forceAndCall(1, funApply, outer(attribute, stat, "-")) # impute missing entries: nodes without inNeighbor, transformFun(differences) @@ -2550,8 +2671,9 @@ init_DyNAM_choice.tertiusDiff <- function(effectFun, network, attribute, #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' transformFun = function(x) x^2, +#' aggregateFun = function(x) median(x, na.rm = TRUE) +#' ) #' #' update_DyNAM_choice_tertiusDiff( #' network, attribute, @@ -2560,8 +2682,9 @@ init_DyNAM_choice.tertiusDiff <- function(effectFun, network, attribute, #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' transformFun = function(x) x^2, +#' aggregateFun = function(x) median(x, na.rm = TRUE) +#' ) #' } update_DyNAM_choice_tertiusDiff <- function( network, @@ -2614,7 +2737,8 @@ update_DyNAM_choice_tertiusDiff <- function( valChangeCache <- forceAndCall( 1, aggregateFun, - if (length(inReceiver) > 0) attribute[inReceiver] else NA) + 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) @@ -2642,14 +2766,16 @@ update_DyNAM_choice_tertiusDiff <- function( 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)) + 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: it's an update value for node, # then its update is done separately @@ -2662,7 +2788,8 @@ update_DyNAM_choice_tertiusDiff <- function( replace = forceAndCall( 1, transformFun, - (if (isTwoMode) replace else replace[-node]) - cache[isNotMissCache]) + (if (isTwoMode) replace else replace[-node]) - cache[isNotMissCache] + ) ) } changes <- rbind( @@ -2678,7 +2805,8 @@ update_DyNAM_choice_tertiusDiff <- function( replace = forceAndCall( 1, transformFun, - (if (isTwoMode) attribute else attribute[-x]) - cache[x]) + (if (isTwoMode) attribute else attribute[-x]) - cache[x] + ) ) } ) @@ -2692,8 +2820,10 @@ update_DyNAM_choice_tertiusDiff <- function( diag(toImpute) <- FALSE } imputeVal <- mean(changes[, "replace"], na.rm = TRUE) - changes <- rbind(changes, - cbind(which(toImpute, arr.ind = TRUE), imputeVal)) + changes <- rbind( + changes, + cbind(which(toImpute, arr.ind = TRUE), imputeVal) + ) } else if (isImpute) { stat <- forceAndCall(1, transformFun, outer(attribute, cache, "-")) toImpute <- is.na(stat) @@ -2704,8 +2834,10 @@ update_DyNAM_choice_tertiusDiff <- function( } imputeVal <- mean(stat, na.rm = TRUE) if (any(toImpute)) { - changes <- rbind(changes, - cbind(which(toImpute, arr.ind = TRUE), imputeVal)) + changes <- rbind( + changes, + cbind(which(toImpute, arr.ind = TRUE), imputeVal) + ) } } return(list(cache = cache, changes = changes)) @@ -2761,10 +2893,12 @@ init_DyNAM_choice.same <- function(effectFun, attribute) { # Get arguments params <- formals(effectFun) isTwoMode <- eval(params[["isTwoMode"]]) - if (isTwoMode) + if (isTwoMode) { stop("effect", dQuote("same"), - "doesn't work in two mode networks ('isTwoMode = TRUE')", - call. = FALSE) + "doesn't work in two mode networks ('isTwoMode = TRUE')", + call. = FALSE + ) + } stat <- 1 * outer(attribute, attribute, "==") diag(stat) <- 0 return(list(stat = stat)) @@ -2821,15 +2955,17 @@ init_DyNAM_choice.diff <- function(effectFun, attribute) { params <- formals(effectFun) isTwoMode <- eval(params[["isTwoMode"]]) funApply <- eval(params[["transformFun"]]) # applied FUN instead - if (isTwoMode) + if (isTwoMode) { stop("effect", dQuote("diff"), - "doesn't work in two mode networks ('isTwoMode = TRUE')", - call. = FALSE - ) + "doesn't work in two mode networks ('isTwoMode = TRUE')", + call. = FALSE + ) + } return(list(stat = forceAndCall( 1, funApply, - outer(attribute, attribute, "-")))) + outer(attribute, attribute, "-") + ))) } #' @aliases diff @@ -2871,12 +3007,14 @@ init_DyNAM_choice.sim <- function(effectFun, attribute) { params <- formals(effectFun) isTwoMode <- eval(params[["isTwoMode"]]) funApply <- eval(params[["transformFun"]]) # applied FUN instead - if (isTwoMode) + if (isTwoMode) { stop("effect", dQuote("sim"), - "doesn't work in two mode networks ('isTwoMode = TRUE')", - call. = FALSE) + "doesn't work in two mode networks ('isTwoMode = TRUE')", + call. = FALSE + ) + } return(list(stat = (-1) * - forceAndCall(1, funApply, outer(attribute, attribute, "-")))) + forceAndCall(1, funApply, outer(attribute, attribute, "-")))) } #' @aliases sim @@ -2902,12 +3040,15 @@ init_DyNAM_choice.egoAlterInt <- function(effectFun, attribute) { params <- formals(effectFun) isTwoMode <- eval(params[["isTwoMode"]]) funApply <- eval(params[["transformFun"]]) # applied FUN instead - if (isTwoMode) + if (isTwoMode) { stop("effect", dQuote("diff"), - "doesn't work in two mode networks ('isTwoMode = TRUE')", - call. = FALSE) - if (length(attribute) != 2) + "doesn't work in two mode networks ('isTwoMode = TRUE')", + call. = FALSE + ) + } + if (length(attribute) != 2) { stop("Interaction ego alter is just define for two attributes") + } attr1 <- attribute[[1]] attr2 <- attribute[[2]] @@ -2923,9 +3064,9 @@ update_DyNAM_choice_egoAlterInt <- function( n1, n2, isTwoMode = FALSE, transformFun = identity) { - - if (length(attribute) != 2) + if (length(attribute) != 2) { stop("Interaction ego alter is just define for two attributes") + } attr1 <- attribute[[1]] attr2 <- attribute[[2]] diff --git a/R/functions_effects_DyNAM_choice_coordination.R b/R/functions_effects_DyNAM_choice_coordination.R index dc2f684..366f3d2 100644 --- a/R/functions_effects_DyNAM_choice_coordination.R +++ b/R/functions_effects_DyNAM_choice_coordination.R @@ -1,7 +1,7 @@ # define methods ---------------------------------------------------------- # init the statistical matrix init_DyNAM_choice_coordination <- function( - effectFun, network, attribute, n1, n2, cache = NULL) { + effectFun, network, attribute, n1, n2, cache = NULL) { UseMethod("init_DyNAM_choice", effectFun) } @@ -9,9 +9,9 @@ init_DyNAM_choice_coordination <- function( # tie --------------------------------------------------------------------- update_DyNAM_choice_coordination_tie <- function( - network, - sender, receiver, replace, - weighted = FALSE, transformFun = identity) { + network, + sender, receiver, replace, + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, @@ -21,9 +21,9 @@ update_DyNAM_choice_coordination_tie <- function( # inertia ----------------------------------------------------------------- update_DyNAM_choice_coordination_inertia <- function( - network, - sender, receiver, replace, - weighted = FALSE, transformFun = identity) { + network, + sender, receiver, replace, + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_coordination_tie( network = network, sender = sender, receiver = receiver, replace = replace, @@ -33,10 +33,10 @@ update_DyNAM_choice_coordination_inertia <- function( # indeg ------------------------------------------------------------------- update_DyNAM_choice_coordination_indeg <- function( - network, - sender, receiver, replace, cache, - n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity) { + network, + sender, receiver, replace, cache, + n1, n2, isTwoMode = FALSE, + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -61,12 +61,12 @@ update_DyNAM_choice_coordination_indeg <- function( # trans ------------------------------------------------------------------- update_DyNAM_choice_coordination_trans <- function( - network, - sender, - receiver, - replace, cache, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, + receiver, + replace, cache, + isTwoMode = FALSE, + transformFun = identity) { update_DyNAM_choice_trans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -76,12 +76,12 @@ update_DyNAM_choice_coordination_trans <- function( # mixedTrans -------------------------------------------------------------- update_DyNAM_choice_coordination_mixedTrans <- function( - network, - sender, - receiver, - replace, netUpdate, cache, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, + receiver, + replace, netUpdate, cache, + isTwoMode = FALSE, + transformFun = identity) { update_DyNAM_choice_mixedTrans( network = network, sender = sender, receiver = receiver, replace = replace, @@ -92,11 +92,11 @@ update_DyNAM_choice_coordination_mixedTrans <- function( # four -------------------------------------------------------------------- update_DyNAM_choice_coordination_four <- function( - network, - sender, receiver, replace, - cache, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, receiver, replace, + cache, + isTwoMode = FALSE, + transformFun = identity) { update_DyNAM_choice_four( network = network, sender = sender, receiver = receiver, replace = replace, @@ -176,8 +176,9 @@ update_DyNAM_choice_coordination_tertius <- function( #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' transformFun = function(x) x^2, +#' aggregateFun = function(x) median(x, na.rm = TRUE) +#' ) #' #' update_DyNAM_choice_coordination_tertiusDiff( #' network, attribute, @@ -186,59 +187,62 @@ update_DyNAM_choice_coordination_tertius <- function( #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' transformFun = function(x) x^2, +#' aggregateFun = function(x) median(x, na.rm = TRUE) +#' ) #' } update_DyNAM_choice_coordination_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) + 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 ------------------------------------------------------------------ update_DyNAM_choice_coordination_nodeTrans <- function( - network, - sender, - receiver, - replace, - cache, - n1, n2, - isTwoMode = FALSE, - transformFun = identity) { + network, + sender, + receiver, + replace, + cache, + n1, n2, + isTwoMode = FALSE, + transformFun = identity) { update_DyNAM_choice_nodeTrans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, n1 = n1, n2 = n2, isTwoMode = isTwoMode, - transformFun = transformFun) + transformFun = transformFun + ) } # Covariate effects ------------------------------------------------------- # alter ------------------------------------------------------------------- update_DyNAM_choice_coordination_alter <- function( - attribute, - node, replace, - n1, n2, - isTwoMode = FALSE) { + attribute, + node, replace, + n1, n2, + isTwoMode = FALSE) { update_DyNAM_choice_alter( attribute = attribute, node = node, replace = replace, @@ -249,9 +253,9 @@ update_DyNAM_choice_coordination_alter <- function( # same -------------------------------------------------------------------- update_DyNAM_choice_coordination_same <- function( - attribute, - node, replace, - isTwoMode = FALSE) { + attribute, + node, replace, + isTwoMode = FALSE) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, @@ -261,10 +265,10 @@ update_DyNAM_choice_coordination_same <- function( # diff -------------------------------------------------------------------- update_DyNAM_choice_coordination_diff <- function( - attribute, node, replace, - n1, n2, - isTwoMode = FALSE, - transformFun = abs) { + attribute, node, replace, + n1, n2, + isTwoMode = FALSE, + transformFun = abs) { update_DyNAM_choice_diff( attribute = attribute, node = node, replace = replace, @@ -276,10 +280,10 @@ update_DyNAM_choice_coordination_diff <- function( # sim --------------------------------------------------------------------- update_DyNAM_choice_coordination_sim <- function( - attribute, node, replace, - n1, n2, - isTwoMode = FALSE, - transformFun = abs) { + attribute, node, replace, + n1, n2, + isTwoMode = FALSE, + transformFun = abs) { update_DyNAM_choice_sim( attribute = attribute, node = node, replace = replace, diff --git a/R/functions_effects_DyNAM_rate.R b/R/functions_effects_DyNAM_rate.R index 6759781..3eed22e 100644 --- a/R/functions_effects_DyNAM_rate.R +++ b/R/functions_effects_DyNAM_rate.R @@ -1,8 +1,7 @@ # define methods ---------------------------------------------------------- # init the statistical matrix init_DyNAM_rate <- function( - effectFun, network, attribute, n1, n2, cache = NULL - ) { + effectFun, network, attribute, n1, n2, cache = NULL) { UseMethod("init_DyNAM_rate", effectFun) } @@ -11,8 +10,7 @@ init_DyNAM_rate.default <- function( effectFun, network = NULL, attribute = NULL, window, - n1, n2 -) { + n1, n2) { init_DyNAM_choice.default( effectFun = effectFun, network = network, attribute = attribute, @@ -49,9 +47,9 @@ init_DyNAM_rate.default <- function( #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity -#' ) +#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) { #' NULL +#' } #' init_REM_choice.indeg(effectFUN, network, 5, 6) #' network <- matrix( #' c( @@ -64,23 +62,25 @@ init_DyNAM_rate.default <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity -#' ) +#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity) { #' NULL +#' } #' init_DyNAM_rate.indeg(effectFUN, network, NULL, 5, 5) #' #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity, -#' type = "alter" -#' ) +#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity, +#' type = "alter") { #' NULL +#' } #' init_DyNAM_rate.indeg(effectFUN, network, NULL, 5, 5) #' } init_DyNAM_rate.indeg <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) - init_REM_choice.indeg(effectFun = effectFun, network = network, - window = window, - n1 = n1, n2 = n2) + init_REM_choice.indeg( + effectFun = effectFun, network = network, + window = window, + n1 = n1, n2 = n2 + ) } #' update stat indegree using cache ego @@ -125,8 +125,7 @@ update_DyNAM_rate_indeg <- function( network, sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity -) { + weighted = FALSE, transformFun = identity) { update_REM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -138,9 +137,11 @@ update_DyNAM_rate_indeg <- function( # outdeg --------------------------------------------------------------- init_DyNAM_rate.outdeg <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) - init_REM_choice.outdeg(effectFun = effectFun, network = network, - window = window, - n1 = n1, n2 = n2) + init_REM_choice.outdeg( + effectFun = effectFun, network = network, + window = window, + n1 = n1, n2 = n2 + ) } @@ -148,8 +149,7 @@ update_DyNAM_rate_outdeg <- function( network, sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity -) { + weighted = FALSE, transformFun = identity) { update_REM_choice_outdeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -163,7 +163,8 @@ init_DyNAM_rate.nodeTrans <- function(effectFun, network, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) init_REM_choice.nodeTrans( effectFun = effectFun, network = network, - window = window, n1 = n1, n2 = n2) + window = window, n1 = n1, n2 = n2 + ) } update_DyNAM_rate_nodeTrans <- function( @@ -174,8 +175,7 @@ update_DyNAM_rate_nodeTrans <- function( cache, n1, n2, isTwoMode = FALSE, - transformFun = identity -) { + transformFun = identity) { update_REM_choice_nodeTrans( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -185,8 +185,7 @@ update_DyNAM_rate_nodeTrans <- function( } # tertius ---------------------------------------------------------------- init_DyNAM_rate.tertius <- function( - effectFun, network, attribute, window, n1, n2 - ) { + effectFun, network, attribute, window, n1, n2) { formals(effectFun) <- c(formals(effectFun), list(type = "ego")) init_REM_choice.tertius( effectFun = effectFun, network = network, attribute = attribute, @@ -206,8 +205,7 @@ update_DyNAM_rate_tertius <- function( isTwoMode = FALSE, n1 = n1, n2 = n2, transformFun = identity, - aggregateFun = function(x) mean(x, na.rm = TRUE) -) { + aggregateFun = function(x) mean(x, na.rm = TRUE)) { update_REM_choice_tertius( network = network, attribute = attribute, @@ -226,16 +224,17 @@ update_DyNAM_rate_tertius <- function( # Covariate effects ------------------------------------------------------- # ego --------------------------------------------------------------------- init_DyNAM_rate.ego <- function(effectFun, attribute, n1, n2) { - init_REM_choice.ego(effectFun = effectFun, attribute = attribute, - n1 = n1, n2 = n2) + init_REM_choice.ego( + effectFun = effectFun, attribute = attribute, + n1 = n1, n2 = n2 + ) } update_DyNAM_rate_ego <- function( attribute, node, replace, n1, n2, - isTwoMode = FALSE -) { + isTwoMode = FALSE) { update_REM_choice_ego( attribute = attribute, node = node, replace = replace, diff --git a/R/functions_effects_DyNAMi_choice.R b/R/functions_effects_DyNAMi_choice.R index 0dc0200..7df5b4b 100644 --- a/R/functions_effects_DyNAMi_choice.R +++ b/R/functions_effects_DyNAMi_choice.R @@ -6,14 +6,13 @@ init_DyNAMi_choice <- function(effectFun, network, attribute) { # default ----------------------------------------------------------------- -#init_DyNAMi_choice.default <- function(effectFun, network, attribute) +# init_DyNAMi_choice.default <- function(effectFun, network, attribute) # NULL # # effect without cache object init_DyNAMi_choice.default <- function(effectFun, network = NULL, attribute = NULL, groupsNetwork, window, n1, n2) { - # print(match.call()) if (is.null(network) && is.null(attribute)) { # this check could be unnecessary @@ -26,9 +25,9 @@ init_DyNAMi_choice.default <- function(effectFun, # if multiple networks, attributes or combination of both are specified. # The initialization is done over the fist network # lenNetwork <- length(network) - hasNetwork <- length(network) >= 1 - hasMultNets <- length(network) >= 1 & is.list(network) - hasMultAtt <- length(attribute) >= 1 & is.list(attribute) + hasNetwork <- length(network) >= 1 + hasMultNets <- length(network) >= 1 & is.list(network) + hasMultAtt <- length(attribute) >= 1 & is.list(attribute) .argsNames <- names(formals(effectFun)) # if network inputs, just the first network is empty. @@ -49,7 +48,7 @@ init_DyNAMi_choice.default <- function(effectFun, netIter <- network[[1]] } else { if ((!is.null(window) && !is.infinite(window)) || - all(network[!is.na(network)] == 0)) { + all(network[!is.na(network)] == 0)) { return(stats) } netIter <- network @@ -111,8 +110,9 @@ init_DyNAMi_choice.default <- function(effectFun, } # update networks # hack: if it's not the same dimension, the network shouldn't be updated - if (dim(netIter)[1] == n1 && dim(netIter)[2] == n2) + if (dim(netIter)[1] == n1 && dim(netIter)[2] == n2) { emptyObject[i, j] <- netIter[i, j] + } } } } else { @@ -162,14 +162,11 @@ update_DyNAMi_choice_tie <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "proportion" -) { - + weighted = FALSE, subType = "proportion") { reptotal <- NULL for (i in seq.int(n1)) { for (j in seq.int(n2)) { - members <- which(groupsNetwork[, j] == 1) nmembers <- length(members) @@ -183,8 +180,9 @@ update_DyNAMi_choice_tie <- function( smembers <- members[members != i] snmembers <- length(smembers) if (snmembers == 0) { - if (statistics[i, j] != 0) + if (statistics[i, j] != 0) { reptotal <- rbind(reptotal, cbind(node1 = i, node2 = j, replace = 0)) + } next } @@ -225,14 +223,11 @@ update_DyNAMi_choice_inertia <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "proportion" -) { - + weighted = FALSE, subType = "proportion") { reptotal <- NULL for (i in seq.int(n1)) { for (j in seq.int(n2)) { - members <- which(groupsNetwork[, j] == 1) nmembers <- length(members) @@ -292,9 +287,7 @@ update_DyNAMi_choice_alterdeg <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "mean" -) { - + weighted = FALSE, subType = "mean") { reptotal <- NULL meandeg <- mean(rowSums(network)) sddeg <- sd(rowSums(network)) @@ -327,8 +320,11 @@ update_DyNAMi_choice_alterdeg <- function( rep <- sum(network[smembers, ]) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) - rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) { + rep <- (sum(network[smembers, ]) - meandeg) / sddeg + } else { + rep <- 0 + } } if (subType == "min") { rep <- sum(network[smembers, ]) @@ -344,9 +340,11 @@ update_DyNAMi_choice_alterdeg <- function( rep <- mean(rowSums(network[smembers, ])) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) + if (sddeg > 0) { rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg - else rep <- 0 + } else { + rep <- 0 + } } if (subType == "min") { rep <- min(rowSums(network[smembers, ])) @@ -359,9 +357,7 @@ update_DyNAMi_choice_alterdeg <- function( if (statistics[i, j] != rep) { reptotal <- rbind(reptotal, cbind(node1 = i, node2 = j, replace = rep)) } - } - } return(reptotal) @@ -376,8 +372,7 @@ update_DyNAMi_choice_alterpop <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "mean_normalized" -) { + weighted = FALSE, subType = "mean_normalized") { update_DyNAMi_choice_alterdeg( network = network, groupsNetwork = groupsNetwork, @@ -396,9 +391,7 @@ update_DyNAMi_choice_size <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "identity" -) { - + weighted = FALSE, subType = "identity") { reptotal <- NULL for (i in seq.int(n1)) { @@ -440,9 +433,7 @@ update_DyNAMi_choice_dyad <- function( groupsNetwork, sender, receiver, replace, n1, n2, statistics, - weighted = FALSE, subType = "identity" -) { - + weighted = FALSE, subType = "identity") { reptotal <- NULL for (i in seq.int(n1)) { @@ -485,9 +476,7 @@ update_DyNAMi_choice_alter <- function( sender, receiver, replace, n1, n2, statistics, subType = "mean", - node = 0 -) { - + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -525,8 +514,11 @@ update_DyNAMi_choice_alter <- function( rep <- (mean(attribute[smembers]) - meanatt)^2 } if (subType == "mean_normalized") { - if (sdatt > 0) rep <- (mean(attribute[smembers]) - meanatt) / sdatt - else rep <- 0 + if (sdatt > 0) { + rep <- (mean(attribute[smembers]) - meanatt) / sdatt + } else { + rep <- 0 + } } if (subType == "min") { rep <- min(attribute[smembers]) @@ -574,8 +566,7 @@ update_DyNAMi_choice_same <- function( sender, receiver, replace, n1, n2, statistics, subType = "proportion", - node = 0 -) { + node = 0) { reptotal <- NULL for (i in seq.int(n1)) { @@ -626,8 +617,7 @@ update_DyNAMi_choice_diff <- function( sender, receiver, replace, n1, n2, statistics, subType = "averaged_sum", - node = 0 -) { + node = 0) { reptotal <- NULL for (i in seq.int(n1)) { @@ -691,8 +681,7 @@ update_DyNAMi_choice_sim <- function( sender, receiver, replace, n1, n2, statistics, subType = "averaged_sum", - node = 0 -) { + node = 0) { reptotal <- NULL for (i in seq.int(n1)) { @@ -748,8 +737,7 @@ update_DyNAMi_choice_sizeXdiff <- function( sender, receiver, replace, n1, n2, statistics, subType = "averaged_sum", - node = 0 -) { + node = 0) { reptotal <- NULL for (i in seq.int(n1)) { @@ -805,8 +793,7 @@ update_DyNAMi_choice_dyadXdiff <- function( sender, receiver, replace, n1, n2, statistics, subType = "averaged_sum", - node = 0 -) { + node = 0) { reptotal <- NULL for (i in seq.int(n1)) { @@ -866,8 +853,7 @@ update_DyNAMi_choice_sizeXego <- function( sender, receiver, replace, n1, n2, statistics, subType = "identity", - node = 0 -) { + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -902,8 +888,11 @@ update_DyNAMi_choice_sizeXego <- function( rep <- snmembers * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) rep <- snmembers * (attribute[i] - meanatt) / sdatt - else rep <- 0 + if (sdatt > 0) { + rep <- snmembers * (attribute[i] - meanatt) / sdatt + } else { + rep <- 0 + } } if (statistics[i, j] != rep) { @@ -923,8 +912,7 @@ update_DyNAMi_choice_dyadXego <- function( sender, receiver, replace, n1, n2, statistics, subType = "identity", - node = 0 -) { + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) diff --git a/R/functions_effects_DyNAMi_rate.R b/R/functions_effects_DyNAMi_rate.R index 076bba4..7d83c6b 100644 --- a/R/functions_effects_DyNAMi_rate.R +++ b/R/functions_effects_DyNAMi_rate.R @@ -9,8 +9,7 @@ init_DyNAMi_rate.default <- function( effectFun, network = NULL, attribute = NULL, groupsNetwork, window, - n1, n2 -) { + n1, n2) { init_DyNAMi_choice.default( effectFun = effectFun, network = network, attribute = attribute, @@ -29,19 +28,17 @@ update_DyNAMi_rate_intercept <- function( sender, receiver, replace, n1, n2, statistics, weighted = FALSE, - joining = 1 -) { - + joining = 1) { reptotal <- NULL # JOINING RATE if (joining == 1) { - for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 1) { @@ -64,12 +61,12 @@ update_DyNAMi_rate_intercept <- function( # LEAVING RATE if (joining == -1) { - for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (isingroup) { if (statistics[i, 1] != 1) { @@ -103,8 +100,7 @@ update_DyNAMi_rate_inertia <- function( sender, receiver, replace, n1, n2, statistics, weighted = TRUE, subType = "proportion", - joining = -1 -) { + joining = -1) { update_DyNAMi_rate_tie( network = network, groupsNetwork = groupsNetwork, @@ -124,9 +120,7 @@ update_DyNAMi_rate_tie <- function( sender, receiver, replace, n1, n2, statistics, weighted = FALSE, subType = "proportion", - joining = -1 -) { - + joining = -1) { reptotal <- NULL # LEAVING MODEL @@ -134,8 +128,9 @@ update_DyNAMi_rate_tie <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -192,9 +187,7 @@ update_DyNAMi_rate_egodeg <- function( sender, receiver, replace, n1, n2, statistics, weighted = TRUE, subType = "identity", - joining = 1 -) { - + joining = 1) { reptotal <- NULL meandeg <- mean(rowSums(network)) sddeg <- sd(rowSums(network)) @@ -204,10 +197,11 @@ update_DyNAMi_rate_egodeg <- function( reptotal <- NULL for (i in seq.int(n1)) { - owngroup <- which(groupsNetwork[i,] == 1) + owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (subType == "identity") { @@ -217,8 +211,11 @@ update_DyNAMi_rate_egodeg <- function( rep <- sum(network[i, ]) - meandeg } if (subType == "normalized") { - if (sddeg > 0) - rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) { + rep <- (sum(network[i, ]) - meandeg) / sddeg + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { @@ -246,8 +243,9 @@ update_DyNAMi_rate_egodeg <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (isingroup) { if (subType == "identity") { @@ -257,8 +255,11 @@ update_DyNAMi_rate_egodeg <- function( rep <- sum(network[i, ]) - meandeg } if (subType == "normalized") { - if (sddeg > 0) - rep <- (sum(network[i, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) { + rep <- (sum(network[i, ]) - meandeg) / sddeg + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { @@ -292,8 +293,7 @@ update_DyNAMi_rate_egopop <- function( sender, receiver, replace, n1, n2, statistics, weighted = TRUE, subType = "normalized", - joining = 1 -) { + joining = 1) { update_DyNAMi_rate_egodeg( network = network, groupsNetwork = groupsNetwork, @@ -313,9 +313,7 @@ update_DyNAMi_rate_alterdeg <- function( sender, receiver, replace, n1, n2, statistics, weighted = TRUE, subType = "mean", - joining = -1 -) { - + joining = -1) { reptotal <- NULL meandeg <- mean(rowSums(network)) maxdeg <- max(rowSums(network)) @@ -323,14 +321,14 @@ update_DyNAMi_rate_alterdeg <- function( # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -355,8 +353,11 @@ update_DyNAMi_rate_alterdeg <- function( rep <- sum(network[smembers, ]) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) - rep <- (sum(network[smembers, ]) - meandeg) / sddeg else rep <- 0 + if (sddeg > 0) { + rep <- (sum(network[smembers, ]) - meandeg) / sddeg + } else { + rep <- 0 + } } if (subType == "min") { rep <- sum(network[smembers, ]) @@ -372,9 +373,11 @@ update_DyNAMi_rate_alterdeg <- function( rep <- mean(rowSums(network[smembers, ])) - meandeg } if (subType == "mean_normalized") { - if (sddeg > 0) + if (sddeg > 0) { rep <- (mean(rowSums(network[smembers, ])) - meandeg) / sddeg - else rep <- 0 + } else { + rep <- 0 + } } if (subType == "min") { rep <- min(rowSums(network[smembers, ])) / maxdeg @@ -391,7 +394,6 @@ update_DyNAMi_rate_alterdeg <- function( ) } } - } return(reptotal) @@ -406,8 +408,7 @@ update_DyNAMi_rate_alterpop <- function( sender, receiver, replace, n1, n2, statistics, weighted = TRUE, subType = "mean_normalized", - joining = -1 -) { + joining = -1) { update_DyNAMi_rate_alterdeg( network = network, groupsNetwork = groupsNetwork, @@ -427,21 +428,19 @@ update_DyNAMi_rate_size <- function( sender, receiver, replace, n1, n2, statistics, weighted = FALSE, subType = "identity", - joining = -1 -) { - + joining = -1) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -473,7 +472,6 @@ update_DyNAMi_rate_size <- function( ) } } - } return(reptotal) @@ -489,21 +487,19 @@ update_DyNAMi_rate_dyad <- function( sender, receiver, replace, n1, n2, statistics, weighted = FALSE, subType = "identity", - joining = -1 -) { - + joining = -1) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -533,7 +529,6 @@ update_DyNAMi_rate_dyad <- function( ) } } - } return(reptotal) @@ -553,9 +548,7 @@ update_DyNAMi_rate_ego <- function( n1, n2, statistics, subType = "identity", joining = 1, - node = 0 -) { - + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -567,8 +560,9 @@ update_DyNAMi_rate_ego <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (subType == "identity") { @@ -581,8 +575,11 @@ update_DyNAMi_rate_ego <- function( rep <- attribute[i] - meanatt } if (subType == "normalized") { - if (sdatt > 0) - rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) { + rep <- (attribute[i] - meanatt) / sdatt + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { @@ -601,7 +598,6 @@ update_DyNAMi_rate_ego <- function( } } } - } # LEAVING RATE @@ -611,8 +607,9 @@ update_DyNAMi_rate_ego <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (isingroup) { if (subType == "identity") { @@ -625,8 +622,11 @@ update_DyNAMi_rate_ego <- function( rep <- attribute[i] - meanatt } if (subType == "normalized") { - if (sdatt > 0) - rep <- (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) { + rep <- (attribute[i] - meanatt) / sdatt + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { @@ -645,7 +645,6 @@ update_DyNAMi_rate_ego <- function( } } } - } return(reptotal) @@ -661,23 +660,21 @@ update_DyNAMi_rate_alter <- function( n1, n2, statistics, subType = "mean", joining = -1, - node = 0 -) { - + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -707,8 +704,11 @@ update_DyNAMi_rate_alter <- function( rep <- (mean(attribute[smembers]) - meanatt)^2 } if (subType == "mean_normalized") { - if (sdatt > 0) - rep <- (mean(attribute[smembers]) - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) { + rep <- (mean(attribute[smembers]) - meanatt) / sdatt + } else { + rep <- 0 + } } if (subType == "min") { rep <- min(attribute[smembers]) @@ -745,11 +745,9 @@ update_DyNAMi_rate_alter <- function( ) } } - } return(reptotal) - } # same -------------------------------------------------------------------- @@ -762,20 +760,19 @@ update_DyNAMi_rate_same <- function( n1, n2, statistics, subType = "proportion", joining = -1, - node = 0 -) { + node = 0) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -809,7 +806,6 @@ update_DyNAMi_rate_same <- function( ) } } - } return(reptotal) @@ -825,20 +821,19 @@ update_DyNAMi_rate_diff <- function( n1, n2, statistics, subType = "averaged_sum", joining = -1, - node = 0 -) { + node = 0) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -884,7 +879,6 @@ update_DyNAMi_rate_diff <- function( ) } } - } return(reptotal) @@ -901,20 +895,19 @@ update_DyNAMi_rate_sim <- function( n1, n2, statistics, subType = "averaged_sum", joining = -1, - node = 0 -) { + node = 0) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -951,7 +944,6 @@ update_DyNAMi_rate_sim <- function( ) } } - } return(reptotal) @@ -970,20 +962,19 @@ update_DyNAMi_rate_sizeXdiff <- function( n1, n2, statistics, subType = "averaged_sum", joining = -1, - node = 0 -) { + node = 0) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -1021,7 +1012,6 @@ update_DyNAMi_rate_sizeXdiff <- function( ) } } - } return(reptotal) @@ -1038,20 +1028,19 @@ update_DyNAMi_rate_dyadXdiff <- function( n1, n2, statistics, subType = "averaged_sum", joining = -1, - node = 0 -) { + node = 0) { reptotal <- NULL # LEAVING MODEL if (joining == -1) { - reptotal <- NULL for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } if (!isingroup) { if (statistics[i, 1] != 0) { @@ -1094,7 +1083,6 @@ update_DyNAMi_rate_dyadXdiff <- function( ) } } - } return(reptotal) @@ -1110,9 +1098,7 @@ update_DyNAMi_rate_sizeXego <- function( n1, n2, statistics, subType = "identity", joining = -1, - node = 0 -) { - + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -1124,8 +1110,9 @@ update_DyNAMi_rate_sizeXego <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } members <- which(groupsNetwork[, owngroup] == 1) nmembers <- length(members) @@ -1143,8 +1130,11 @@ update_DyNAMi_rate_sizeXego <- function( rep <- nmembers * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) - rep <- nmembers * (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) { + rep <- nmembers * (attribute[i] - meanatt) / sdatt + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { @@ -1179,9 +1169,7 @@ update_DyNAMi_rate_dyadXego <- function( n1, n2, statistics, subType = "identity", joining = -1, - node = 0 -) { - + node = 0) { reptotal <- NULL meanatt <- mean(attribute) sdatt <- sd(attribute) @@ -1193,8 +1181,9 @@ update_DyNAMi_rate_dyadXego <- function( for (i in seq.int(n1)) { owngroup <- which(groupsNetwork[i, ] == 1) isingroup <- FALSE - if (length(owngroup) == 1) + if (length(owngroup) == 1) { isingroup <- length(which(groupsNetwork[, owngroup] == 1)) > 1 + } members <- which(groupsNetwork[, owngroup] == 1) nmembers <- length(members) @@ -1218,8 +1207,11 @@ update_DyNAMi_rate_dyadXego <- function( rep <- m * (attribute[i] - meanatt) } if (subType == "normalized") { - if (sdatt > 0) - rep <- m * (attribute[i] - meanatt) / sdatt else rep <- 0 + if (sdatt > 0) { + rep <- m * (attribute[i] - meanatt) / sdatt + } else { + rep <- 0 + } } if (statistics[i, 1] != rep) { diff --git a/R/functions_effects_REM.R b/R/functions_effects_REM.R index 4edfb22..e7cf025 100644 --- a/R/functions_effects_REM.R +++ b/R/functions_effects_REM.R @@ -1,8 +1,7 @@ # define methods ---------------------------------------------------------- # init the statistical matrix init_REM_choice <- function( - effectFun, network, attribute, n1, n2, cache = NULL -) { + effectFun, network, attribute, n1, n2, cache = NULL) { UseMethod("init_REM_choice", effectFun) } @@ -16,14 +15,17 @@ init_REM_choice.default <- function( effectFun = effectFun, network = network, attribute = attribute, window = window, - n1 = n1, n2 = n2) + 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) + init_DyNAM_choice.tie( + effectFun = effectFun, network = network, + window = window, n1 = n1, n2 = n2 + ) } update_REM_choice_tie <- function( @@ -39,8 +41,10 @@ update_REM_choice_tie <- function( # 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) + init_REM_choice.tie( + effectFun = effectFun, network = network, + window = window, n1 = n1, n2 = n2 + ) } update_REM_choice_inertia <- function( @@ -59,7 +63,8 @@ init_REM_choice.recip <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.recip( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_recip <- function( @@ -104,8 +109,9 @@ update_REM_choice_recip <- function( #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) +#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) { #' NULL +#' } #' init_REM_choice.indeg(effectFUN, network, NULL, 5, 6) #' network <- matrix( #' c( @@ -118,15 +124,17 @@ update_REM_choice_recip <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity, -#' type = "ego") +#' 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") +#' 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) { @@ -139,20 +147,23 @@ init_REM_choice.indeg <- function(effectFun, network, window, n1, n2) { 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) + "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) + na.rm = TRUE + ) # applied transformFun instead stat <- forceAndCall(1, funApply, cache) @@ -203,13 +214,15 @@ init_REM_choice.indeg <- function(effectFun, network, window, n1, n2) { #' network, #' 1, 2, 3, #' cache, 5, 6, -#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "ego") +#' 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") +#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "al" +#' ) #' } update_REM_choice_indeg <- function( network, @@ -244,8 +257,11 @@ update_REM_choice_indeg <- function( if (type == "alter") { # when the cache had change - if (isTwoMode) other <- seq_len(n1) else - other <- setdiff(seq_len(n1), receiver) + if (isTwoMode) { + other <- seq_len(n1) + } else { + other <- setdiff(seq_len(n1), receiver) + } changes <- cbind( node1 = other, @@ -254,8 +270,11 @@ update_REM_choice_indeg <- function( ) } else if (type == "ego") { # when the cache had change - if (isTwoMode) other <- seq_len(n2) else - other <- setdiff(seq_len(n2), receiver) + if (isTwoMode) { + other <- seq_len(n2) + } else { + other <- setdiff(seq_len(n2), receiver) + } changes <- cbind( node1 = receiver, @@ -294,8 +313,9 @@ update_REM_choice_indeg <- function( #' nrow = 5, ncol = 6, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) +#' weighted = TRUE, isTwoMode = TRUE, transformFun = identity) { #' NULL +#' } #' init_REM_choice.outdeg(effectFUN, network, NULL, 5, 6) #' network <- matrix( #' c( @@ -308,15 +328,17 @@ update_REM_choice_indeg <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' effectFUN <- function( -#' weighted = TRUE, isTwoMode = FALSE, transformFun = identity, -#' type = "ego") +#' 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") +#' 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) { @@ -331,7 +353,9 @@ init_REM_choice.outdeg <- function(effectFun, network, window, n1, n2) { stop( dQuote("outdeg"), "effect must not use for type 'alter' (type = 'alter') when is ", - "a two-mode network (isTwoMode = TRUE) ", call. = FALSE) + "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)) { @@ -342,7 +366,8 @@ init_REM_choice.outdeg <- function(effectFun, network, window, n1, n2) { } # indeg as colsums cache <- .rowSums(if (weighted) network else network > 0, n1, n2, - na.rm = TRUE) + na.rm = TRUE + ) # applied transformFun instead stat <- forceAndCall(1, funApply, cache) @@ -393,13 +418,15 @@ init_REM_choice.outdeg <- function(effectFun, network, window, n1, n2) { #' network, #' 1, 2, 3, #' cache, 5, 6, -#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "ego") +#' 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") +#' isTwoMode = TRUE, weighted = TRUE, transformFun = sqrt, type = "al" +#' ) #' } update_REM_choice_outdeg <- function( network, @@ -435,8 +462,11 @@ update_REM_choice_outdeg <- function( if (type == "alter") { # when the cache had change - if (isTwoMode) other <- seq_len(n1) else + if (isTwoMode) { + other <- seq_len(n1) + } else { other <- setdiff(seq_len(n1), sender) + } changes <- cbind( node1 = other, @@ -445,8 +475,11 @@ update_REM_choice_outdeg <- function( ) } else if (type == "ego") { # when the cache had change - if (isTwoMode) other <- seq_len(n2) else + if (isTwoMode) { + other <- seq_len(n2) + } else { other <- setdiff(seq_len(n2), sender) + } changes <- cbind( node1 = sender, @@ -462,7 +495,8 @@ init_REM_choice.trans <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.trans( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_trans <- function( @@ -485,7 +519,8 @@ init_REM_choice.cycle <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.cycle( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_cycle <- function( @@ -508,7 +543,8 @@ init_REM_choice.commonReceiver <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.commonReceiver( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_commonReceiver <- function( @@ -531,7 +567,8 @@ init_REM_choice.commonSender <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.commonSender( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_commonSender <- function( @@ -554,7 +591,8 @@ init_REM_choice.mixedTrans <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.mixedTrans( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_mixedTrans <- function( @@ -577,7 +615,8 @@ init_REM_choice.mixedCycle <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.mixedCycle( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_mixedCycle <- function( @@ -601,7 +640,8 @@ init_REM_choice.mixedCommonReceiver <- function(effectFun, network, init_DyNAM_choice.mixedCommonReceiver( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_mixedCommonReceiver <- function( @@ -625,7 +665,8 @@ init_REM_choice.mixedCommonSender <- function(effectFun, network, init_DyNAM_choice.mixedCommonSender( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_mixedCommonSender <- function( @@ -648,7 +689,8 @@ init_REM_choice.four <- function(effectFun, network, window, n1, n2) { init_DyNAM_choice.four( effectFun = effectFun, network = network, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } update_REM_choice_four <- function( @@ -696,9 +738,10 @@ update_REM_choice_four <- function( #' ) #' attribute <- c(1, 0, 1, 3, 1) #' effectFUN <- function( -#' type = "alter", isTwoMode = TRUE, -#' transformFun = abs, aggregateFun = function(x) median(x, na.rm = TRUE)) +#' 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, @@ -712,7 +755,9 @@ init_REM_choice.tertius <- function(effectFun, network, attribute, 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) + "a two-mode network (isTwoMode = TRUE) ", + call. = FALSE + ) } # if (anyNA(network)) network[is.na(network)] <- 0 # has window or is empty initialize empty @@ -725,15 +770,19 @@ init_REM_choice.tertius <- function(effectFun, network, attribute, # 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]) - }) + 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 @@ -786,36 +835,38 @@ init_REM_choice.tertius <- function(effectFun, network, attribute, #' 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)) +#' 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)) +#' 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)) { + 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)) { @@ -855,7 +906,8 @@ update_REM_choice_tertius <- function( # change stat valChangeCache <- forceAndCall( 1, aggregateFun, - if (length(inReceiver) > 0) attribute[inReceiver] else NA) + 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() @@ -881,14 +933,16 @@ update_REM_choice_tertius <- function( 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)) + 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 @@ -1001,8 +1055,9 @@ update_REM_choice_tertius <- function( #' ) #' attribute <- c(1, 0, 1, 3, 1) #' effectFUN <- function(transformFun = abs, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' aggregateFun = function(x) median(x, na.rm = TRUE)) { #' NULL +#' } #' init_REM_choice.tertiusDiff(effectFUN, network, attribute) #' } init_REM_choice.tertiusDiff <- function(effectFun, network, attribute, @@ -1011,7 +1066,8 @@ init_REM_choice.tertiusDiff <- function(effectFun, network, attribute, effectFun = effectFun, network = network, attribute = attribute, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) } #' update stat transitivity using cache @@ -1055,8 +1111,9 @@ init_REM_choice.tertiusDiff <- function(effectFun, network, attribute, #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' transformFun = function(x) x^2, +#' aggregateFun = function(x) median(x, na.rm = TRUE) +#' ) #' #' update_REM_choice_tertiusDiff( #' network, attribute, @@ -1065,21 +1122,22 @@ init_REM_choice.tertiusDiff <- function(effectFun, network, attribute, #' 3, #' cache, #' n1 = 5, n2 = 6, -#' transformFun = function(x) x ^ 2, -#' aggregateFun = function(x) median(x, na.rm = TRUE)) +#' 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)) { + 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, @@ -1091,7 +1149,8 @@ update_REM_choice_tertiusDiff <- function( isTwoMode = isTwoMode, n1 = n1, n2 = n2, transformFun = transformFun, - aggregateFun = aggregateFun) + aggregateFun = aggregateFun + ) } # nodeTrans ------------------------------------------------------------------ @@ -1124,23 +1183,27 @@ update_REM_choice_tertiusDiff <- function( #' nrow = 5, ncol = 5, byrow = TRUE #' ) #' effectFUN <- function( -#' isTwoMode = TRUE, transformFun = identity, type = "ego") +#' isTwoMode = TRUE, transformFun = identity, type = "ego") { #' NULL +#' } #' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5) #' #' effectFUN <- function( -#' isTwoMode = FALSE, transformFun = identity, type = "ego") +#' isTwoMode = FALSE, transformFun = identity, type = "ego") { #' NULL +#' } #' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5) #' #' effectFUN <- function( -#' isTwoMode = FALSE, transformFun = identity, type = "alter") +#' isTwoMode = FALSE, transformFun = identity, type = "alter") { #' NULL +#' } #' init_REM_choice.nodeTrans(effectFUN, network, NULL, 5, 5) #' #' effectFUN <- function( -#' isTwoMode = FALSE, transformFun = identity, type = "alter") +#' 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) { @@ -1152,7 +1215,9 @@ init_REM_choice.nodeTrans <- function(effectFun, network, window, n1, n2) { if (isTwoMode) { stop("'nodeTrans' effect must not use ", - "when is a two-mode network (isTwoMode = TRUE)", call. = FALSE) + "when is a two-mode network (isTwoMode = TRUE)", + call. = FALSE + ) } # has window or is empty initialize empty @@ -1167,11 +1232,13 @@ init_REM_choice.nodeTrans <- function(effectFun, network, window, n1, n2) { # 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) + 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") + nrow = n1, ncol = n2, byrow = (type == "alter") ) # if (!isTwoMode) diag(stat) <- 0 @@ -1266,10 +1333,12 @@ update_REM_choice_nodeTrans <- function( replaceValues <- (replace - oldValue) * senderChanges + cache[sender] if (type == "ego") { changes <- cbind( - node1 = sender, node2 = third(n1, sender), replace = replaceValues) + node1 = sender, node2 = third(n1, sender), replace = replaceValues + ) } else { changes <- cbind( - node1 = third(n1, sender), node2 = sender, replace = replaceValues) + node1 = third(n1, sender), node2 = sender, replace = replaceValues + ) } cache[sender] <- replaceValues } @@ -1356,14 +1425,15 @@ update_REM_choice_ego <- function( # alter ------------------------------------------------------------------- init_REM_choice.alter <- function(effectFun, attribute, n1, n2) { init_DyNAM_choice.alter( - effectFun = effectFun, attribute = attribute, n1 = n2, n2 = n2) + effectFun = effectFun, attribute = attribute, n1 = n2, n2 = n2 + ) } update_REM_choice_alter <- function( - attribute, - node, replace, - n1, n2, - isTwoMode = FALSE) { + attribute, + node, replace, + n1, n2, + isTwoMode = FALSE) { update_DyNAM_choice_alter( attribute = attribute, node = node, replace = replace, diff --git a/R/functions_estimation.R b/R/functions_estimation.R index b2e6427..dbc8b32 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -74,12 +74,12 @@ #' \item{initialParameters}{a numeric vector. #' It includes initial parameters of the estimation. #' Default is set to NULL.} -#' \item{fixedParameters}{a numeric vector. It specifies which component of -#' the coefficient parameters (intercept included) is fixed and the value -#' it takes during estimation, e.g., if the vector is `c(2, NA)` then -#' the first component of the parameter is fixed to 2 during the -#' estimation process. Default is set to `NULL`, i.e. all parameters are -#' estimated. Note that it must be consistent with `initialParameters`.} +#' \item{fixedParameters}{a numeric vector. It specifies which component of +#' the coefficient parameters (intercept included) is fixed and the value +#' it takes during estimation, e.g., if the vector is `c(2, NA)` then +#' the first component of the parameter is fixed to 2 during the +#' estimation process. Default is set to `NULL`, i.e. all parameters are +#' estimated. Note that it must be consistent with `initialParameters`.} #' \item{maxIterations}{maximum number of iterations of the Gauss/Fisher #' scoring method for the estimation. Default is set to 20.} #' \item{maxScoreStopCriterion}{maximum absolute score criteria for successful @@ -201,24 +201,30 @@ #' # A multinomial receiver choice model #' 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) +#' callNetwork <- linkEvents( +#' x = callNetwork, changeEvent = calls, +#' nodes = actors +#' ) +#' callsDependent <- defineDependentEvents( +#' events = calls, nodes = actors, +#' defaultNetwork = callNetwork +#' ) #' #' \dontshow{ #' callsDependent <- callsDependent[1:50, ] #' } #' #' mod01 <- estimate(callsDependent ~ inertia + recip + trans, -#' model = "DyNAM", subModel = "choice", -#' estimationInit = list(engine = "default_c")) +#' model = "DyNAM", subModel = "choice", +#' estimationInit = list(engine = "default_c") +#' ) #' summary(mod01) #' #' # A individual activity rates model #' mod02 <- estimate(callsDependent ~ 1 + nodeTrans + indeg + outdeg, -#' model = "DyNAM", subModel = "rate", -#' estimationInit = list(engine = "default_c")) +#' model = "DyNAM", subModel = "rate", +#' estimationInit = list(engine = "default_c") +#' ) #' summary(mod02) #' #' \donttest{ @@ -257,14 +263,14 @@ #' } #' estimate <- function( - x, - model = c("DyNAM", "REM", "DyNAMi"), - subModel = c("choice", "rate", "choice_coordination"), - estimationInit = NULL, - preprocessingInit = NULL, - preprocessingOnly = FALSE, - progress = getOption("progress"), - verbose = getOption("verbose")) { + x, + model = c("DyNAM", "REM", "DyNAMi"), + subModel = c("choice", "rate", "choice_coordination"), + estimationInit = NULL, + preprocessingInit = NULL, + preprocessingOnly = FALSE, + progress = getOption("progress"), + verbose = getOption("verbose")) { UseMethod("estimate", x) } @@ -273,14 +279,14 @@ estimate <- function( #' @importFrom stats as.formula #' @export estimate.formula <- function( - x, - model = c("DyNAM", "REM", "DyNAMi"), - subModel = c("choice", "rate", "choice_coordination"), - estimationInit = NULL, - preprocessingInit = NULL, - preprocessingOnly = FALSE, - progress = getOption("progress"), - verbose = getOption("verbose")) { + x, + model = c("DyNAM", "REM", "DyNAMi"), + subModel = c("choice", "rate", "choice_coordination"), + estimationInit = NULL, + preprocessingInit = NULL, + preprocessingOnly = FALSE, + progress = getOption("progress"), + verbose = getOption("verbose")) { # Steps: # 1. Parse the formula # 2. Initialize additional objects @@ -338,30 +344,34 @@ estimate.formula <- function( } # Decide the type of engine - engine <- match.arg(estimationInit[["engine"]], - c("default", "default_c", "gather_compute")) + engine <- match.arg( + estimationInit[["engine"]], + c("default", "default_c", "gather_compute") + ) if (!is.null(estimationInit[["engine"]])) estimationInit[["engine"]] <- NULL # gather_compute and default_c don't support returnEventProbabilities if (!is.null(estimationInit) && - "returnEventProbabilities" %in% names(estimationInit)) { + "returnEventProbabilities" %in% names(estimationInit)) { if (estimationInit["returnEventProbabilities"] == TRUE && - engine != "default") { + engine != "default") { warning("engine = ", dQuote(engine), " doesn't support", - dQuote("returnEventProbabilities"), - ". engine =", dQuote("default"), " is used instead.", - call. = FALSE, immediate. = TRUE) + dQuote("returnEventProbabilities"), + ". engine =", dQuote("default"), " is used instead.", + call. = FALSE, immediate. = TRUE + ) engine <- "default" } } # gather_compute and default_c don't support restrictions of opportunity sets if (!is.null(estimationInit) && - "opportunitiesList" %in% names(estimationInit)) { + "opportunitiesList" %in% names(estimationInit)) { if (!is.null(estimationInit["opportunitiesList"]) && engine != "default") { warning("engine = ", dQuote(engine), " doesn't support", - dQuote("opportunitiesList"), - ". engine =", dQuote("default"), " is used instead.", - call. = FALSE, immediate. = TRUE) + dQuote("opportunitiesList"), + ". engine =", dQuote("default"), " is used instead.", + call. = FALSE, immediate. = TRUE + ) engine <- "default" } } @@ -386,29 +396,33 @@ estimate.formula <- function( # # C implementation doesn't have ignoreRep option issue #105 if (any(unlist(parsedformula$ignoreRepParameter)) && - engine %in% c("default_c", "gather_compute")) { + engine %in% c("default_c", "gather_compute")) { warning("engine = ", dQuote(engine), - " doesn't support ignoreRep effects. engine =", - dQuote("default"), " is used instead.", - call. = FALSE, immediate. = TRUE) + " doesn't support ignoreRep effects. engine =", + dQuote("default"), " is used instead.", + call. = FALSE, immediate. = TRUE + ) engine <- "default" } # Model-specific preprocessing initialization if (hasIntercept && model %in% c("DyNAM", "DyNAMi") && - subModel %in% c("choice", "choice_coordination")) { + subModel %in% c("choice", "choice_coordination")) { warning("Model ", dQuote(model), " subModel ", dQuote(subModel), - " ignores the time intercept.", - call. = FALSE, immediate. = TRUE) + " ignores the time intercept.", + call. = FALSE, immediate. = TRUE + ) hasIntercept <- FALSE } rightCensored <- hasIntercept if (progress && - !(model %in% c("DyNAM", "DyNAMi") && - subModel %in% c("choice", "choice_coordination"))) + !(model %in% c("DyNAM", "DyNAMi") && + subModel %in% c("choice", "choice_coordination"))) { cat( - ifelse(hasIntercept, "T", "No t"), "ime intercept added.\n", sep = "" + ifelse(hasIntercept, "T", "No t"), "ime intercept added.\n", + sep = "" ) + } # if (progress && !all(vapply(windowParameters, is.null, logical(1)))) # cat("Creating window objects in global environment.") @@ -445,7 +459,8 @@ estimate.formula <- function( # enviroment from which get the objects effects <- createEffectsFunctions(rhsNames, model, subModel, - envir = PreprocessEnvir) + envir = PreprocessEnvir + ) # Get links between objects and effects for printing results objectsEffectsLink <- getObjectsEffectsLink(rhsNames) @@ -453,12 +468,17 @@ estimate.formula <- function( if (is.null(preprocessingInit)) { # Initialize events list and link to objects events <- getEventsAndObjectsLink( - depName, rhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[1]] - # moved cleanInteractionEvents in getEventsAndObjectsLink + depName, rhsNames, .nodes, .nodes2, + envir = PreprocessEnvir + )[[1]] + # moved cleanInteractionEvents in getEventsAndObjectsLink eventsObjectsLink <- getEventsAndObjectsLink( - depName, rhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[2]] + depName, rhsNames, .nodes, .nodes2, + envir = PreprocessEnvir + )[[2]] eventsEffectsLink <- getEventsEffectsLink( - events, rhsNames, eventsObjectsLink) + events, rhsNames, eventsObjectsLink + ) } # DyNAM-i ONLY: extra cleaning step @@ -467,7 +487,9 @@ estimate.formula <- function( if (model == "DyNAMi") { events <- cleanInteractionEvents( events, eventsEffectsLink, windowParameters, subModel, depName, - eventsObjectsLink, envir = PreprocessEnvir) + eventsObjectsLink, + envir = PreprocessEnvir + ) } ### 3. PREPROCESS statistics---- @@ -475,7 +497,7 @@ estimate.formula <- function( ## add new ones if (!is.null(preprocessingInit)) { # recover the nodesets - .nodes <- preprocessingInit$nodes + .nodes <- preprocessingInit$nodes .nodes2 <- preprocessingInit$nodes2 isTwoMode <- FALSE if (!identical(.nodes, .nodes2)) isTwoMode <- TRUE @@ -486,7 +508,9 @@ estimate.formula <- function( newrhsNames <- rhsNames[which(effectsindexes == 0)] newWindowParameters <- windowParameters[which(effectsindexes == 0)] neweffects <- createEffectsFunctions( - newrhsNames, model, subModel, envir = PreprocessEnvir) + newrhsNames, model, subModel, + envir = PreprocessEnvir + ) # Get links between objects and effects for printing results newobjectsEffectsLink <- getObjectsEffectsLink(newrhsNames) @@ -505,11 +529,16 @@ estimate.formula <- function( # Retrieve again the events to calculate new statistics newevents <- getEventsAndObjectsLink( - depName, newrhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[1]] + depName, newrhsNames, .nodes, .nodes2, + envir = PreprocessEnvir + )[[1]] neweventsObjectsLink <- getEventsAndObjectsLink( - depName, newrhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[2]] + depName, newrhsNames, .nodes, .nodes2, + envir = PreprocessEnvir + )[[2]] neweventsEffectsLink <- getEventsEffectsLink( - newevents, newrhsNames, neweventsObjectsLink) + newevents, newrhsNames, neweventsObjectsLink + ) # Preprocess the new effects if (progress) cat("Pre-processing additional effects.\n") @@ -536,23 +565,24 @@ estimate.formula <- function( # test the length of the dependent and RC updates (in case the events # objects was changed in the environment) - if (length(preprocessingInit$intervals) != length(newprep$intervals)) + if (length(preprocessingInit$intervals) != length(newprep$intervals)) { stop( "The numbers of dependent events in the formula and in the ", "preprocessed object are not consistent.\n", "\tPlease check whether these events have changed.", call. = FALSE ) + } if (length(preprocessingInit$rightCensoredIntervals) != - length(newprep$rightCensoredIntervals)) + length(newprep$rightCensoredIntervals)) { stop( "The numbers of right-censored events in the formula and in the ", "preprocessed object are not consistent.\n", - "\tPlease check whether some windows have been changed.", + "\tPlease check whether some windows have been changed.", call. = FALSE ) - + } } # combine old and new preprocessed objects @@ -639,12 +669,12 @@ estimate.formula <- function( } } - prep <- allprep - prep$formula <- formula - prep$model <- model + prep <- allprep + prep$formula <- formula + prep$model <- model prep$subModel <- subModel - prep$nodes <- .nodes - prep$nodes2 <- .nodes2 + prep$nodes <- .nodes + prep$nodes2 <- .nodes2 } ## 3.2 PREPROCESS when preprocessingInit == NULL @@ -664,7 +694,8 @@ estimate.formula <- function( rightCensored = rightCensored, progress = progress, groupsNetwork = parsedformula$defaultNetworkName, - prepEnvir = PreprocessEnvir) + prepEnvir = PreprocessEnvir + ) } else { prep <- preprocess( model = model, @@ -686,15 +717,15 @@ estimate.formula <- function( progress = progress, prepEnvir = PreprocessEnvir ) - } + } # The formula, nodes, nodes2 are added to the preprocessed object so that # we can call the estimation with preprocessingInit later # (for parsing AND composition changes) - prep$formula <- formula - prep$model <- model + prep$formula <- formula + prep$model <- model prep$subModel <- subModel - prep$nodes <- .nodes - prep$nodes2 <- .nodes2 + prep$nodes <- .nodes + prep$nodes2 <- .nodes2 } ## 3.3 Stop here if preprocessingOnly == TRUE @@ -706,8 +737,10 @@ estimate.formula <- function( ### 4. PREPARE PRINTING---- # functions_utility.R effectDescription <- - GetDetailPrint(objectsEffectsLink, parsedformula, - estimationInit[["fixedParameters"]]) + GetDetailPrint( + objectsEffectsLink, parsedformula, + estimationInit[["fixedParameters"]] + ) hasWindows <- attr(effectDescription, "hasWindows") if (is.null(hasWindows)) { hasWindows <- !all(vapply(windowParameters, is.null, logical(1))) @@ -732,10 +765,13 @@ estimate.formula <- function( modelTypeCall <- "DyNAM-M" } } - if (progress) + if (progress) { cat( "Estimating a model: ", dQuote(model), ", subModel: ", - dQuote(subModel), ".\n", sep = "") + dQuote(subModel), ".\n", + sep = "" + ) + } EstimateEnvir <- new.env() # Default estimation @@ -758,7 +794,7 @@ estimate.formula <- function( # prefer user-defined arguments argsEstimation <- append( estimationInit[!(names(estimationInit) %in% - c("startTime", "endTime"))], + c("startTime", "endTime"))], additionalArgs[!(names(additionalArgs) %in% names(estimationInit))] ) @@ -771,7 +807,9 @@ estimate.formula <- function( ), error = \(e) { stop("Error in ", model, " ", subModel, - " estimation: ", e, call. = FALSE) + " estimation: ", e, + call. = FALSE + ) } ) } else { @@ -779,7 +817,9 @@ estimate.formula <- function( result <- do.call("estimate_int", args = argsEstimation), error = \(e) { stop("Error in ", model, " ", subModel, - " estimation: ", e, call. = FALSE) + " estimation: ", e, + call. = FALSE + ) } ) } @@ -787,14 +827,17 @@ estimate.formula <- function( ### 6. RESULTS---- result$names <- effectDescription formulaKeep <- as.formula(Reduce(paste, deparse(formula)), - env = new.env(parent = emptyenv())) + env = new.env(parent = emptyenv()) + ) result$formula <- formulaKeep result$model <- model result$subModel <- subModel result$rightCensored <- hasIntercept result$nParams <- sum(!GetFixed(result)) - result$call <- match.call(call = sys.call(-1L), - expand.dots = TRUE) + result$call <- match.call( + call = sys.call(-1L), + expand.dots = TRUE + ) result$call[[2]] <- formulaKeep return(result) diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 98dfd3d..7acd573 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -7,37 +7,38 @@ # Estimation estimate_int <- function( - statsList, - nodes, nodes2, - defaultNetworkName, - modelType = c("DyNAM-MM", "DyNAM-M", "REM-ordered", - "DyNAM-M-Rate", "REM", "DyNAM-M-Rate-ordered"), - initialParameters = NULL, - fixedParameters = NULL, - excludeParameters = NULL, - initialDamping = 1, - maxIterations = 20, - dampingIncreaseFactor = 2, - dampingDecreaseFactor = 3, - maxScoreStopCriterion = 0.001, - # additional return objects - returnEventProbabilities = FALSE, - # additional parameter for DyNAM-MM - allowReflexive = FALSE, - isTwoMode = FALSE, - # additional parameter for DyNAM-M-Rate - hasIntercept = FALSE, - returnIntervalLogL = FALSE, - parallelize = FALSE, - cpus = 6, - verbose = FALSE, - progress = FALSE, - impute = TRUE, - ignoreRepParameter, - # restrictions of opportunity sets - opportunitiesList = NULL, - prepEnvir = new.env()) { - + statsList, + nodes, nodes2, + defaultNetworkName, + modelType = c( + "DyNAM-MM", "DyNAM-M", "REM-ordered", + "DyNAM-M-Rate", "REM", "DyNAM-M-Rate-ordered" + ), + initialParameters = NULL, + fixedParameters = NULL, + excludeParameters = NULL, + initialDamping = 1, + maxIterations = 20, + dampingIncreaseFactor = 2, + dampingDecreaseFactor = 3, + maxScoreStopCriterion = 0.001, + # additional return objects + returnEventProbabilities = FALSE, + # additional parameter for DyNAM-MM + allowReflexive = FALSE, + isTwoMode = FALSE, + # additional parameter for DyNAM-M-Rate + hasIntercept = FALSE, + returnIntervalLogL = FALSE, + parallelize = FALSE, + cpus = 6, + verbose = FALSE, + progress = FALSE, + impute = TRUE, + ignoreRepParameter, + # restrictions of opportunity sets + opportunitiesList = NULL, + prepEnvir = new.env()) { ## SET VARIABLES minDampingFactor <- initialDamping @@ -53,7 +54,7 @@ estimate_int <- function( idFixedCompnents <- NULL likelihoodOnly <- FALSE if (!is.null(fixedParameters)) { - if (length(fixedParameters) != nParams) + if (length(fixedParameters) != nParams) { stop( "The length of fixedParameters is inconsistent with", "the number of the parameters.", @@ -61,6 +62,7 @@ estimate_int <- function( length(fixedParameters), "\n\tNumber of parameters:", nParams, call. = FALSE ) + } if (all(!is.na(fixedParameters))) likelihoodOnly <- TRUE parameters[!is.na(fixedParameters)] <- @@ -73,15 +75,16 @@ estimate_int <- function( ## PARAMETER CHECKS - if (length(parameters) != nParams) + if (length(parameters) != nParams) { stop( " Wrong number of initial parameters passed to function.", "\n\tLength ", dQuote("parameters"), " vector:", length(parameters), "\n\tNumber of parameters:", nParams, call. = FALSE ) + } - if (!(length(minDampingFactor) %in% c(1, nParams))) + if (!(length(minDampingFactor) %in% c(1, nParams))) { stop( "minDampingFactor has wrong length:", "\n\tLength ", dQuote("minDampingFactor"), " vector:", @@ -89,12 +92,14 @@ estimate_int <- function( "\nIt should be length 1 or same as number of parameters.", call. = FALSE ) + } - if (dampingIncreaseFactor < 1 || dampingDecreaseFactor < 1) + if (dampingIncreaseFactor < 1 || dampingDecreaseFactor < 1) { stop( "Damping increase / decrease factors cannot be smaller than one.", call. = FALSE ) + } ## REDUCE STATISTICS LIST @@ -128,12 +133,12 @@ estimate_int <- function( ## GET COMPOSITION CHANGES compChangeName1 <- attr(nodes, "events")[ "present" == attr(nodes, "dynamicAttribute") - ] + ] hasCompChange1 <- !is.null(compChangeName1) && length(compChangeName1) > 0 compChangeName2 <- attr(nodes2, "events")[ "present" == attr(nodes2, "dynamicAttribute") - ] + ] hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 if (hasCompChange1) { @@ -167,8 +172,8 @@ estimate_int <- function( # CHANGED MARION # replace first parameter with an initial estimate of the intercept if (modelType %in% c("REM", "DyNAM-M-Rate") && hasIntercept && - is.null(initialParameters) && - (is.null(fixedParameters) || is.na(fixedParameters[1]))) { + is.null(initialParameters) && + (is.null(fixedParameters) || is.na(fixedParameters[1]))) { totalTime <- sum(unlist(statsList$intervals), na.rm = TRUE) + sum(unlist(statsList$rightCensoredIntervals), na.rm = TRUE) @@ -284,12 +289,13 @@ estimate_int <- function( } if (isInitialEstimation && any(is.na(unlist(res))) && - !all(parameters[-1] == 0)) # # Check + !all(parameters[-1] == 0)) { # # Check stop( "Estimation not possible with initial parameters.", " Try using zeros instead.", call. = FALSE ) + } # If we only want the likelihood break here if (likelihoodOnly) { @@ -303,27 +309,33 @@ estimate_int <- function( # It's for the fixing parameter feature. \ score[idFixedCompnents] <- 0 - if (!verbose && progress) + if (!verbose && progress) { cat( "\rMax score: ", - round(max(abs(score)), - round(-logb(maxScoreStopCriterion / 1, 10)) + 1), + round( + max(abs(score)), + round(-logb(maxScoreStopCriterion / 1, 10)) + 1 + ), " (", iIteration, "). " ) + } if (verbose) { cat( "\n\nLikelihood:", logLikelihood, "in iteration", iIteration, - "\nParameters:", toString(parameters), - "\nScore:", toString(score) + "\nParameters:", toString(parameters), + "\nScore:", toString(score) ) # print(informationMatrix) } if (logLikelihood <= logLikelihood.old || any(is.na(unlist(res)))) { - if (verbose) - cat("\nNo improvement in estimation.", - " Resetting values and adjusting damping.") + if (verbose) { + cat( + "\nNo improvement in estimation.", + " Resetting values and adjusting damping." + ) + } # reset values logLikelihood <- logLikelihood.old parameters <- parameters.old @@ -357,39 +369,45 @@ estimate_int <- function( solve(informationMatrixUnfixed), silent = TRUE ) - if (inherits(inverseInformationUnfixed, "try-error")) + if (inherits(inverseInformationUnfixed, "try-error")) { stop( "Matrix cannot be inverted;", " probably due to collinearity between parameters." ) + } update <- rep(0, nParams) update[idUnfixedCompnents] <- (inverseInformationUnfixed %*% score[idUnfixedCompnents]) / dampingFactor - if (verbose) + if (verbose) { cat( "\nUpdate: ", toString(update), "\nDamping factor: ", toString(dampingFactor) ) + } # check for stop criteria if (max(abs(score)) <= maxScoreStopCriterion) { isConverged <- TRUE - if (progress) + if (progress) { cat( "\nStopping as maximum absolute score is below ", - maxScoreStopCriterion, ".\n", sep = "" + maxScoreStopCriterion, ".\n", + sep = "" ) + } break } if (iIteration > maxIterations) { - if (progress) + if (progress) { cat( "\nStopping as maximum of ", maxIterations, - " iterations have been reached. No convergence.\n") + " iterations have been reached. No convergence.\n" + ) + } break } @@ -423,8 +441,9 @@ estimate_int <- function( nEvents = nEvents ) if (returnIntervalLogL) estimationResult$intervalLogL <- intervalLogL - if (returnEventProbabilities) + if (returnEventProbabilities) { estimationResult$eventProbabilities <- eventProbabilities + } attr(estimationResult, "class") <- "result.goldfish" estimationResult } @@ -446,14 +465,18 @@ getEventValues <- function( if (modelType == "DyNAM-MM") { multinomialProbabilities <- getMultinomialProbabilities( - statsArray, activeDyad, parameters, allowReflexive = allowReflexive) + statsArray, activeDyad, parameters, + allowReflexive = allowReflexive + ) eventLikelihoods <- getLikelihoodMM(multinomialProbabilities) logLikelihood <- log(eventLikelihoods[activeDyad[1], activeDyad[2]]) firstDerivatives <- getFirstDerivativeMM( - statsArray, eventLikelihoods, multinomialProbabilities) + statsArray, eventLikelihoods, multinomialProbabilities + ) score <- firstDerivatives[activeDyad[1], activeDyad[2], ] informationMatrix <- getMultinomialInformationMatrix( - eventLikelihoods, firstDerivatives) + eventLikelihoods, firstDerivatives + ) pMatrix <- eventLikelihoods } @@ -461,12 +484,14 @@ getEventValues <- function( eventProbabilities <- getMultinomialProbabilities( statsArray, activeDyad, parameters, - actorNested = TRUE, allowReflexive = FALSE, isTwoMode = isTwoMode) + actorNested = TRUE, allowReflexive = FALSE, isTwoMode = isTwoMode + ) logLikelihood <- log(eventProbabilities[activeDyad[2]]) firstDerivatives <- getFirstDerivativeM(statsArray, eventProbabilities) score <- firstDerivatives[activeDyad[2], ] informationMatrix <- getMultinomialInformationMatrixM( - eventProbabilities, firstDerivatives) + eventProbabilities, firstDerivatives + ) pMatrix <- eventProbabilities } @@ -474,12 +499,14 @@ getEventValues <- function( eventProbabilities <- getMultinomialProbabilities( statsArray, activeDyad, parameters, - actorNested = FALSE, allowReflexive = FALSE) + actorNested = FALSE, allowReflexive = FALSE + ) logLikelihood <- log(eventProbabilities[activeDyad[1], activeDyad[2]]) firstDerivatives <- getFirstDerivativeREM(statsArray, eventProbabilities) score <- firstDerivatives[activeDyad[1], activeDyad[2], ] informationMatrix <- getInformationMatrixREM( - eventProbabilities, firstDerivatives) + eventProbabilities, firstDerivatives + ) pMatrix <- eventProbabilities } @@ -503,9 +530,10 @@ getEventValues <- function( rowSums(t( t(matrix( apply(deviations, 1, function(x) outer(x, x)), - ncol = length(eventProbabilities)) - ) - * eventProbabilities)), + ncol = length(eventProbabilities) + )) + * eventProbabilities + )), length(parameters), length(parameters) ) pMatrix <- eventProbabilities @@ -546,9 +574,9 @@ getEventValues <- function( ratesStatsSum <- colSums(rates * statsArray) ratesStatsStatsSum <- colSums(t( - apply(statsArray, 1, function(x) outer(x, x))) * - rates - ) + apply(statsArray, 1, function(x) outer(x, x)) + ) * + rates) if (length(parameters) == 1 && modelType == "DyNAM-M-Rate") { v <- as.vector(statsArray) sum <- 0 @@ -669,7 +697,7 @@ getInformationMatrixREM <- function(eventProbabilities, firstDerivatives) { indexes, 1, \(ind) { firstDerivatives[, , ind[1]] * firstDerivatives[, , ind[2]] * - eventProbabilities + eventProbabilities } )) information <- matrix(values, nParams, nParams) @@ -708,9 +736,7 @@ getIterationStepState <- function( impute = TRUE, verbose = FALSE, opportunitiesList = NULL, - prepEnvir = new.env() -) { - + prepEnvir = new.env()) { # CHANGED MARION: changed dims nEvents <- length(statsList$orderEvents) nParams <- dim(statsList$initialStats)[3] @@ -720,10 +746,12 @@ getIterationStepState <- function( score <- rep(0, nParams) logLikelihood <- 0 - if (returnEventProbabilities) + if (returnEventProbabilities) { EventProbabilities <- vector(mode = "list", length = nEvents) - if (returnIntervalLogL) + } + if (returnIntervalLogL) { eventLogL <- numeric(nEvents) + } # check for parallelization # if (parallelize && require("snowfall", quietly = TRUE)) { @@ -762,8 +790,9 @@ getIterationStepState <- function( updFun <- function(stat, change) { # stat: current statistics (for one effect only) # change: statsList$dependentStatsChange[[current event]][[current effect]] - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -786,12 +815,13 @@ getIterationStepState <- function( is.null, logical(1) ) - for (j in which(pars2update)) + for (j in which(pars2update)) { statsArray[, , j + hasIntercept] <- - updFun( - statsArray[, , j + hasIntercept], - statsList$dependentStatsChange[[idep]][[j]] - ) + updFun( + statsArray[, , j + hasIntercept], + statsList$dependentStatsChange[[idep]][[j]] + ) + } # with intercept in the model if (hasIntercept) { time <- time + statsList$intervals[[idep]] @@ -828,10 +858,11 @@ getIterationStepState <- function( } # IMPUTE missing statistics with current mean - if (impute) + if (impute) { for (j in seq_len(nParams)) { statsArray[, , j] <- imputeFun(statsArray[, , j]) } + } statsArrayComp <- statsArray # Handle the ignoreRep option @@ -846,7 +877,7 @@ getIterationStepState <- function( ones[, 1], ones[, 2], rep(ignoreRepIds, each = length(ignoreRepIds) * nrow(ones)) - )] <- 0 + )] <- 0 # CHANGED SIWEI startTime <- statsList$eventTime[[i]] net[seq_len(dim(net)[1]), seq_len(dim(net)[2])] <- mat @@ -855,8 +886,9 @@ getIterationStepState <- function( # update opportunity set opportunities <- rep(TRUE, nrow(nodes2)) updateopportunities <- !is.null(opportunitiesList) - if (updateopportunities) + if (updateopportunities) { opportunities <- seq_len(nrow(nodes2)) %in% opportunitiesList[[i]] + } # update composition # CHANGED SIWEI: fixed errors for composition change update @@ -867,14 +899,14 @@ getIterationStepState <- function( if (updatepresence) { update <- compChange1[compChange1$time <= current_time & - compChange1$time > oldTime, ] + compChange1$time > oldTime, ] presence[update$node] <- update$replace } if (updatepresence2) { update2 <- compChange2[compChange2$time <= current_time & - compChange2$time > oldTime, ] + compChange2$time > oldTime, ] presence2[update2$node] <- update2$replace } oldTime <- current_time @@ -887,9 +919,11 @@ getIterationStepState <- function( statsArrayComp <- statsArrayComp[subset, , , drop = FALSE] if (isDependent) { position <- which(activeDyad[1] == which(subset)) - if (length(position) == 0) + if (length(position) == 0) { stop("Active node ", activeDyad[1], " not present in event ", i, - call. = FALSE) + call. = FALSE + ) + } activeDyad[1] <- position } @@ -899,9 +933,11 @@ getIterationStepState <- function( statsArrayComp <- statsArrayComp[, subset, , drop = TRUE] if (isDependent) { position <- which(activeDyad[2] == which(subset)) - if (length(position) == 0) + if (length(position) == 0) { stop("Active node ", activeDyad[2], " not available in event ", i, - call. = FALSE) + call. = FALSE + ) + } activeDyad[2] <- position } @@ -913,8 +949,9 @@ getIterationStepState <- function( # CHANGED SIWEI: treat one-mode and two-mode cases seperately # handle the reductions in one step outside the iteration loop, to be make if (reduceMatrixToVector) { - if (verbose && i == 1) + if (verbose && i == 1) { cat("\nReplacing effects statistics by row means") + } # statsArrayComp: n_nodes1*n_nodes2*num_statistics matrix arr <- apply( statsArrayComp, @@ -922,8 +959,11 @@ getIterationStepState <- function( \(stat) { if (!isTwoMode) diag(stat) <- 0 m <- stat - if (!isTwoMode) rowSums(m, na.rm = TRUE) / (dim(m)[1] - 1) - else rowMeans(m, na.rm = TRUE) + if (!isTwoMode) { + rowSums(m, na.rm = TRUE) / (dim(m)[1] - 1) + } else { + rowMeans(m, na.rm = TRUE) + } } ) statsArrayComp <- arr # statsArrayComp: n_nodes*n_effects matrix @@ -1032,7 +1072,7 @@ getMultinomialInformationMatrix <- function(likelihoods, derivatives) { indexes, 1, \(ind) { sum(derivatives[, , ind[1]] * derivatives[, , ind[2]] * - likelihoodsTriangle) + likelihoodsTriangle) } ) informationMatrix <- matrix(values, nParams, nParams, byrow = FALSE) @@ -1054,7 +1094,7 @@ getMultinomialInformationMatrixM <- function( indexes, 1, \(ind) { firstDerivatives[, ind[1]] * firstDerivatives[, ind[2]] * - eventProbabilities + eventProbabilities } ) if (!is.null(dim(temp))) { @@ -1077,16 +1117,16 @@ getMultinomialProbabilities <- function( actorNested = TRUE, allowReflexive = TRUE, isTwoMode = FALSE) { - # allow this for a two- OR a three-dimensional array provided as input, # to be make nDimensions <- length(dim(statsArray)) - if (!(nDimensions %in% c(2, 3))) + if (!(nDimensions %in% c(2, 3))) { stop( "StatsArray in getMultinomialProbabilities has to be", " two- or three-dimensional.", call. = FALSE ) + } # nParams <- dim(statsArray)[nDimensions] nActors1 <- dim(statsArray)[1] @@ -1125,18 +1165,18 @@ modifyStatisticsList <- function( reduceArrayToMatrix = FALSE, excludeParameters = NULL, addInterceptEffect = FALSE) { - # exclude effect statistics if (!is.null(excludeParameters)) { unknownIndexes <- setdiff( excludeParameters, seq_len(dim(statsList$initialStats)[3]) ) - if (length(unknownIndexes) > 0) + if (length(unknownIndexes) > 0) { stop( "Unknown parameter indexes in 'excludeIndexes': ", paste(unknownIndexes, collapse = " ") ) + } statsList$initialStats <- statsList$initialStats[, , -excludeParameters] } @@ -1204,7 +1244,7 @@ reduceStatisticsList <- function( if (statsList$orderEvents[[i]] > 1) { newintervals[[length(newintervals)]] <- newintervals[[length(newintervals)]] + - statsList$rightCensoredIntervals[[irc]] + statsList$rightCensoredIntervals[[irc]] irc <- irc + 1 } } diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index 4f99349..09defc2 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -7,41 +7,39 @@ # Estimation estimate_c_int <- function( - statsList, - nodes, nodes2, - defaultNetworkName, - modelTypeCall = c( - "DyNAM-MM", "DyNAM-M", "REM-ordered", - "DyNAM-M-Rate", "REM", "DyNAM-M-Rate-ordered" - ), - initialParameters = NULL, - fixedParameters = NULL, - excludeParameters = NULL, - initialDamping = 1, - maxIterations = 20, - dampingIncreaseFactor = 2, - dampingDecreaseFactor = 3, - maxScoreStopCriterion = 0.001, - # additional return objects - returnEventProbabilities = FALSE, - # additional parameter for DyNAM-MM - allowReflexive = FALSE, - isTwoMode = FALSE, - # additional parameter for DyNAM-M-Rate - hasIntercept = FALSE, - returnIntervalLogL = FALSE, - parallelize = FALSE, - cpus = 6, - verbose = FALSE, - progress = FALSE, - ignoreRepParameter = ignoreRepParameter, - testing = FALSE, - get_data_matrix = FALSE, - impute = FALSE, - engine = c("default_c", "gather_compute"), - prepEnvir = new.env() - ) { - + statsList, + nodes, nodes2, + defaultNetworkName, + modelTypeCall = c( + "DyNAM-MM", "DyNAM-M", "REM-ordered", + "DyNAM-M-Rate", "REM", "DyNAM-M-Rate-ordered" + ), + initialParameters = NULL, + fixedParameters = NULL, + excludeParameters = NULL, + initialDamping = 1, + maxIterations = 20, + dampingIncreaseFactor = 2, + dampingDecreaseFactor = 3, + maxScoreStopCriterion = 0.001, + # additional return objects + returnEventProbabilities = FALSE, + # additional parameter for DyNAM-MM + allowReflexive = FALSE, + isTwoMode = FALSE, + # additional parameter for DyNAM-M-Rate + hasIntercept = FALSE, + returnIntervalLogL = FALSE, + parallelize = FALSE, + cpus = 6, + verbose = FALSE, + progress = FALSE, + ignoreRepParameter = ignoreRepParameter, + testing = FALSE, + get_data_matrix = FALSE, + impute = FALSE, + engine = c("default_c", "gather_compute"), + prepEnvir = new.env()) { minDampingFactor <- initialDamping # CHANGED MARION # nParams: number of effects + 1 (if has intercept) @@ -55,7 +53,7 @@ estimate_c_int <- function( idFixedCompnents <- NULL likelihoodOnly <- FALSE if (!is.null(fixedParameters)) { - if (length(fixedParameters) != nParams) + if (length(fixedParameters) != nParams) { stop( "The length of fixedParameters is inconsistent with", "the number of the parameters.", @@ -63,6 +61,7 @@ estimate_c_int <- function( length(fixedParameters), "\n\tNumber of parameters:", nParams, call. = FALSE ) + } if (all(!is.na(fixedParameters))) likelihoodOnly <- TRUE parameters[!is.na(fixedParameters)] <- @@ -76,15 +75,16 @@ estimate_c_int <- function( ## PARAMETER CHECKS - if (length(parameters) != nParams) + if (length(parameters) != nParams) { stop( " Wrong number of initial parameters passed to function.", "\n\tLength ", dQuote("parameters"), " vector:", length(parameters), "\n\tNumber of parameters:", nParams, call. = FALSE ) + } - if (!(length(minDampingFactor) %in% c(1, nParams))) + if (!(length(minDampingFactor) %in% c(1, nParams))) { stop( "minDampingFactor has wrong length:", "\n\tLength ", dQuote("minDampingFactor"), " vector:", @@ -92,12 +92,14 @@ estimate_c_int <- function( "\nIt should be length 1 or same as number of parameters.", call. = FALSE ) + } - if (dampingIncreaseFactor < 1 || dampingDecreaseFactor < 1) + if (dampingIncreaseFactor < 1 || dampingDecreaseFactor < 1) { stop( "Damping increase / decrease factors cannot be smaller than one.", call. = FALSE ) + } ## REDUCE STATISTICS LIST @@ -178,9 +180,9 @@ estimate_c_int <- function( ## ADD INTERCEPT # CHANGED MARION # replace first parameter with an initial estimate of the intercept - if (modelTypeCall %in% c("REM","DyNAM-M-Rate") && hasIntercept && - is.null(initialParameters) && - (is.null(fixedParameters) || is.na(fixedParameters[1]))) { + if (modelTypeCall %in% c("REM", "DyNAM-M-Rate") && hasIntercept && + is.null(initialParameters) && + (is.null(fixedParameters) || is.na(fixedParameters[1]))) { totalTime <- sum(unlist(statsList$intervals), na.rm = TRUE) + sum(unlist(statsList$rightCensoredIntervals), na.rm = TRUE) @@ -262,7 +264,7 @@ estimate_c_int <- function( timespan[is_dependent] <- statsList$intervals timespan[!is_dependent] <- statsList$rightCensoredIntervals } else if (modelTypeCall %in% - c("DyNAM-M-Rate-ordered", "REM-ordered", "DyNAM-MM")) { + c("DyNAM-M-Rate-ordered", "REM-ordered", "DyNAM-MM")) { is_dependent <- statsList$orderEvents == 1 } else { timespan <- NA @@ -390,12 +392,13 @@ estimate_c_int <- function( } if (isInitialEstimation && any(is.na(unlist(res))) && - !all(parameters[-1] == 0)) + !all(parameters[-1] == 0)) { stop( "Estimation not possible with initial parameters.", " Try using zeros instead.", call. = FALSE ) + } # If we only want the likelihood break here if (likelihoodOnly) { @@ -413,8 +416,8 @@ estimate_c_int <- function( cat( "\rMax score: ", round(max(abs(score)), round(-logb(maxScoreStopCriterion / 1, 10)) + 1), - " (", iIteration, "). " - ) + " (", iIteration, "). " + ) } if (verbose) { cat( @@ -426,11 +429,12 @@ estimate_c_int <- function( } if (logLikelihood <= logLikelihood.old || any(is.na(unlist(res)))) { - if (verbose) + if (verbose) { cat( "\nNo improvement in estimation.", " Resetting values and adjusting damping." ) + } # reset values logLikelihood <- logLikelihood.old parameters <- parameters.old @@ -460,47 +464,52 @@ estimate_c_int <- function( # The fixed components of the score have already be set to be 0. # It's for the fixing parameter feature. informationMatrixUnfixed <- - informationMatrix[idUnfixedCompnents,idUnfixedCompnents] + informationMatrix[idUnfixedCompnents, idUnfixedCompnents] inverseInformationUnfixed <- try( solve(informationMatrixUnfixed), silent = TRUE ) - if (inherits(inverseInformationUnfixed, "try-error")) + if (inherits(inverseInformationUnfixed, "try-error")) { stop( "Matrix cannot be inverted;", " probably due to collinearity between parameters.", call. = FALSE ) + } - update <- rep(0,nParams) - update[idUnfixedCompnents] <- - (inverseInformationUnfixed %*% score[idUnfixedCompnents]) / - dampingFactor + update <- rep(0, nParams) + update[idUnfixedCompnents] <- + (inverseInformationUnfixed %*% score[idUnfixedCompnents]) / + dampingFactor - if (verbose) + if (verbose) { cat( "\nUpdate: ", toString(update), "\nDamping factor:", toString(dampingFactor) ) + } # check for stop criteria if (max(abs(score)) <= maxScoreStopCriterion) { isConverged <- TRUE - if (progress) + if (progress) { cat( "\nStopping as maximum absolute score is below ", - maxScoreStopCriterion, ".\n", sep = "" + maxScoreStopCriterion, ".\n", + sep = "" ) + } break } if (iIteration > maxIterations) { - if (progress) + if (progress) { cat( "\nStopping as maximum of ", maxIterations, " iterations have been reached. No convergence.\n" ) + } break } @@ -512,7 +521,7 @@ estimate_c_int <- function( ## ESTIMATION: END # calculate standard errors # the variance for the fixed compenents should be 0 - stdErrors <- rep(0,nParams) + stdErrors <- rep(0, nParams) stdErrors[idUnfixedCompnents] <- sqrt(diag(inverseInformationUnfixed)) # define, type and return result @@ -536,8 +545,9 @@ estimate_c_int <- function( # if (testing) estimationResult$intermediateData <- # DataMatrixAndId$intermediate_data if (returnIntervalLogL) estimationResult$intervalLogL <- intervalLogL - if (returnEventProbabilities) + if (returnEventProbabilities) { estimationResult$eventProbabilities <- eventProbabilities + } attr(estimationResult, "class") <- "result.goldfish" estimationResult } @@ -563,8 +573,7 @@ estimate_ <- function( n_actors1, n_actors2, twomode_or_reflexive, - impute -) { + impute) { if (modelTypeCall == "DyNAM-MM") { res <- estimate_DyNAM_MM( parameters, @@ -718,9 +727,7 @@ gather_ <- function( n_actors2, twomode_or_reflexive, verbose, - impute -) { - + impute) { if (modelTypeCall %in% c("REM-ordered", "REM", "DyNAM-MM")) { # For DyNAM-MM, we deal with twomode_or_reflexive in the estimation # for convenience. @@ -805,17 +812,17 @@ compute_ <- function( n_candidates2, timespan, is_dependent, - twomode_or_reflexive -) { - if (modelTypeCall %in% c("DyNAM-M", "REM-ordered", "DyNAM-M-Rate-ordered")) + twomode_or_reflexive) { + if (modelTypeCall %in% c("DyNAM-M", "REM-ordered", "DyNAM-M-Rate-ordered")) { res <- compute_multinomial_selection( parameters, stat_all_events, n_candidates, selected ) + } - if (modelTypeCall %in% c("DyNAM-M-Rate", "REM")) + if (modelTypeCall %in% c("DyNAM-M-Rate", "REM")) { res <- compute_poisson_selection( parameters, stat_all_events, @@ -824,8 +831,9 @@ compute_ <- function( timespan, is_dependent ) + } - if (modelTypeCall == "DyNAM-MM") + if (modelTypeCall == "DyNAM-MM") { res <- compute_coordination_selection( parameters, stat_all_events, @@ -837,6 +845,7 @@ compute_ <- function( selected_actor2, twomode_or_reflexive ) + } return(res) } diff --git a/R/functions_gather.R b/R/functions_gather.R index 2aae50e..7d76aeb 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -43,12 +43,11 @@ #' createBilat ~ inertia(bilatnet) + trans(bilatnet) + tie(contignet) #' ) GatherPreprocessing <- function( - formula, - model = c("DyNAM", "REM"), - subModel = c("choice", "choice_coordination", "rate"), - preprocessArgs = NULL, - progress = getOption("progress")) { - + formula, + model = c("DyNAM", "REM"), + subModel = c("choice", "choice_coordination", "rate"), + preprocessArgs = NULL, + progress = getOption("progress")) { model <- match.arg(model) subModel <- match.arg(subModel) @@ -68,9 +67,12 @@ GatherPreprocessing <- function( ) } - if (!is.null(preprocessArgs["opportunitiesList"])) - warning(dQuote("GatherPreprocessing"), " doesn't implement yet the ", - dQuote("opportunitiesList"), " functionality") + if (!is.null(preprocessArgs["opportunitiesList"])) { + warning( + dQuote("GatherPreprocessing"), " doesn't implement yet the ", + dQuote("opportunitiesList"), " functionality" + ) + } } ### 1. PARSE the formula---- @@ -81,18 +83,21 @@ GatherPreprocessing <- function( windowParameters <- parsedformula$windowParameters # # C implementation doesn't have ignoreRep option issue #105 - if (any(unlist(parsedformula$ignoreRepParameter))) + if (any(unlist(parsedformula$ignoreRepParameter))) { stop("gatherPreprocessing ", - " doesn't support ignoreRep effects (GH issue #105)!", - call. = FALSE, immediate. = TRUE) + " doesn't support ignoreRep effects (GH issue #105)!", + call. = FALSE, immediate. = TRUE + ) + } # Model-specific preprocessing initialization if (model %in% c("DyNAM", "DyNAMi") && - subModel %in% c("choice", "choice_coordination") && - parsedformula$hasIntercept) { + subModel %in% c("choice", "choice_coordination") && + parsedformula$hasIntercept) { warning("Model ", dQuote(model), " subModel ", dQuote(subModel), - " ignores the time intercept.", - call. = FALSE, immediate. = TRUE) + " ignores the time intercept.", + call. = FALSE, immediate. = TRUE + ) parsedformula$hasIntercept <- FALSE } rightCensored <- parsedformula$hasIntercept @@ -124,7 +129,9 @@ GatherPreprocessing <- function( envir <- environment() effects <- createEffectsFunctions( - parsedformula$rhsNames, model, subModel, envir = envir) + parsedformula$rhsNames, model, subModel, + envir = envir + ) # Get links between objects and effects for printing results objectsEffectsLink <- getObjectsEffectsLink(parsedformula$rhsNames) @@ -133,13 +140,18 @@ GatherPreprocessing <- function( # Initialize events list and link to objects events <- getEventsAndObjectsLink( parsedformula$depName, parsedformula$rhsNames, - .nodes, .nodes2, envir = envir)[[1]] + .nodes, .nodes2, + envir = envir + )[[1]] # moved cleanInteractionEvents in getEventsAndObjectsLink eventsObjectsLink <- getEventsAndObjectsLink( parsedformula$depName, parsedformula$rhsNames, - .nodes, .nodes2, envir = envir)[[2]] + .nodes, .nodes2, + envir = envir + )[[2]] eventsEffectsLink <- getEventsEffectsLink( - events, parsedformula$rhsNames, eventsObjectsLink) + events, parsedformula$rhsNames, eventsObjectsLink + ) ## 3.2 PREPROCESS when preprocessingInit == NULL preprocessingStat <- preprocess( @@ -357,21 +369,24 @@ GatherPreprocessing <- function( #' @noRd #' #' @examples -#' names <- cbind(Object = c("bilatnet", "bilatnet", "contignet"), -#' Weighted = c("W", "", "W")) +#' names <- cbind( +#' Object = c("bilatnet", "bilatnet", "contignet"), +#' Weighted = c("W", "", "W") +#' ) #' rownames(names) <- c("inertia", "trans", "tie") #' CreateNames(names, sep = "|") CreateNames <- function( - names, sep = " ", joiner = ", ") { - + names, sep = " ", joiner = ", ") { isObjectD <- grepl("Object \\d+", colnames(names)) if (any(isObjectD)) { - object <- apply(names[, isObjectD], 1, - function(z) { - ret <- Filter(function(w) !is.na(w) & w != "", z) - ret <- paste(ret, collapse = joiner) - return(ret) - }) + object <- apply( + names[, isObjectD], 1, + function(z) { + ret <- Filter(function(w) !is.na(w) & w != "", z) + ret <- paste(ret, collapse = joiner) + return(ret) + } + ) newNames <- c("Object", colnames(names)[!isObjectD]) names <- cbind(object, names[, !isObjectD]) colnames(names) <- newNames @@ -382,12 +397,14 @@ CreateNames <- function( } names <- cbind(effect = rownames(names), names) - nombres <- apply(names, 1, - function(z) { - ret <- Filter(function(w) !is.na(w) & w != "", z) - ret <- paste(ret, collapse = sep) - return(ret) - }) + nombres <- apply( + names, 1, + function(z) { + ret <- Filter(function(w) !is.na(w) & w != "", z) + ret <- paste(ret, collapse = sep) + return(ret) + } + ) names(nombres) <- NULL return(nombres) diff --git a/R/functions_group_interaction_utility.R b/R/functions_group_interaction_utility.R index 5f904b0..f2258a4 100644 --- a/R/functions_group_interaction_utility.R +++ b/R/functions_group_interaction_utility.R @@ -47,7 +47,6 @@ #' } defineGroups_interaction <- function(records, actors, seed.randomization, progress = getOption("progress")) { - stopifnot( inherits(records, "data.frame"), inherits(actors, "data.frame"), @@ -154,10 +153,8 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # check all actors for (a1 in seq.int(nactors - 1)) { - # check all others for (a2 in seq.int(a1 + 1, nactors)) { - # interaction records? nAa1 <- which(records$NodeA == toString(a1)) nBa1 <- which(records$NodeB == toString(a1)) @@ -170,7 +167,7 @@ defineGroups_interaction <- function(records, actors, seed.randomization, if (length(inda1a2) > 0) { for (j in seq.int(length(inda1a2))) { if (records$Start[inda1a2[j]] <= time && - records$End[inda1a2[j]] > time) { + records$End[inda1a2[j]] > time) { areinteracting <- 1 } } @@ -184,7 +181,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, g <- 1 for (a1 in seq.int(nactors)) { - # is the actor is interacting? isinteracting <- sum(tempnet[a1, ]) > 0 @@ -335,7 +331,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # if some of them were interacting before, in one or several groups if (numpreviousgroups >= 1) { - # we randomly choose the group to keep, potentially # create one more in the split case newkeptg <- FALSE @@ -377,7 +372,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, if (newkeptg) { for (g2 in seq_len(numpreviousgroups)) { - # we check whether there are some other actors # in the previous group previousgroup <- previousgroups[g2] @@ -387,7 +381,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, if (length(previousgroupactors) > 0) { for (a2 in seq_along(previousgroupactors)) { - # dependent leaving events for active actors in other groups # + exogenous joining events to intermediary singletons if (!previousgroup %in% singletons) { @@ -502,7 +495,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # debug # cat(paste("(exo) leaving event: ", # previousgroupactors[a2],"to", newg, "\n")) - } else { # if it was a singleton, it just leaves the singleton exotimeevents_temp <- c(exotimeevents_temp, time) @@ -533,7 +525,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, previousgroups <- previousgroups[which(previousgroups != keptg)] for (g2 in seq.int(numpreviousgroups)) { - # we check whether there are some other actors # in the previous group previousgroup <- previousgroups[g2] @@ -543,7 +534,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, if (length(previousgroupactors) > 0) { for (a2 in seq.int(length(previousgroupactors))) { - # dependent leaving events for active actors in other groups # + exogenous joining events to intermediary singletons if (!previousgroup %in% singletons) { @@ -672,7 +662,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # "to", newg, "\n" # ) # ) - } else { # if it was a singleton, it just leaves the singleton exotimeevents_temp <- c(exotimeevents_temp, time) @@ -744,7 +733,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, # if there were previous groups, go through all of them in a random order if (numgroups > 0) { for (g in seq.int(numgroups)) { - # what about other actors in the group previousgroup <- previousgroups[g] groupactors <- which(currentgroups == previousgroup) @@ -889,7 +877,6 @@ defineGroups_interaction <- function(records, actors, seed.randomization, pastreceiverevents <- c(pastreceiverevents, pastreceiverevents_temp) pastreplaceevents <- c(pastreplaceevents, pastreplaceevents_temp) pastorder <- c(pastorder, pastorder_temp) - } # RESULTS @@ -951,13 +938,16 @@ defineGroups_interaction <- function(records, actors, seed.randomization, exogenous.events$receiver <- groups$label[exogenous.events$receiver] # Inform about the number of events - if (progress) + if (progress) { cat( "Data preparation for DyNAM-i model:\n", paste(nrow(dependent.events), "dependent events created"), "\n", - paste(nrow(exogenous.events), - "exogenous events created (group composition updates") + paste( + nrow(exogenous.events), + "exogenous events created (group composition updates" + ) ) + } groupsResult <- list( interaction.updates = interaction.updates, @@ -980,15 +970,13 @@ defineGroups_interaction <- function(records, actors, seed.randomization, cleanInteractionEvents <- function( events, eventsEffectsLink, windowParameters, subModel, depName, eventsObjectsLink, envir) { - - done.events <- rep(FALSE,dim(eventsEffectsLink)[1]) + done.events <- rep(FALSE, dim(eventsEffectsLink)[1]) # Windowed events: we remove the order of the events for (e in seq.int(dim(eventsEffectsLink)[1])) { for (eff in seq.int(dim(eventsEffectsLink)[2])) { if (!done.events[e] && !is.na(eventsEffectsLink[e, eff]) && - !is.null(windowParameters[[eff]])) { - + !is.null(windowParameters[[eff]])) { eventsobject <- get(rownames(eventsEffectsLink)[e], envir = envir) # correct the order of events @@ -1043,7 +1031,6 @@ cleanInteractionEvents <- function( # remove own groups from the sets of options setopportunities_interaction <- function( nodes, nodes2, eventsObjectsLink, groups.network) { - # get objects getactors <- get(nodes) getgroups <- get(nodes2) diff --git a/R/functions_output.R b/R/functions_output.R index 23c966c..8bf10fe 100644 --- a/R/functions_output.R +++ b/R/functions_output.R @@ -39,15 +39,16 @@ NULL #' @rdname print-method #' @method print result.goldfish print.result.goldfish <- function( - x, ..., digits = max(3, getOption("digits") - 2), - width = getOption("width"), complete = FALSE) { + x, ..., digits = max(3, getOption("digits") - 2), + width = getOption("width"), complete = FALSE) { cat("\nCall:\n") print(x$call) cat("\n\n") if (length(coef(x, complete = complete))) { cat("Coefficients:\n") print.default(format(coef(x, complete = complete), digits = digits), - print.gap = 2, quote = FALSE, width = width, ...) + print.gap = 2, quote = FALSE, width = width, ... + ) } else { cat("No coefficients\n") } @@ -121,10 +122,9 @@ summary.result.goldfish <- function(object, ...) { #' corrected for small sample size AICc are reported.} #' \item{Model and subModel:}{the values set during estimation.} print.summary.result.goldfish <- function( - x, ..., - digits = max(3, getOption("digits") - 2), - width = getOption("width"), complete = FALSE) { - + x, ..., + digits = max(3, getOption("digits") - 2), + width = getOption("width"), complete = FALSE) { nParams <- x$nParams aicc <- x$AIC + 2 * nParams * (nParams + 1) / (x$nEvents - nParams - 1) cat("\nCall:\n") @@ -142,12 +142,12 @@ print.summary.result.goldfish <- function( names <- x$names[!isFixed, ] coefMat <- x$coefMat[!isFixed, ] isDetPrint <- !((ncol(names) == 2) && - (length(unique(names[, "Object"])) == 1)) + (length(unique(names[, "Object"])) == 1)) } else { names <- x$names coefMat <- x$coefMat isDetPrint <- !((ncol(names) == 1) && - (length(unique(names[, "Object"])) == 1)) + (length(unique(names[, "Object"])) == 1)) } if (isDetPrint) { @@ -163,13 +163,19 @@ print.summary.result.goldfish <- function( "with max abs. score of", round(x$convergence$maxAbsScore, digits) ), "\n") - cat(" ", - paste("Log-Likelihood: ", signif(x$logLikelihood, digits), - "\n", sep = "")) - cat(" ", + cat( + " ", + paste("Log-Likelihood: ", signif(x$logLikelihood, digits), + "\n", + sep = "" + ) + ) + cat( + " ", "AIC: ", signif(x$AIC, digits), "\n AICc:", signif(aicc, digits), - "\n BIC: ", signif(x$BIC, digits), "\n") + "\n BIC: ", signif(x$BIC, digits), "\n" + ) cat(" model:", dQuote(x$model), "subModel:", dQuote(x$subModel), "\n") invisible(x) } @@ -191,19 +197,25 @@ print.nodes.goldfish <- function(x, ..., full = FALSE, n = 6) { events <- attr(x, "events") dynamicAttr <- attr(x, "dynamicAttributes") cat("Number of nodes:", nrow(x), "\n") - if ("present" %in% names(x)) + if ("present" %in% names(x)) { cat("Number of present nodes:", sum(x$present), "\n") + } if (!is.null(events) && any(events != "")) { title <- c("Dynamic attribute(s):", "Linked events") mxName <- max(nchar(dynamicAttr), nchar(title[1])) + 4 cat(title[1], strrep(" ", mxName - nchar(title[1])), title[2], - "\n", sep = "") + "\n", + sep = "" + ) lapply( seq_along(events), function(x) { - cat(strrep(" ", 2), dynamicAttr[x], - strrep(" ", mxName - nchar(dynamicAttr[x]) - 2), events[x], "\n") - }) + cat( + strrep(" ", 2), dynamicAttr[x], + strrep(" ", mxName - nchar(dynamicAttr[x]) - 2), events[x], "\n" + ) + } + ) } cat("\n") @@ -241,14 +253,17 @@ print.network.goldfish <- function(x, ..., full = FALSE, n = 6L) { directed <- attr(x, "directed") ties <- if (directed) sum(x > 0) else sum(x > 0) / 2 events <- attr(x, "events") - cat("Dimensions:", paste(dim(x), collapse = " "), - "\nNumber of ties (no weighted):", ties, - "\nNodes set(s):", paste(nodes, collapse = " "), - "\nIt is a", ifelse(length(nodes) == 2, "two-mode", "one-mode"), - "and", ifelse(directed, "directed", "undirected"), "network\n") + cat( + "Dimensions:", paste(dim(x), collapse = " "), + "\nNumber of ties (no weighted):", ties, + "\nNodes set(s):", paste(nodes, collapse = " "), + "\nIt is a", ifelse(length(nodes) == 2, "two-mode", "one-mode"), + "and", ifelse(directed, "directed", "undirected"), "network\n" + ) - if (!is.null(events) && any(events != "")) + if (!is.null(events) && any(events != "")) { cat("Linked events:", paste(events, collapse = ", "), "\n") + } cat("\n") attributes(x)[c("class", "events", "nodes", "directed")] <- NULL @@ -285,10 +300,13 @@ print.network.goldfish <- function(x, ..., full = FALSE, n = 6L) { print.dependent.goldfish <- function(x, ..., full = FALSE, n = 6) { nodes <- attr(x, "nodes") defaultNetwork <- attr(x, "defaultNetwork") - cat("Number of events:", nrow(x), - "\nNodes set(s):", paste(nodes, collapse = " "), "\n") - if (!is.null(defaultNetwork) && defaultNetwork != "") + cat( + "Number of events:", nrow(x), + "\nNodes set(s):", paste(nodes, collapse = " "), "\n" + ) + if (!is.null(defaultNetwork) && defaultNetwork != "") { cat("Default network:", defaultNetwork, "\n") + } cat("\n") attributes(x)[c("nodes", "defaultNetwork", "type")] <- NULL @@ -366,7 +384,8 @@ print.preprocessed.goldfish <- function(x, ..., width = getOption("width")) { wrap <- paste(wrap, collapse = paste0("\n", strrep(" ", mxName + 1))) cat(wrap) cat("\n") - }) + } + ) invisible(NULL) } @@ -381,9 +400,7 @@ generics::tidy #' @export tidy.result.goldfish <- function( x, conf.int = FALSE, conf.level = 0.95, - compact = TRUE, complete = FALSE, ... -) { - + compact = TRUE, complete = FALSE, ...) { isFixed <- GetFixed(x) coefMat <- summary.result.goldfish(x)$coefMat colnames(coefMat) <- c("estimate", "std.error", "statistic", "p.value") @@ -397,18 +414,21 @@ tidy.result.goldfish <- function( terms <- paste( x$names[, 1], rownames(x$names), - if (ncol(x$names) > 2) apply(x$names[, -1], 1, paste, collapse = " ") - else x$names[, -1] - ) + if (ncol(x$names) > 2) { + apply(x$names[, -1], 1, paste, collapse = " ") + } else { + x$names[, -1] + } + ) terms <- trimws(terms) - terms <- gsub("\\$"," ", terms) + terms <- gsub("\\$", " ", terms) if (!complete) terms <- terms[!isFixed] terms <- cbind(term = terms) } else { terms <- cbind(term = rownames(x$names), x$names) - terms[, "Object"] <- gsub("\\$"," ", terms[, "Object"]) + terms[, "Object"] <- gsub("\\$", " ", terms[, "Object"]) if (!complete) terms <- terms[!isFixed, ] } diff --git a/R/functions_parsing.R b/R/functions_parsing.R index 808f7c2..0b196ef 100644 --- a/R/functions_parsing.R +++ b/R/functions_parsing.R @@ -21,13 +21,14 @@ #' @examples #' \donttest{ #' calls <- structure( -#' list(time = 1, sender = "a", receiver = "b", replace = 1), -#' class = "dependent.goldfish" -#' ) +#' list(time = 1, sender = "a", receiver = "b", replace = 1), +#' class = "dependent.goldfish" +#' ) #' callNetwork <- structure(matrix(0, 3, 3), class = "network.goldfish") #' #' parseFormula( -#' calls ~ outdeg(callNetwork, type="ego") + indeg(callNetwork, type="alter") +#' calls ~ outdeg(callNetwork, type = "ego") + +#' indeg(callNetwork, type = "alter") #' ) #' } parseFormula <- function(formula, envir = new.env()) { @@ -35,7 +36,9 @@ parseFormula <- function(formula, envir = new.env()) { depName <- getDependentName(formula) if (!inherits(get(depName, envir = envir), "dependent.goldfish")) { stop("The left hand side of the formula should contain dependent events", - " (check the function defineDependentEvents).", call. = FALSE) + " (check the function defineDependentEvents).", + call. = FALSE + ) } # check right side rhsNames <- getRHSNames(formula) @@ -72,10 +75,12 @@ parseFormula <- function(formula, envir = new.env()) { mult <- parseMultipleEffects(rhsNames, envir = envir) rhsNames <- mult[[1]] ignoreRepParameter <- mult[[2]] - # check mismatch with default parameter + # check mismatch with default parameter if (any(unlist(ignoreRepParameter)) && is.null(defaultNetworkName)) { stop("No default network defined, thus ", dQuote("ignoreRep = TRUE"), - " effects cannot be used.", call. = FALSE) + " effects cannot be used.", + call. = FALSE + ) } # check right side: weighted parameter weightedParameter <- lapply(rhsNames, function(x) { @@ -91,10 +96,11 @@ parseFormula <- function(formula, envir = new.env()) { getFunName <- function(x, which) { v <- getElement(x, which) v <- ifelse(!is.null(v), v, "") - v <- gsub("['\" ]", "", v) # replace quotation marks + v <- gsub("['\" ]", "", v) # replace quotation marks v <- ifelse( grepl("function.?\\(", v) || nchar(v) > 12, - "userDefined", v) # if it is a function, it is replace by short text + "userDefined", v + ) # if it is a function, it is replace by short text } transParameter <- lapply(rhsNames, getFunName, "transformFun") aggreParameter <- lapply(rhsNames, getFunName, "aggregateFun") @@ -137,34 +143,38 @@ parseFormula <- function(formula, envir = new.env()) { # are new, and with the # the index of the effect in the old formula if the effect was already there compareFormulas <- function( - oldparsedformula, newparsedformula, model, subModel -) { - + oldparsedformula, newparsedformula, model, subModel) { # test dependent events and default network if (oldparsedformula$depName != newparsedformula$depName) { - stop("The dependent events in the formula are not the ones used in", - " the preprocessed object given in preprocessingInit.") + stop( + "The dependent events in the formula are not the ones used in", + " the preprocessed object given in preprocessingInit." + ) } if (!identical( oldparsedformula$defaultNetworkName, newparsedformula$defaultNetworkName )) { - stop("The default network in the formula is not the one used in", - " the preprocessed object given in preprocessingInit.") + stop( + "The default network in the formula is not the one used in", + " the preprocessed object given in preprocessingInit." + ) } # test the right-censoring # for now it's easier to just reject inconsistent formulas, otherwise, # we would need go in the details of the RC intervals and updates oldhasIntercept <- oldparsedformula$hasIntercept newhasIntercept <- newparsedformula$hasIntercept - if (model %in% "DyNAM" && subModel %in% c("choice", "choice_coordination") - && oldhasIntercept) { + if (model %in% "DyNAM" && subModel %in% c("choice", "choice_coordination") && + oldhasIntercept) { oldhasIntercept <- FALSE newhasIntercept <- FALSE } if (oldhasIntercept && !newhasIntercept) { - stop("The preprocessing for the object in preprocessingInit was not done", - " with the right-censored intervals that this formula requires.") + stop( + "The preprocessing for the object in preprocessingInit was not done", + " with the right-censored intervals that this formula requires." + ) } if (!oldhasIntercept && newhasIntercept) { stop( @@ -234,23 +244,28 @@ createEffectsFunctions <- function(effectInit, model, subModel, FUN <- tryCatch( eval(parse(text = funText), envir = environment()), error = function(e) NULL - ) + ) # FUN <- NULL if (is.null(FUN)) { - tryCatch({ - FUN <- eval(parse(text = x[[1]]), envir = envir) - }, - error = function(e) stop("Unknown effect ", x[[1]]) # , - # finally = warning("Effect ") + tryCatch( + { + FUN <- eval(parse(text = x[[1]]), envir = envir) + }, + error = function(e) stop("Unknown effect ", x[[1]]) # , + # finally = warning("Effect ") ) } # collect update functions for stat - .FUNStat <- utils::getS3method(.statMethod, x[[1]], optional = TRUE, - envir = environment()) + .FUNStat <- utils::getS3method(.statMethod, x[[1]], + optional = TRUE, + envir = environment() + ) if (is.null(.FUNStat)) { - .FUNStat <- utils::getS3method(.statMethod, "default", optional = TRUE, - envir = envir) + .FUNStat <- utils::getS3method(.statMethod, "default", + optional = TRUE, + envir = envir + ) } # Update signatures of the effects based on default parameters @@ -289,12 +304,14 @@ createEffectsFunctions <- function(effectInit, model, subModel, eval(.signature[["network"]], envir = envir), "nodes" )) > 1 if (!is.null(parmsToSet[["isTwoMode"]]) && - eval(parmsToSet[["isTwoMode"]], envir = envir) != isTwoMode) { + eval(parmsToSet[["isTwoMode"]], envir = envir) != isTwoMode) { warning( "The \"isTwoMode\" parameter in effect ", x[[1]], " has a different value than", " the attributes on network argument '", - x[[2]], "'", call. = FALSE, immediate. = TRUE) + x[[2]], "'", + call. = FALSE, immediate. = TRUE + ) } else if (isTwoMode && is.null(parmsToSet[["isTwoMode"]])) { .signature[["isTwoMode"]] <- isTwoMode warning( @@ -336,7 +353,6 @@ createEffectsFunctions <- function(effectInit, model, subModel, # create new events lists when a window should be applied createWindowedEvents <- function(objectEvents, window) { - # create dissolution events # - for increment, add the opposite increment # - for replace, replace by 0 @@ -386,8 +402,7 @@ getDependentName <- function(formula) { getEventsAndObjectsLink <- function( depName, rhsNames, nodes = NULL, nodes2 = NULL, - envir = environment() -) { + envir = environment()) { # Find objects (irrespective of where they occur) objectNames <- getDataObjects(rhsNames) @@ -525,7 +540,7 @@ parseIntercept <- function(rhsNames) { tryCatch( v <- as.numeric(rhsNames[[1]][[1]]), warning = function(x) { - } + } ) if (!is.na(v) && v == 1) { intercept <- TRUE @@ -540,8 +555,7 @@ parseIntercept <- function(rhsNames) { # then finds a network object from the other parameters that this is related to # unless a network name is passed to the multiple attribute parseMultipleEffects <- function( - rhsNames, default = FALSE, envir = environment() -) { + rhsNames, default = FALSE, envir = environment()) { multiple <- list() multipleNames <- character(0) for (i in seq_along(rhsNames)) { @@ -549,14 +563,16 @@ parseMultipleEffects <- function( id <- which(names(rhsNames[[i]]) == "ignoreRep") multipleParam <- ifelse(length(id) == 1, rhsNames[[i]][[id]], default) - if (multipleParam %in% c("T", "F", "TRUE", "FALSE")) + if (multipleParam %in% c("T", "F", "TRUE", "FALSE")) { multipleParam <- as.logical(multipleParam) + } if (!multipleParam) { table <- getDataObjects(rhsNames[i]) netIds <- vapply(getElementFromDataObjectTable(table, envir = envir), - FUN = inherits, - FUN.VALUE = logical(1), - what = "network.goldfish") + FUN = inherits, + FUN.VALUE = logical(1), + what = "network.goldfish" + ) name <- table[netIds, "name"][1] # take first network # apply(getDataObjects(rhsNames) # netIds <- sapply(, function(x) "network.goldfish" %in% class(get(x))) @@ -568,8 +584,9 @@ parseMultipleEffects <- function( multipleParam <- FALSE } - if (!is.na(name) && name != "" && !exists(name, envir = envir)) + if (!is.na(name) && name != "" && !exists(name, envir = envir)) { stop("Unknown object in 'ignoreRep' parameter: ", name, call. = FALSE) + } multiple <- append(multiple, multipleParam) multipleNames <- c(multipleNames, name) @@ -587,7 +604,7 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { hasWindows <- which( vapply(rhsNames, function(x) !is.null(getElement(x, "window")), logical(1)) - ) + ) for (i in hasWindows) { windowName <- rhsNames[[i]]$window @@ -597,7 +614,8 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { e$message <- paste( "Invalid window parameter for effect ", rhsNames[[i]][[1]], " ", rhsNames[[i]][[2]], - ":\n", e$message) + ":\n", e$message + ) stop(e) } ) @@ -608,18 +626,21 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { # support for lubridate object classes for date operations if (inherits(window, c("Period", "Duration")) && - "lubridate" %in% attr(attr(window, "class"), "package")) { + "lubridate" %in% attr(attr(window, "class"), "package")) { if (!isValidName) { windowName <- gsub("\\s", "", as.character(window)) - if (inherits(window, "Duration")) - windowName <- gsub("^(\\d+s)\\s*(\\(.+\\))$", "\\1", - as.character(window)) + if (inherits(window, "Duration")) { + windowName <- gsub( + "^(\\d+s)\\s*(\\(.+\\))$", "\\1", + as.character(window) + ) } + } } else if (inherits(window, "character")) { if (!isValidName) windowName <- gsub(" ", "", window) if (!is.numeric(window) && - !grepl("^\\d+ (sec|min|hour|day|week|month|year)", window)) { + !grepl("^\\d+ (sec|min|hour|day|week|month|year)", window)) { stop( "The window effect specified with the effect ", rhsNames[[i]][[1]], " ", rhsNames[[i]][[2]], " is not in the form 'number unit'\n", @@ -652,11 +673,13 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { } } else if (is.numeric(window)) { # check numeric type - if (window < 0) + if (window < 0) { stop( "The window specified with the effect ", rhsNames[[i]][[1]], " ", rhsNames[[i]][[2]], - " is not a positive numeric value") + " is not a positive numeric value" + ) + } } @@ -672,8 +695,8 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { # newRhs[[2]] <- paste(rhsNames[[i]][[2]], window, sep="_") # rhsNames[[length(rhsNames)+1]] <- newRhs rhsNames[[i]][[2]] <- paste(rhsNames[[i]][[2]], - windowName, - sep = "_" + windowName, + sep = "_" ) @@ -691,7 +714,6 @@ parseTimeWindows <- function(rhsNames, envir = new.env()) { allDynamicAttributes <- attr(nodes, "dynamicAttributes") allEvents <- allEvents[allDynamicAttributes == attribute] } else { - # get network, create windowed network, get related events # to be windowed later network <- get(name, envir = envir) diff --git a/R/functions_postestimate.R b/R/functions_postestimate.R index 2446023..e8fe94a 100644 --- a/R/functions_postestimate.R +++ b/R/functions_postestimate.R @@ -1,4 +1,3 @@ - #' Extract model coefficients from estimate output #' #' Return a named vector with the estimated coefficients returned by `estimate`. @@ -29,15 +28,20 @@ #' # A multinomial receiver choice model #' 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) +#' callNetwork <- linkEvents( +#' x = callNetwork, changeEvent = calls, +#' nodes = actors +#' ) +#' callsDependent <- defineDependentEvents( +#' events = calls, nodes = actors, +#' defaultNetwork = callNetwork +#' ) #' \dontshow{ #' callsDependent <- callsDependent[1:50, ] #' } #' mod01 <- estimate(callsDependent ~ inertia + recip + trans, -#' model = "DyNAM", subModel = "choice") +#' model = "DyNAM", subModel = "choice" +#' ) #' coef(mod01) coef.result.goldfish <- function(object, ..., complete = FALSE) { result <- object$parameters diff --git a/R/functions_preprocessing.R b/R/functions_preprocessing.R index 27a010c..0297fba 100644 --- a/R/functions_preprocessing.R +++ b/R/functions_preprocessing.R @@ -23,26 +23,25 @@ #' #' @noRd preprocess <- function( - model, - subModel, - events, - effects, - windowParameters, - ignoreRepParameter, - eventsObjectsLink, - eventsEffectsLink, - objectsEffectsLink, - # multipleParameter, - nodes, - nodes2 = nodes, - isTwoMode, - # add more parameters - startTime = min(vapply(events, function(x) min(x$time), double(1))), - endTime = max(vapply(events, function(x) max(x$time), double(1))), - rightCensored = FALSE, - progress = FALSE, - prepEnvir = new.env()) { - + model, + subModel, + events, + effects, + windowParameters, + ignoreRepParameter, + eventsObjectsLink, + eventsEffectsLink, + objectsEffectsLink, + # multipleParameter, + nodes, + nodes2 = nodes, + isTwoMode, + # add more parameters + startTime = min(vapply(events, function(x) min(x$time), double(1))), + endTime = max(vapply(events, function(x) max(x$time), double(1))), + rightCensored = FALSE, + progress = FALSE, + prepEnvir = new.env()) { # For debugging # if (identical(environment(), globalenv())) { # startTime <- min(vapply(events, function(x) min(x$time), double(1))) @@ -84,10 +83,11 @@ preprocess <- function( if (any(isWindowEffect)) hasEndTime <- TRUE } else if (endTime != eventsMax) { if (!is.numeric(endTime)) endTime <- as.numeric(endTime) - if (eventsMin > endTime) + if (eventsMin > endTime) { stop("End time smaller than first event time.", call. = FALSE) - # to solve: if endTime > eventsMax - # should it produce censored events? warning? + } + # to solve: if endTime > eventsMax + # should it produce censored events? warning? # add a fake event to the event list # endTimeEvent <- data.frame( # time = endTime, @@ -102,8 +102,9 @@ preprocess <- function( startTime <- eventsMin } else if (startTime != eventsMin) { if (!is.numeric(startTime)) startTime <- as.numeric(startTime) - if (eventsMax < startTime) + if (eventsMax < startTime) { stop("Start time geater than last event time.", call. = FALSE) + } hasStartTime <- TRUE if (eventsMin < startTime) isValidEvent <- FALSE # if (eventsMin > startTime) isValidEvent <- TRUE @@ -119,7 +120,8 @@ preprocess <- function( statCache <- initializeCacheStat( objectsEffectsLink = objectsEffectsLink, effects = effects, groupsNetwork = NULL, windowParameters = windowParameters, - n1 = n1, n2 = n2, model = model, subModel = subModel, envir = prepEnvir) + n1 = n1, n2 = n2, model = model, subModel = subModel, envir = prepEnvir + ) # We put the initial stats to the previous format of 3 dimensional array initialStats <- array( unlist(lapply(statCache, "[[", "stat")), @@ -142,12 +144,13 @@ preprocess <- function( time <- unique(events[[1]]$time) if (rightCensored) { nRightCensoredEvents <- unique(unlist(lapply(events, function(x) x$time))) - nTotalEvents <- as.integer(sum(nRightCensoredEvents <= endTime)) + nTotalEvents <- as.integer(sum(nRightCensoredEvents <= endTime)) nRightCensoredEvents <- setdiff(nRightCensoredEvents, time) if (length(nRightCensoredEvents) > 1) { nRightCensoredEvents <- as.integer(sum( nRightCensoredEvents >= startTime & - nRightCensoredEvents <= endTime) - 1) + nRightCensoredEvents <= endTime + ) - 1) } else { nRightCensoredEvents <- 0L } @@ -159,7 +162,8 @@ preprocess <- function( nDependentEvents <- ifelse( hasStartTime || hasEndTime, as.integer(sum(time >= startTime & time <= endTime)), - as.integer(length(time))) + as.integer(length(time)) + ) # CHANGED ALVARO: preallocate objects sizes dependentStatistics <- vector("list", nDependentEvents) timeIntervals <- vector("numeric", ifelse(rightCensored, nDependentEvents, 0)) @@ -183,8 +187,9 @@ preprocess <- function( # callDependent(439*4), calls(439*4), friendship(766*4)) pointers <- rep(1, length(events)) validPointers <- rep(TRUE, length(events)) - if (hasEndTime) + if (hasEndTime) { validPointers <- vapply(events, function(x) x$time[1], double(1)) <= endTime + } pointerTempRightCensored <- 1L time <- startTime interval <- 0L @@ -214,7 +219,7 @@ preprocess <- function( nextEventTime <- times[nextEvent] if (hasStartTime || hasEndTime) { if (isValidEvent && nextEventTime <= endTime) { - interval <- nextEventTime - time + interval <- nextEventTime - time } else if (isValidEvent && nextEventTime > endTime) { interval <- endTime - time nextEventTime <- endTime @@ -260,7 +265,7 @@ preprocess <- function( iDependentEvents <- 1L + iDependentEvents dependentStatistics[[iDependentEvents]] <- updatesDependent if (rightCensored) timeIntervals[[iDependentEvents]] <- interval - # timeIntervals[[iDependentEvents]] # correct it for not rate models + # timeIntervals[[iDependentEvents]] # correct it for not rate models updatesDependent <- vector("list", nEffects) updatesIntervals <- vector("list", nEffects) # CHANGED MARION: added orderEvents @@ -277,14 +282,13 @@ preprocess <- function( event_sender[[eventPos]] <- event$sender event_receiver[[eventPos]] <- event$receiver } - } else if (!isDependent) { # 2. store statistic updates for RIGHT-CENSORED # (non-dependent, positive) intervals if (isValidEvent && rightCensored && interval > 0) { # CHANGED MARION: the incremented index was incorrect - #rightCensoredStatistics[[ pointers[nextEvent] ]] <- updatesIntervals - #timeIntervalsRightCensored[[length(rightCensoredStatistics)]] <- + # rightCensoredStatistics[[ pointers[nextEvent] ]] <- updatesIntervals + # timeIntervalsRightCensored[[length(rightCensoredStatistics)]] <- # interval rightCensoredStatistics[[pointerTempRightCensored]] <- updatesIntervals timeIntervalsRightCensored[[pointerTempRightCensored]] <- interval @@ -327,7 +331,8 @@ preprocess <- function( objectNameTable <- eventsObjectsLink[nextEvent, -1] objectName <- objectNameTable$name object <- getElementFromDataObjectTable( - objectNameTable, envir = prepEnvir + objectNameTable, + envir = prepEnvir )[[1]] isUndirectedNet <- FALSE if (inherits(object, "network.goldfish")) { @@ -376,107 +381,117 @@ preprocess <- function( ## 3a. calculate statistics changes - if (!finalStep) + if (!finalStep) { for (id in which(!is.na(eventsEffectsLink[nextEvent, ]))) { - # create the ordered list for the objects - objectsToPass <- objectsEffectsLink[, id][ - !is.na(objectsEffectsLink[, id])] - names <- rownames(objectsEffectsLink)[!is.na(objectsEffectsLink[, id])] - orderedNames <- names[order(objectsToPass)] - orderedObjectTable <- getDataObjects(list(list("", orderedNames))) - .objects <- getElementFromDataObjectTable( - orderedObjectTable, - envir = prepEnvir - ) - # identify class to feed effects functions - objCat <- assignCatToObject(.objects) - attIDs <- which(objCat == "attribute") - netIDs <- which(objCat == "network") - if (attr(objCat, "noneClass")) - stop("An object is not assigned either as network or attibute", - paste(names[attr(objCat, "manyClasses") != 1], collapse = ", "), - "check the class of the object.", call. = FALSE) - - # call effects function with required arguments - .argsFUN <- list( - network = if (length(.objects[netIDs]) == 1) { - .objects[netIDs][[1]] - } else { - .objects[netIDs] - }, - attribute = if (length(.objects[attIDs]) == 1) { - .objects[attIDs][[1]] - } else { - .objects[attIDs] - }, - cache = statCache[[id]], - n1 = n1, - n2 = n2, - netUpdate = if (length(.objects[netIDs]) == 1) { - NULL - } else { - which(orderedNames == objectName) - }, - attUpdate = if (length(.objects[attIDs]) == 1) { - NULL - } else { - which(orderedNames == objectName) + # create the ordered list for the objects + objectsToPass <- objectsEffectsLink[, id][ + !is.na(objectsEffectsLink[, id]) + ] + names <- rownames(objectsEffectsLink) + names <- names[!is.na(objectsEffectsLink[, id])] + orderedNames <- names[order(objectsToPass)] + orderedObjectTable <- getDataObjects(list(list("", orderedNames))) + .objects <- getElementFromDataObjectTable( + orderedObjectTable, + envir = prepEnvir + ) + # identify class to feed effects functions + objCat <- assignCatToObject(.objects) + attIDs <- which(objCat == "attribute") + netIDs <- which(objCat == "network") + if (attr(objCat, "noneClass")) { + stop("An object is not assigned either as network or attibute", + paste(names[attr(objCat, "manyClasses") != 1], collapse = ", "), + "check the class of the object.", + call. = FALSE + ) } - ) - - effectUpdate <- callFUN( - effects, id, "effect", c(.argsFUN, event), " cannot update \n", - colnames(objectsEffectsLink)[id] - ) - updates <- effectUpdate$changes - # if cache and changes are not null update cache - if (!is.null(effectUpdate$cache) && !is.null(effectUpdate$changes)) { - statCache[[id]] <- effectUpdate$cache - } + # call effects function with required arguments + .argsFUN <- list( + network = if (length(.objects[netIDs]) == 1) { + .objects[netIDs][[1]] + } else { + .objects[netIDs] + }, + attribute = if (length(.objects[attIDs]) == 1) { + .objects[attIDs][[1]] + } else { + .objects[attIDs] + }, + cache = statCache[[id]], + n1 = n1, + n2 = n2, + netUpdate = if (length(.objects[netIDs]) == 1) { + NULL + } else { + which(orderedNames == objectName) + }, + attUpdate = if (length(.objects[attIDs]) == 1) { + NULL + } else { + which(orderedNames == objectName) + } + ) - if (isUndirectedNet) { - event2 <- event - event2$sender <- event$receiver - event2$receiver <- event$sender - if (!is.null(effectUpdate$cache) && !is.null(effectUpdate$changes)) - .argsFUN$cache <- statCache[[id]] - effectUpdate2 <- callFUN( - effects, id, "effect", c(.argsFUN, event2), " cannot update \n", + effectUpdate <- callFUN( + effects, id, "effect", c(.argsFUN, event), " cannot update \n", colnames(objectsEffectsLink)[id] ) - if (!is.null(effectUpdate2$cache) && !is.null(effectUpdate2$changes)) - statCache[[id]] <- effectUpdate2$cache - updates2 <- effectUpdate2$changes - updates <- rbind(updates, updates2) - } + updates <- effectUpdate$changes + # if cache and changes are not null update cache + if (!is.null(effectUpdate$cache) && !is.null(effectUpdate$changes)) { + statCache[[id]] <- effectUpdate$cache + } - if (!is.null(updates)) { - if (hasStartTime && nextEventTime < startTime) { - initialStats[cbind(updates[, "node1"], updates[, "node2"], id)] <- - updates[, "replace"] - } else { - # CHANGED WEIGUTIAN: UPDATE THE STAT MAT - # AND IMPUTE THE MISSING VALUES - # if (anyNA(statCache[[id]][["stat"]])) { - # position_NA <- which( - # is.na(statCache[[id]][["stat"]]), - # arr.ind = TRUE - # ) - # average <- mean(statCache[[id]][["stat"]], na.rm = TRUE) - # updates[is.na(updates[, "replace"]), "replace"] <- average - # statCache[[id]][["stat"]][position_NA] <- average - # } - - updatesDependent[[id]] <- ReduceUpdateNonDuplicates( - updatesDependent[[id]], - updates - ) - updatesIntervals[[id]] <- ReduceUpdateNonDuplicates( - updatesIntervals[[id]], - updates + if (isUndirectedNet) { + event2 <- event + event2$sender <- event$receiver + event2$receiver <- event$sender + if (!is.null(effectUpdate$cache) && + !is.null(effectUpdate$changes)) { # styler: off + .argsFUN$cache <- statCache[[id]] + } + effectUpdate2 <- callFUN( + effects, id, "effect", c(.argsFUN, event2), " cannot update \n", + colnames(objectsEffectsLink)[id] ) + + if (!is.null(effectUpdate2$cache) && + !is.null(effectUpdate2$changes)) { # styler: off + statCache[[id]] <- effectUpdate2$cache + } + updates2 <- effectUpdate2$changes + updates <- rbind(updates, updates2) + } + + if (!is.null(updates)) { + if (hasStartTime && nextEventTime < startTime) { + initialStats[cbind(updates[, "node1"], updates[, "node2"], id)] <- + updates[, "replace"] + } else { + # CHANGED WEIGUTIAN: UPDATE THE STAT MAT + # AND IMPUTE THE MISSING VALUES + # if (anyNA(statCache[[id]][["stat"]])) { + # position_NA <- which( + # is.na(statCache[[id]][["stat"]]), + # arr.ind = TRUE + # ) + # average <- mean(statCache[[id]][["stat"]], na.rm = TRUE) + # updates[is.na(updates[, "replace"]), "replace"] <- average + # statCache[[id]][["stat"]][position_NA] <- average + # } + + updatesDependent[[id]] <- ReduceUpdateNonDuplicates( + updatesDependent[[id]], + updates + ) + updatesIntervals[[id]] <- ReduceUpdateNonDuplicates( + updatesIntervals[[id]], + updates + ) + } } } } @@ -494,7 +509,8 @@ preprocess <- function( # Assign object assign("object", object, envir = prepEnvir) eval(parse(text = paste(objectName, "<- object")), - envir = prepEnvir, enclos = parent.frame()) + envir = prepEnvir, enclos = parent.frame() + ) } } # end 3. (!dependent) @@ -508,21 +524,22 @@ preprocess <- function( close(pb) } - return(structure(list( - initialStats = initialStats, - dependentStatsChange = dependentStatistics, - rightCensoredStatsChange = rightCensoredStatistics, - intervals = timeIntervals, - # CHANGED MARION - rightCensoredIntervals = timeIntervalsRightCensored, - orderEvents = orderEvents, - eventTime = event_time, - eventSender = event_sender, - eventReceiver = event_receiver, - startTime = startTime, - endTime = endTime - ), - class = "preprocessed.goldfish" + return(structure( + list( + initialStats = initialStats, + dependentStatsChange = dependentStatistics, + rightCensoredStatsChange = rightCensoredStatistics, + intervals = timeIntervals, + # CHANGED MARION + rightCensoredIntervals = timeIntervalsRightCensored, + orderEvents = orderEvents, + eventTime = event_time, + eventSender = event_sender, + eventReceiver = event_receiver, + startTime = startTime, + endTime = endTime + ), + class = "preprocessed.goldfish" )) } @@ -543,25 +560,27 @@ preprocess <- function( #' #' @noRd initializeCacheStat <- function( - objectsEffectsLink, effects, - groupsNetwork, windowParameters, - n1, n2, - model, subModel, envir = environment()) { + objectsEffectsLink, effects, + groupsNetwork, windowParameters, + n1, n2, + model, subModel, envir = environment()) { objTable <- getDataObjects(list(rownames(objectsEffectsLink)), - removeFirst = FALSE + removeFirst = FALSE ) .objects <- getElementFromDataObjectTable(objTable, envir = envir) # list of 4, call matrix, friendship matrix, actor$gradetype vector, # actor$floor vector objCat <- assignCatToObject(.objects) - if (attr(objCat, "noneClass")) + if (attr(objCat, "noneClass")) { stop( "An object is not assigned either as network or attibute", paste(rownames(objectsEffectsLink)[attr(objCat, "manyClasses") != 1], - collapse = ", "), + collapse = ", " + ), "check the class of the object.", call. = FALSE ) + } # objects: list of 6, each element is a 84*84 matrix objectsRet <- lapply( @@ -584,8 +603,11 @@ initializeCacheStat <- function( .argsFUN <- list( effectFun = effects[[iEff]][["effect"]], network = if (length(networks) == 1) networks[[1]] else networks, - attribute = if (length(attributes) == 1) - attributes[[1]] else attributes, + attribute = if (length(attributes) == 1) { + attributes[[1]] + } else { + attributes + }, groupsNetwork = groupsNetwork, window = windowParameters[[iEff]], n1 = n1, @@ -622,7 +644,7 @@ initializeCacheStat <- function( #' network = m, #' n1 = 5, n2 = 5, #' sender = 1, receiver = 5, replace = 0 -#' ) +#' ) #' effects <- list(list(effect = out)) #' #' ver2 <- callFUN( @@ -639,7 +661,7 @@ initializeCacheStat <- function( #' effects = effects, effectPos = effectPos, effectType = "effect", #' .argsFUN = .argsFUN, textMss = " ver ", #' effectLabel = "out" -#' ) +#' ) #' } callFUN <- function( effects, effectPos, effectType, .argsFUN, textMss, @@ -648,29 +670,33 @@ callFUN <- function( warn <- NULL .argsNames <- formals(effects[[effectPos]][[effectType]]) .argsKeep <- pmatch(names(.argsNames), names(.argsFUN)) - # check for more than one net + # check for more than one net errorHandler <- function(e) { erro <- simpleError( paste0( "Effect ", dQuote(effectLabel), - " (", effectPos, ") ", textMss, e$message) + " (", effectPos, ") ", textMss, e$message + ) ) stop(erro) } - tryCatch({ - withCallingHandlers({ - callRes <- do.call( - effects[[effectPos]][[effectType]], - .argsFUN[na.omit(.argsKeep)] - )}, - error = identity, - warning = function(w) { - warn <<- w - invokeRestart("muffleWarning") - } - ) - }, - error = errorHandler + tryCatch( + { + withCallingHandlers( + { + callRes <- do.call( + effects[[effectPos]][[effectType]], + .argsFUN[na.omit(.argsKeep)] + ) + }, + error = identity, + warning = function(w) { + warn <<- w + invokeRestart("muffleWarning") + } + ) + }, + error = errorHandler ) if (!is.null(warn)) warning(warn) return(callRes) @@ -713,9 +739,12 @@ callFUN <- function( #' ) #' #' objectsEffectsLink <- matrix( -#' c(1, NA, NA, 1), nrow = 2, ncol = 2, -#' dimnames = list(c("networkAlgo", "actorsEx$attr1"), -#' c("inertia", "alter")) +#' c(1, NA, NA, 1), +#' nrow = 2, ncol = 2, +#' dimnames = list( +#' c("networkAlgo", "actorsEx$attr1"), +#' c("inertia", "alter") +#' ) #' ) #' prepEnvir <- environment() #' @@ -724,7 +753,8 @@ callFUN <- function( imputeMissingData <- function(objectsEffectsLink, envir = new.env()) { # get data object table, row objects columns class (matrix, attribute) objTable <- getDataObjects(list(rownames(objectsEffectsLink)), - removeFirst = FALSE) + removeFirst = FALSE + ) # print(objTable) done <- structure(vector("logical", nrow(objTable)), names = objTable$name) for (iEff in seq_len(nrow(objTable))) { @@ -746,7 +776,8 @@ imputeMissingData <- function(objectsEffectsLink, envir = new.env()) { # Assign object assign("object", object, envir = envir) eval(parse(text = paste(objectName, "<- object")), - envir = envir, enclos = parent.frame()) + envir = envir, enclos = parent.frame() + ) } } return(done) diff --git a/R/functions_preprocessing_interaction.R b/R/functions_preprocessing_interaction.R index 12a6e4d..75e7310 100644 --- a/R/functions_preprocessing_interaction.R +++ b/R/functions_preprocessing_interaction.R @@ -16,24 +16,23 @@ #' #' @noRd preprocessInteraction <- function( - subModel, - events, - effects, - eventsObjectsLink, - eventsEffectsLink, - objectsEffectsLink, - # multipleParameter, - nodes, - nodes2 = nodes, - # add more parameters - startTime = min(vapply(events, function(x) min(x$time), double(1))), - endTime = max(vapply(events, function(x) max(x$time), double(1))), - rightCensored = FALSE, - progress = FALSE, - groupsNetwork = groupsNetwork, - prepEnvir = environment()) { - -# For debugging + subModel, + events, + effects, + eventsObjectsLink, + eventsEffectsLink, + objectsEffectsLink, + # multipleParameter, + nodes, + nodes2 = nodes, + # add more parameters + startTime = min(vapply(events, function(x) min(x$time), double(1))), + endTime = max(vapply(events, function(x) max(x$time), double(1))), + rightCensored = FALSE, + progress = FALSE, + groupsNetwork = groupsNetwork, + prepEnvir = environment()) { + # For debugging # if (identical(environment(), globalenv())) { # startTime <- min(vapply(events, function(x) min(x$time), double(1))) # endTime <- max(vapply(events, function(x) max(x$time), double(1))) @@ -56,11 +55,12 @@ preprocessInteraction <- function( stats <- initializeCacheStat( objectsEffectsLink = objectsEffectsLink, effects = effects, groupsNetwork = groupsNetworkObject, windowParameters = NULL, - n1 = n1, n2 = n2, model = model, subModel = subModel, envir = prepEnvir) + n1 = n1, n2 = n2, model = model, subModel = subModel, envir = prepEnvir + ) # We put the initial stats to the previous format of 3 dimensional array initialStats <- array(unlist(stats), - dim = c(n1, n2, nEffects) + dim = c(n1, n2, nEffects) ) # statCache <- lapply(statCache, "[[", "cache") @@ -90,21 +90,23 @@ preprocessInteraction <- function( hasEndTime <- FALSE eventsMin <- min(vapply(events, function(x) min(x$time), double(1))) eventsMax <- max(vapply(events, function(x) max(x$time), double(1))) - if (!is.null(endTime) && endTime != eventsMax) + if (!is.null(endTime) && endTime != eventsMax) { stop( dQuote("DyNAMi"), " doesn't support setting the ", dQuote("endTime"), "parameter", call. = FALSE ) + } - if (!is.null(startTime) && startTime != eventsMin) + if (!is.null(startTime) && startTime != eventsMin) { stop( dQuote("DyNAMi"), " doesn't support setting the ", dQuote("StartTime"), "parameter", call. = FALSE ) + } # initialize loop parameters events[[1]] <- NULL @@ -136,15 +138,15 @@ preprocessInteraction <- function( for (e in seq.int(length(events))) { ev <- events[[e]] if (inherits(ev, "interaction.groups.updates") && - all(get(dname, envir = prepEnvir) == ev)) { + all(get(dname, envir = prepEnvir) == ev)) { depindex <- e deporder <- attr(ev, "order") } else if (inherits(ev, "interaction.groups.updates") && - !all(get(dname, envir = prepEnvir) == ev)) { + !all(get(dname, envir = prepEnvir) == ev)) { exoindex <- e exoorder <- attr(ev, "order") } else if (inherits(ev, "interaction.network.updates") && - !is.null(attr(ev, "order"))) { + !is.null(attr(ev, "order"))) { numpast <- numpast + 1 pastindexes[numpast] <- e pastorders[[numpast]] <- attr(ev, "order") @@ -156,20 +158,21 @@ preprocessInteraction <- function( # (because there was no effect with the default network) # we need to find them anyway! if (depindex == 0) { - # find groups udates and add them to events groupsupdates <- attr(groupsNetworkObject, "events") # PATCH Marion: the groups update events were not sanitized groupsupdates1Object <- sanitizeEvents( - get(groupsupdates[1], envir = prepEnvir), nodes, nodes2) + get(groupsupdates[1], envir = prepEnvir), nodes, nodes2 + ) assign(groupsupdates[1], groupsupdates1Object, envir = prepEnvir) groupsupdates2Object <- sanitizeEvents( - get(groupsupdates[2], envir = prepEnvir), nodes, nodes2) + get(groupsupdates[2], envir = prepEnvir), nodes, nodes2 + ) assign(groupsupdates[2], groupsupdates2Object, envir = prepEnvir) if (all(get(dname, envir = prepEnvir) == - get(groupsupdates[1], envir = prepEnvir))) { + get(groupsupdates[1], envir = prepEnvir))) { depn <- groupsupdates[1] exon <- groupsupdates[2] } else { @@ -229,8 +232,10 @@ preprocessInteraction <- function( # added Marion: updates of statistics updFun <- function(stat, change) { - if (!is.null(change)) stat[cbind(change[, "node1"], change[, "node2"])] <- + if (!is.null(change)) { + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -258,7 +263,6 @@ preprocessInteraction <- function( # iterate over all event lists while (any(validPointers)) { - # times: the timepoint for next events to update in all event lists times <- Map(function(e, p) e[p, ]$time, events, pointers) |> vapply(identity, numeric(1)) @@ -303,7 +307,7 @@ preprocessInteraction <- function( if (length(cptindexes) > 1) cptorder <- cptorder - 1 } } - } else {# otherwise we take the first next event + } else { # otherwise we take the first next event nextEvent <- currentpointers[1] } interval <- times[nextEvent] - time @@ -313,7 +317,7 @@ preprocessInteraction <- function( # changed Marion: for choice, only joining events are dependent events isDependent <- (subModel == "rate" && nextEvent == depindex) || (subModel == "choice" && nextEvent == depindex && - events[[depindex]][pointers[nextEvent], "increment"] > 0) + events[[depindex]][pointers[nextEvent], "increment"] > 0) # # CHANGED ALVARO: progress bar if (progress && iDependentEvents %% dotEvents == 0) { @@ -334,7 +338,6 @@ preprocessInteraction <- function( # 1. store statistic updates for DEPENDENT events if (isDependent) { - # first store statistics iDependentEvents <- 1 + iDependentEvents dependentStatistics[[iDependentEvents]] <- updatesDependent @@ -422,8 +425,8 @@ preprocessInteraction <- function( pointerTempRightCensored <- pointerTempRightCensored + 1 } - # 3. update stats and data objects for OBJECT CHANGE EVENTS - # (all non-dependent events) + # 3. update stats and data objects for OBJECT CHANGE EVENTS + # (all non-dependent events) # Two steps are performed for non-dependent events # (0. get objects and update increment columns) @@ -434,11 +437,13 @@ preprocessInteraction <- function( objectNameTable <- eventsObjectsLink[nextEvent + 1, -1] objectName <- objectNameTable$name object <- getElementFromDataObjectTable( - objectNameTable, envir = prepEnvir - )[[1]] + objectNameTable, + envir = prepEnvir + )[[1]] isUndirectedNet <- FALSE - if (inherits(object, "network.goldfish")) + if (inherits(object, "network.goldfish")) { isUndirectedNet <- !attr(object, "directed") + } # # CHANGED ALVARO: avoid dependence in variables position if (isIncrementEvent[nextEvent]) { @@ -449,8 +454,9 @@ preprocessInteraction <- function( event <- events[[nextEvent]][pointers[nextEvent], varsKeep] if (isNodeEvent[nextEvent]) oldValue <- object[event$node] - if (!isNodeEvent[nextEvent]) + if (!isNodeEvent[nextEvent]) { oldValue <- object[event$sender, event$receiver] + } event$replace <- oldValue + event$increment event$increment <- NULL } else { @@ -461,9 +467,9 @@ preprocessInteraction <- function( event <- events[[nextEvent]][pointers[nextEvent], varsKeep] } - #if (!isNodeEvent[nextEvent] && event$replace < 0) { + # if (!isNodeEvent[nextEvent] && event$replace < 0) { # warning("You are dissolving a tie which doesn't exist!", call. = FALSE) - #} + # } # b. Update the data object @@ -499,8 +505,8 @@ preprocessInteraction <- function( # if EXOGENOUS JOINING OR LEAVING, everything is recalculated if (isgroupupdate) { effIds <- seq.int(dim(eventsEffectsLink)[2]) - } else {# OTHERWISE (PAST UPDATE or ATTRIBUTE UPDATE), - # only statistics related to the object + } else { # OTHERWISE (PAST UPDATE or ATTRIBUTE UPDATE), + # only statistics related to the object effIds <- which(!is.na(eventsEffectsLink[nextEvent + 1, ])) } groupsNetworkObject <- get(groupsNetwork, envir = prepEnvir) @@ -564,20 +570,21 @@ preprocessInteraction <- function( close(pb) } - return(structure(list( - initialStats = initialStats, - dependentStatsChange = dependentStatistics, - rightCensoredStatsChange = rightCensoredStatistics, - intervals = timeIntervals, - # CHANGED MARION - rightCensoredIntervals = timeIntervalsRightCensored, - orderEvents = orderEvents, - eventTime = event_time, - eventSender = event_sender, - eventReceiver = event_receiver, - startTime = startTime, - endTime = endTime - ), - class = "preprocessed.goldfish" + return(structure( + list( + initialStats = initialStats, + dependentStatsChange = dependentStatistics, + rightCensoredStatsChange = rightCensoredStatistics, + intervals = timeIntervals, + # CHANGED MARION + rightCensoredIntervals = timeIntervalsRightCensored, + orderEvents = orderEvents, + eventTime = event_time, + eventSender = event_sender, + eventReceiver = event_receiver, + startTime = startTime, + endTime = endTime + ), + class = "preprocessed.goldfish" )) } diff --git a/R/functions_utility.R b/R/functions_utility.R index 264c6fe..acab4c3 100644 --- a/R/functions_utility.R +++ b/R/functions_utility.R @@ -31,7 +31,6 @@ #' 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)) @@ -47,8 +46,9 @@ getDataObjects <- function(namedList, keepOrder = FALSE, removeFirst = TRUE) { # # case list(...) areList <- grepl("list\\(\\s*(.+)\\s*\\)", objNames) .split <- ifelse(areList, - gsub("list\\(\\s*(.+)\\s*\\)", "\\1", objNames), - objNames) + gsub("list\\(\\s*(.+)\\s*\\)", "\\1", objNames), + objNames + ) .split <- unlist(strsplit(.split, split = "\\s*,\\s*")) if (!keepOrder) .split <- unique(.split) @@ -248,7 +248,7 @@ ReducePreprocess <- function( ) if ((preproData$subModel == "rate" || preproData$model == "REM") && - length(preproData$rightCensoredStatsChange) > 0) { + length(preproData$rightCensoredStatsChange) > 0) { rightCensoredStatChange <- ReduceEffUpdates( preproData$rightCensoredStatsChange, preproData$eventTime[preproData$orderEvents == 2] @@ -341,7 +341,7 @@ UpdateNetwork <- function(network, changeEvents, nodes = NULL, nodes2 = nodes) { if (inherits(changeEvents, "matrix") && - all(c("node1", "node2", "replace") %in% colnames(changeEvents))) { + all(c("node1", "node2", "replace") %in% colnames(changeEvents))) { changeEvents <- data.frame(changeEvents) names(changeEvents)[match(c("node1", "node2"), names(changeEvents))] <- c("sender", "receiver") @@ -375,7 +375,8 @@ UpdateNetwork <- function(network, changeEvents, nodes = NULL, nodes2 = nodes) { names(redEvents)[chIncrement] <- "replace" } else if ("replace" %in% names(changeEvents)) { discard <- duplicated(changeEvents[, c("sender", "receiver")], - fromLast = TRUE) + fromLast = TRUE + ) redEvents <- changeEvents[ !discard, c("sender", "receiver", "replace"), @@ -394,21 +395,23 @@ GetDetailPrint <- function( # 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 + 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( + dimnames(effectDescription) <- list( colnames(objectsEffectsLink), if (ncol(effectDescription) == 1) { "Object" @@ -449,7 +452,8 @@ GetDetailPrint <- function( window = vapply( parsedformula$windowParameters, function(x) ifelse(is.null(x), "", gsub("['\"]", "", x)), - character(1)) + character(1) + ) ) # reduce object name effectDescription[, objectsName] <- t(apply( @@ -493,7 +497,7 @@ GetDetailPrint <- function( if (!is.null(fixedParameters)) { effectDescription <- cbind(effectDescription, - fixed = !is.na(fixedParameters) + fixed = !is.na(fixedParameters) ) } @@ -502,11 +506,13 @@ GetDetailPrint <- function( } GetFixed <- function(object) { - if ("fixed" %in% colnames(object$names)) + if ("fixed" %in% colnames(object$names)) { vapply( object$names[, "fixed"], function(x) eval(parse(text = x)), logical(1) ) - else rep(FALSE, length(object$parameters)) + } else { + rep(FALSE, length(object$parameters)) + } } diff --git a/R/testthat-helpers.R b/R/testthat-helpers.R index f6aee52..6a39601 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -23,11 +23,12 @@ m <- matrix( sprintf("Actor %d", 1:5) ) ) -m0 <- matrix(0, nrow = 5, ncol = 5, - dimnames = list( - sprintf("Actor %d", 1:5), - sprintf("Actor %d", 1:5) - ) +m0 <- matrix(0, + nrow = 5, ncol = 5, + dimnames = list( + sprintf("Actor %d", 1:5), + sprintf("Actor %d", 1:5) + ) ) m1 <- matrix( c( @@ -82,8 +83,10 @@ vCache <- c(0, 2, 3, 1, 0) # Attributes ------------------------------------------------------- testAttr <- data.frame( - label = as.factor(c("Christoph", "James", "Per", "Timon", "Marion", "Mepham", - "Xiaolei", "Federica")), + label = as.factor(c( + "Christoph", "James", "Per", "Timon", "Marion", "Mepham", + "Xiaolei", "Federica" + )), fishingSkill = c(10, NA, 5, 10, 8, 8, 3, NA), fishCaught = c(1, 99, 15, 12, 15, 8, 0, 2), fishSizeMean = c(9.9, 0.1, 0.5, 0.45, 0.25, 0.3, NA, 10), @@ -94,8 +97,7 @@ testAttr <- data.frame( effectFUN_tie <- function( network, sender, receiver, replace, - weighted = FALSE, transformFun = identity -) { + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, @@ -106,8 +108,7 @@ effectFUN_tie <- function( effectFUN_tie_weighted <- function( network, sender, receiver, replace, - weighted = TRUE, transformFun = identity -) { + weighted = TRUE, transformFun = identity) { update_DyNAM_choice_tie( network = network, sender = sender, receiver = receiver, replace = replace, @@ -118,8 +119,7 @@ effectFUN_tie_weighted <- function( effectFUN_same <- function( attribute, node, replace, - isTwoMode = FALSE -) { + isTwoMode = FALSE) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, @@ -132,8 +132,7 @@ effectFUN_indeg <- function( sender, receiver, replace, cache, n1, n2, isTwoMode = FALSE, - weighted = FALSE, transformFun = identity -) { + weighted = FALSE, transformFun = identity) { update_DyNAM_choice_indeg( network = network, sender = sender, receiver = receiver, replace = replace, cache = cache, @@ -148,8 +147,7 @@ effectFUN_trans <- function( receiver, replace, cache, isTwoMode = FALSE, - transformFun = identity -) { + transformFun = identity) { update_DyNAM_choice_trans( network = network, sender = sender, receiver = receiver, replace = replace, @@ -169,8 +167,7 @@ effectFUN_tertius <- function( isTwoMode = FALSE, n1 = n1, n2 = n2, transformFun = abs, - aggregateFun = function(x) mean(x, na.rm = TRUE) -) { + aggregateFun = function(x) mean(x, na.rm = TRUE)) { update_DyNAM_choice_tertiusDiff( network = network, attribute = attribute, @@ -182,28 +179,28 @@ effectFUN_tertius <- function( isTwoMode = isTwoMode, n1 = n1, n2 = n2, transformFun = transformFun, - aggregateFun = aggregateFun) + aggregateFun = aggregateFun + ) } effectFUN_REM_ego <- function( attribute, node, replace, n1, n2, - isTwoMode = FALSE -) { + isTwoMode = FALSE) { update_REM_choice_ego( attribute = attribute, node = node, replace = replace, n1 = n1, n2 = n2, - isTwoMode = isTwoMode) + isTwoMode = isTwoMode + ) } effectFUN_REM_diff <- function( attribute, node, replace, n1, n2, isTwoMode = FALSE, - transformFun = abs -) { + transformFun = abs) { update_DyNAM_choice_diff( attribute = attribute, node = node, replace = replace, @@ -216,8 +213,7 @@ effectFUN_REM_diff <- function( effectFUN_REM_sim <- function( attribute, node, replace, - isTwoMode = FALSE -) { + isTwoMode = FALSE) { update_DyNAM_choice_same( attribute = attribute, node = node, replace = replace, @@ -229,11 +225,16 @@ effectFUN_REM_sim <- function( # direct network eventsIncrement <- data.frame( time = cumsum( - c(1, 5, 3, 4, 2, 1, 3, 4, 5, 1, 3, 4)), - sender = sprintf("Actor %d", - c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5, 1)), - receiver = sprintf("Actor %d", - c(2, 2, 3, 3, 1, 5, 4, 4, 2, 3, 2, 2)), + c(1, 5, 3, 4, 2, 1, 3, 4, 5, 1, 3, 4) + ), + sender = sprintf( + "Actor %d", + c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5, 1) + ), + receiver = sprintf( + "Actor %d", + c(2, 2, 3, 3, 1, 5, 4, 4, 2, 3, 2, 2) + ), increment = c(1, 2, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1), stringsAsFactors = FALSE @@ -253,14 +254,18 @@ compChange <- data.frame( ) networkState <- matrix( - c(0, 3, 0, 0, 0, + c( + 0, 3, 0, 0, 0, 1, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, - 0, 0, 0, 0, 0), + 0, 0, 0, 0, 0 + ), nrow = 5, ncol = 5, byrow = TRUE, - dimnames = list(sprintf("Actor %d", 1:5), - sprintf("Actor %d", 1:5)) + dimnames = list( + sprintf("Actor %d", 1:5), + sprintf("Actor %d", 1:5) + ) ) # defining objects @@ -268,52 +273,66 @@ actorsEx <- defineNodes(actorsEx) actorsEx <- linkEvents( x = actorsEx, changeEvent = compChange, - attribute = "present") + attribute = "present" +) networkState <- defineNetwork( matrix = networkState, nodes = actorsEx, - directed = TRUE) + directed = TRUE +) networkState <- linkEvents( x = networkState, changeEvent = eventsIncrement, - nodes = actorsEx) + nodes = actorsEx +) depNetwork <- defineDependentEvents( events = eventsIncrement, nodes = actorsEx, - defaultNetwork = networkState) + defaultNetwork = networkState +) # exogenous network eventsExogenous <- data.frame( time = c(7, 14, 15, 18, 18, 25, 25), - sender = sprintf("Actor %d", - c(4, 2, 5, 4, 4, 1, 3)), - receiver = sprintf("Actor %d", - c(2, 3, 1, 5, 2, 3, 5)), + sender = sprintf( + "Actor %d", + c(4, 2, 5, 4, 4, 1, 3) + ), + receiver = sprintf( + "Actor %d", + c(2, 3, 1, 5, 2, 3, 5) + ), increment = - c(1, 1, 3, 1, -1, 2, 3), + c(1, 1, 3, 1, -1, 2, 3), stringsAsFactors = FALSE ) networkExog <- matrix( - c(0, 0, 0, 1, 0, + c( + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 2, 0, 0, 0, 1, 0, 0, 0, 0, - 1, 2, 0, 0, 0), + 1, 2, 0, 0, 0 + ), nrow = 5, ncol = 5, byrow = TRUE, - dimnames = list(sprintf("Actor %d", 1:5), - sprintf("Actor %d", 1:5)) + dimnames = list( + sprintf("Actor %d", 1:5), + sprintf("Actor %d", 1:5) + ) ) # define goldfish objects networkExog <- defineNetwork( matrix = networkExog, - nodes = actorsEx, directed = TRUE) + nodes = actorsEx, directed = TRUE +) networkExog <- linkEvents( x = networkExog, changeEvent = eventsExogenous, - nodes = actorsEx) + nodes = actorsEx +) # DyNAM-i ----------------------------------------------------------- @@ -341,78 +360,88 @@ compchanges_DyNAMi <- data.frame( # Actor x Group matrix ---------------------------------------------- covnetwork_DyNAMi <- matrix( - c(0, 1, 1, 0, + c( + 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0, 0, - 0, 0, 0, 0), + 0, 0, 0, 0 + ), nrow = 4, ncol = 4, byrow = TRUE, - dimnames = list(sprintf("Actor %d", 1:4), - sprintf("Group %d", 1:4)) + dimnames = list( + sprintf("Actor %d", 1:4), + sprintf("Group %d", 1:4) + ) ) # Events ------------------------------------------------------------ depevents_DyNAMi <- data.frame( - time = c(5, 10, 10, 20, 20, 20, 25, 25), - sender = sprintf("Actor %d", c(1, 3, 4, 1, 3, 3, 1, 4)), - receiver = sprintf("Group %d", c(2, 2, 2, 2, 2, 1, 1, 2)), + time = c(5, 10, 10, 20, 20, 20, 25, 25), + sender = sprintf("Actor %d", c(1, 3, 4, 1, 3, 3, 1, 4)), + receiver = sprintf("Group %d", c(2, 2, 2, 2, 2, 1, 1, 2)), increment = c(1, 1, 1, -1, -1, 1, -1, -1), stringsAsFactors = FALSE ) -attr(depevents_DyNAMi,"order") <- c(1, 4, 8, 13, 15, 17, 20, 22) +attr(depevents_DyNAMi, "order") <- c(1, 4, 8, 13, 15, 17, 20, 22) class(depevents_DyNAMi) <- c(class(depevents_DyNAMi), "interaction.groups.updates") exoevents_DyNAMi <- data.frame( - time = c(5, 10, 10, 20, 20, 20, 25, 25), - sender = sprintf("Actor %d", c(1, 3, 4, 1, 3, 3, 1, 4)), - receiver = sprintf("Group %d", c(1, 3, 4, 1, 3, 3, 3, 4)), + time = c(5, 10, 10, 20, 20, 20, 25, 25), + sender = sprintf("Actor %d", c(1, 3, 4, 1, 3, 3, 1, 4)), + receiver = sprintf("Group %d", c(1, 3, 4, 1, 3, 3, 3, 4)), increment = c(-1, -1, -1, 1, 1, -1, 1, 1), stringsAsFactors = FALSE ) -attr(exoevents_DyNAMi,"order") <- c(3, 7, 12, 14, 16, 19, 21, 23) +attr(exoevents_DyNAMi, "order") <- c(3, 7, 12, 14, 16, 19, 21, 23) class(exoevents_DyNAMi) <- c(class(exoevents_DyNAMi), "interaction.groups.updates") pastupdates_DyNAMi <- data.frame( - time = c(5, 10, 10, 10, 10, 10, 20), - sender = sprintf("Actor %d", c(1, 3, 3, 4, 4, 4, 3)), - receiver = sprintf("Actor %d", c(2, 1, 2, 1, 2, 3, 1)), + time = c(5, 10, 10, 10, 10, 10, 20), + sender = sprintf("Actor %d", c(1, 3, 3, 4, 4, 4, 3)), + receiver = sprintf("Actor %d", c(2, 1, 2, 1, 2, 3, 1)), increment = c(1, 1, 1, 1, 1, 1, 1), stringsAsFactors = FALSE ) -attr(pastupdates_DyNAMi,"order") <- c(2, 5, 6, 9, 10, 11, 18) +attr(pastupdates_DyNAMi, "order") <- c(2, 5, 6, 9, 10, 11, 18) class(pastupdates_DyNAMi) <- c(class(pastupdates_DyNAMi), "interaction.network.updates") # goldfish Objects -------------------------------------------------- actors_DyNAMi <- defineNodes(actors_DyNAMi) groups_DyNAMi <- defineNodes(groups_DyNAMi) -#groups <- linkEvents(x = groups, compchanges, attribute = "present") +# groups <- linkEvents(x = groups, compchanges, attribute = "present") initnetwork_DyNAMi <- structure( diag(x = 1, nrow(actors_DyNAMi), nrow(actors_DyNAMi)), - dimnames = list(sprintf("Actor %d", 1:4), sprintf("Group %d", 1:4))) + dimnames = list(sprintf("Actor %d", 1:4), sprintf("Group %d", 1:4)) +) interaction_network_DyNAMi <- defineNetwork( matrix = initnetwork_DyNAMi, - nodes = actors_DyNAMi, nodes2 = groups_DyNAMi, directed = TRUE) + nodes = actors_DyNAMi, nodes2 = groups_DyNAMi, directed = TRUE +) interaction_network_DyNAMi <- linkEvents( x = interaction_network_DyNAMi, changeEvent = depevents_DyNAMi, - nodes = actors_DyNAMi, nodes2 = groups_DyNAMi) + nodes = actors_DyNAMi, nodes2 = groups_DyNAMi +) interaction_network_DyNAMi <- linkEvents( x = interaction_network_DyNAMi, changeEvent = exoevents_DyNAMi, - nodes = actors_DyNAMi, nodes2 = groups_DyNAMi) + nodes = actors_DyNAMi, nodes2 = groups_DyNAMi +) past_network_DyNAMi <- defineNetwork(nodes = actors_DyNAMi, directed = FALSE) past_network_DyNAMi <- linkEvents( x = past_network_DyNAMi, changeEvents = pastupdates_DyNAMi, - nodes = actors_DyNAMi) + nodes = actors_DyNAMi +) dependent.depevents_DyNAMi <- defineDependentEvents( events = depevents_DyNAMi, nodes = actors_DyNAMi, nodes2 = groups_DyNAMi, - defaultNetwork = interaction_network_DyNAMi) + defaultNetwork = interaction_network_DyNAMi +) # result goldfish object -------------------------------------------------- resModObject <- structure( @@ -422,9 +451,12 @@ resModObject <- structure( logLikelihood = -699.4532, finalScore = c(0.000200290995642893, 0, 1.49135840820103e-05), finalInformationMatrix = matrix( - c(41.6502772825771, 20.354755811421, 2.46078347465864, 20.354755811421, + c( + 41.6502772825771, 20.354755811421, 2.46078347465864, 20.354755811421, 49.9909036131337, 10.6250978238344, 2.46078347465864, 10.6250978238344, - 25.7794286431431), ncol = 3, nrow = 3 + 25.7794286431431 + ), + ncol = 3, nrow = 3 ), convergence = list(isConverged = TRUE, maxAbsScore = 0.000200291), nIterations = 7L, @@ -435,7 +467,8 @@ resModObject <- structure( dimnames = list(c("inertia", "recip", "trans"), c("Object", "fixed")) ), formula = as.formula("callsDependent ~ inertia + recip + trans", - env = new.env(parent = emptyenv())), + env = new.env(parent = emptyenv()) + ), model = "DyNAM", subModel = "choice", rightCensored = FALSE, diff --git a/R/zzz.R b/R/zzz.R index 1a88c5a..6480325 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,6 +1,8 @@ #' @importFrom utils packageVersion packageDescription .onAttach <- function(libname, pkgname) { - if (!interactive()) return() + if (!interactive()) { + return() + } base::packageStartupMessage( " <\")))>< The goldfish package in R\n\n", pkgname, ": version ", utils::packageVersion("goldfish"), " ", @@ -10,14 +12,14 @@ # packageStartupMessage( # "Please cite as:\nChristoph Stadtfeld and James Hollway (2018). \"goldfish: - # Statistical network models for dynamic network data\". R package version ", + # Statistical network models for dynamic network data\". R package version ", # packageVersion("goldfish"), # ", www.social-networks.ethz.ch/research/goldfish.html.\n") } -# Whenever you use C++ code in your package, you need to clean up +# Whenever you use C++ code in your package, you need to clean up # after yourself when your package is unloaded. -# Do this by writing a .onUnload() function that unloads the DLL: +# Do this by writing a .onUnload() function that unloads the DLL: # (http://r-pkgs.had.co.nz/src.html) .onUnload <- function(libpath) { library.dynam.unload("goldfish", libpath) diff --git a/tests/testthat/test-effects_preprocessing.R b/tests/testthat/test-effects_preprocessing.R index 4dbaa45..5c379f2 100644 --- a/tests/testthat/test-effects_preprocessing.R +++ b/tests/testthat/test-effects_preprocessing.R @@ -2,12 +2,14 @@ test_that( "Reduce size updates", { depUpdates <- matrix( - c(1, 2, 0, 2, 3, 1, 4, 5, 1), nrow = 3, + c(1, 2, 0, 2, 3, 1, 4, 5, 1), + nrow = 3, dimnames = list(NULL, c("node1", "node2", "replace")), byrow = TRUE ) updates <- matrix( - c(1, 2, 1, 4, 5, 2), nrow = 2, + c(1, 2, 1, 4, 5, 2), + nrow = 2, dimnames = list(NULL, c("node1", "node2", "replace")), byrow = TRUE ) @@ -20,7 +22,8 @@ test_that( check2 <- ReduceUpdateNonDuplicates(depUpdates, updates) outcome <- matrix( - c(2, 3, 1, 1, 2, 1, 4, 5, 2), nrow = 3, + c(2, 3, 1, 1, 2, 1, 4, 5, 2), + nrow = 3, dimnames = list(NULL, c("node1", "node2", "replace")), byrow = TRUE ) diff --git a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R index 16726e9..a59df05 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R @@ -31,36 +31,40 @@ test_that( expect_equal( Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), fillChanges( - nodes = c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5), + nodes = c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5), replace = c(4, 3, 4, 5, 1, 6, 4, 5, 2, 6, 2), - time = NULL, set = 1:5), + time = NULL, set = 1:5 + ), label = "updating outdeg with increment works" ) # n-1 updates expect_equal( statsChange[[1]][["dependent"]], fillChanges( - nodes = c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5), - replace = c(4, 3, 4, 5, 1, 6, 4, 5, 2, 6, 2), - time = c(6, 9, 13, 15, 16, 19, 23, 28, 29, 32, 36), - set = 1:5), + nodes = c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5), + replace = c(4, 3, 4, 5, 1, 6, 4, 5, 2, 6, 2), + time = c(6, 9, 13, 15, 16, 19, 23, 28, 29, 32, 36), + set = 1:5 + ), label = "updating outdeg times with increment works" ) # n-1 updates expect_equal( statsChange[[2]][["dependent"]], fillChanges( - nodes = c(2, 3, 1, 2, 5, 3, 5), - replace = c(5, 1, 5, 4, 1, 3, 4), - time = c(9, 15, 16, 19, 19, 28, 28), - set = 1:5), + nodes = c(2, 3, 1, 2, 5, 3, 5), + replace = c(5, 1, 5, 4, 1, 3, 4), + time = c(9, 15, 16, 19, 19, 28, 28), + set = 1:5 + ), label = "updating indeg times with increment works" ) # n-1 updates expect_equal( statsChange[[1]][["rightCensored"]], fillChanges( - nodes = c(3, 2, 1, 3), - replace = c(3, 5, 6, 5), - time = c(7, 14, 18, 25), - set = 1:5), + nodes = c(3, 2, 1, 3), + replace = c(3, 5, 6, 5), + time = c(7, 14, 18, 25), + set = 1:5 + ), label = "updating outdeg times right censored" ) # n-1 updates expect_null( @@ -173,36 +177,40 @@ test_that( expect_equal( Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), fillChanges( - nodes = c(2, 5, 1, 3, 3, 4), + nodes = c(2, 5, 1, 3, 3, 4), replace = c(5, 1, 6, 4, 5, 2), - time = NULL, set = 1:5), + time = NULL, set = 1:5 + ), label = "updating outdeg with increment works" ) # n-1 updates, should update last expect_equal( statsChange[[1]][["dependent"]], fillChanges( - nodes = c(2, 5, 1, 3, 3, 4), - replace = c(5, 1, 6, 4, 5, 2), - time = c(15, 16, 19, 23, 28, 29), - set = 1:5), + nodes = c(2, 5, 1, 3, 3, 4), + replace = c(5, 1, 6, 4, 5, 2), + time = c(15, 16, 19, 23, 28, 29), + set = 1:5 + ), label = "updating outdeg times with increment works" ) # n-1 updates expect_equal( statsChange[[2]][["dependent"]], fillChanges( - nodes = c(3, 1, 2, 5, 3, 5), - replace = c(1, 5, 4, 1, 3, 4), - time = c(15, 16, 19, 19, 28, 28), - set = 1:5), + nodes = c(3, 1, 2, 5, 3, 5), + replace = c(1, 5, 4, 1, 3, 4), + time = c(15, 16, 19, 19, 28, 28), + set = 1:5 + ), label = "updating indeg times with increment works" ) # n-1 updates expect_equal( statsChange[[1]][["rightCensored"]], fillChanges( - nodes = c(2, 1, 3, 2), - replace = c(5, 6, 5, 6), - time = c(14, 18, 25, 30), - set = 1:5), + nodes = c(2, 1, 3, 2), + replace = c(5, 6, 5, 6), + time = c(14, 18, 25, 30), + set = 1:5 + ), label = "updating outdeg times right censored" ) # n-1 updates expect_null( @@ -288,36 +296,40 @@ test_that( expect_equal( Reduce(rbind, lapply(preproData$dependentStatsChange, "[[", 1)), fillChanges( - nodes = c(3, 2, 2, 5, 1, 3), + nodes = c(3, 2, 2, 5, 1, 3), replace = c(3, 4, 5, 1, 6, 4), - time = NULL, set = 1:5), + time = NULL, set = 1:5 + ), label = "updating outdeg with increment works" ) # n-1 updates, should update last expect_equal( statsChange[[1]][["dependent"]], fillChanges( - nodes = c(3, 2, 2, 5, 1, 3), - replace = c(3, 4, 5, 1, 6, 4), - time = c(9, 13, 15, 16, 19, 23), - set = 1:5), + nodes = c(3, 2, 2, 5, 1, 3), + replace = c(3, 4, 5, 1, 6, 4), + time = c(9, 13, 15, 16, 19, 23), + set = 1:5 + ), label = "updating outdeg times with increment works" ) # n-1 updates expect_equal( statsChange[[2]][["dependent"]], fillChanges( - nodes = c(2, 3, 1, 2, 5), - replace = c(5, 1, 5, 4, 1), - time = c(9, 15, 16, 19, 19), - set = 1:5), + nodes = c(2, 3, 1, 2, 5), + replace = c(5, 1, 5, 4, 1), + time = c(9, 15, 16, 19, 19), + set = 1:5 + ), label = "updating indeg times with increment works" ) # n-1 updates expect_equal( statsChange[[1]][["rightCensored"]], fillChanges( - nodes = c(3, 2, 1, 3), - replace = c(3, 5, 6, 5), - time = c(7, 14, 18, 24), - set = 1:5), + nodes = c(3, 2, 1, 3), + replace = c(3, 5, 6, 5), + time = c(7, 14, 18, 24), + set = 1:5 + ), label = "updating outdeg times right censored" ) # n-1 updates expect_null( diff --git a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R index bbbc8ec..a2fbcac 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R @@ -7,7 +7,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - inertia(past_network_DyNAMi, weighted = TRUE, subType = "count") + + inertia(past_network_DyNAMi, weighted = TRUE, subType = "count") + tie(covnetwork_DyNAMi, weighted = TRUE, subType = "count") + inertia(past_network_DyNAMi, weighted = TRUE, subType = "proportion") + tie(covnetwork_DyNAMi, weighted = TRUE, subType = "proportion") + @@ -24,8 +24,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -290,8 +291,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -391,9 +393,11 @@ test_that( preproData <- estimate( dependent.depevents_DyNAMi ~ alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "mean_normalized") + + weighted = TRUE, subType = "mean_normalized" + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean_normalized") + + weighted = TRUE, subType = "mean_normalized" + ) + alterpop(past_network_DyNAMi, weighted = TRUE, subType = "min") + alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "min") + alterpop(past_network_DyNAMi, weighted = TRUE, subType = "mean") + @@ -401,16 +405,19 @@ test_that( alterpop(past_network_DyNAMi, weighted = TRUE, subType = "max") + alterdeg(covnetwork_DyNAMi, weighted = TRUE, subType = "max") + alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "mean_centered") + + weighted = TRUE, subType = "mean_centered" + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean_centered"), + weighted = TRUE, subType = "mean_centered" + ), model = "DyNAMi", subModel = "choice", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -648,15 +655,16 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - size(interaction_network_DyNAMi, subType = "identity") + + size(interaction_network_DyNAMi, subType = "identity") + size(interaction_network_DyNAMi, subType = "squared"), model = "DyNAMi", subModel = "choice", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -760,7 +768,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ alter(actors_DyNAMi$attr1, subType = "mean") - + alter(actors_DyNAMi$attr1, subType = "mean_normalized") + + alter(actors_DyNAMi$attr1, subType = "mean_normalized") + alter(actors_DyNAMi$attr1, subType = "mean_squared") + alter(actors_DyNAMi$attr1, subType = "min") + alter(actors_DyNAMi$attr1, subType = "max") @@ -771,8 +779,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -980,23 +989,24 @@ test_that( preproData <- estimate( dependent.depevents_DyNAMi ~ same(actors_DyNAMi$attr2, subType = "proportion") - + same(actors_DyNAMi$attr2, subType = "count") - + same(actors_DyNAMi$attr2, subType = "presence") - + diff(actors_DyNAMi$attr1, subType = "averaged_sum") - + diff(actors_DyNAMi$attr1, subType = "mean") - + diff(actors_DyNAMi$attr1, subType = "min") - + diff(actors_DyNAMi$attr1, subType = "max") - + sim(actors_DyNAMi$attr1, subType = "averaged_sum") - + sim(actors_DyNAMi$attr1, subType = "mean") - + sim(actors_DyNAMi$attr1, subType = "min") - + sim(actors_DyNAMi$attr1, subType = "max"), + + same(actors_DyNAMi$attr2, subType = "count") + + same(actors_DyNAMi$attr2, subType = "presence") + + diff(actors_DyNAMi$attr1, subType = "averaged_sum") + + diff(actors_DyNAMi$attr1, subType = "mean") + + diff(actors_DyNAMi$attr1, subType = "min") + + diff(actors_DyNAMi$attr1, subType = "max") + + sim(actors_DyNAMi$attr1, subType = "averaged_sum") + + sim(actors_DyNAMi$attr1, subType = "mean") + + sim(actors_DyNAMi$attr1, subType = "min") + + sim(actors_DyNAMi$attr1, subType = "max"), model = "DyNAMi", subModel = "choice", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } diff --git a/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R index f080f8f..01493f2 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R @@ -13,8 +13,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -118,37 +119,50 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - inertia(past_network_DyNAMi, - weighted = TRUE, subType = "count", joining = -1) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "count", joining = -1) + + weighted = TRUE, subType = "count", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "proportion", joining = -1) + + weighted = TRUE, subType = "proportion", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "proportion", joining = -1) + + weighted = TRUE, subType = "proportion", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "presence", joining = -1) + + weighted = TRUE, subType = "presence", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "presence", joining = -1) + + weighted = TRUE, subType = "presence", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "min", joining = -1) + + weighted = TRUE, subType = "min", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "min", joining = -1) + + weighted = TRUE, subType = "min", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "mean", joining = -1) + + weighted = TRUE, subType = "mean", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean", joining = -1) + + weighted = TRUE, subType = "mean", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "max", joining = -1) + + weighted = TRUE, subType = "max", joining = -1 + ) + tie(covnetwork_DyNAMi, - weighted = TRUE, subType = "max", joining = -1), + weighted = TRUE, subType = "max", joining = -1 + ), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -385,19 +399,23 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - inertia(past_network_DyNAMi, - weighted = TRUE, subType = "count", joining = -1) - + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "count", joining = -1, window = 2) + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1 + ) + inertia(past_network_DyNAMi, - weighted = TRUE, subType = "count", joining = -1, window = 7), + weighted = TRUE, subType = "count", joining = -1, window = 2 + ) + + inertia(past_network_DyNAMi, + weighted = TRUE, subType = "count", joining = -1, window = 7 + ), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -663,37 +681,50 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - egopop(past_network_DyNAMi, - weighted = TRUE, subType = "identity", joining = 1) + + egopop(past_network_DyNAMi, + weighted = TRUE, subType = "identity", joining = 1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "identity", joining = 1) + + weighted = TRUE, subType = "identity", joining = 1 + ) + egopop(past_network_DyNAMi, - weighted = TRUE, subType = "normalized", joining = 1) + + weighted = TRUE, subType = "normalized", joining = 1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "normalized", joining = 1) + + weighted = TRUE, subType = "normalized", joining = 1 + ) + egopop(past_network_DyNAMi, - weighted = TRUE, subType = "identity", joining = -1) + + weighted = TRUE, subType = "identity", joining = -1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "identity", joining = -1) + + weighted = TRUE, subType = "identity", joining = -1 + ) + egopop(past_network_DyNAMi, - weighted = TRUE, subType = "normalized", joining = -1) + + weighted = TRUE, subType = "normalized", joining = -1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "normalized", joining = -1) + + weighted = TRUE, subType = "normalized", joining = -1 + ) + egopop(past_network_DyNAMi, - weighted = TRUE, subType = "centered", joining = 1) + + weighted = TRUE, subType = "centered", joining = 1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "centered", joining = 1) + + weighted = TRUE, subType = "centered", joining = 1 + ) + egopop(past_network_DyNAMi, - weighted = TRUE, subType = "centered", joining = -1) + + weighted = TRUE, subType = "centered", joining = -1 + ) + egodeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "centered", joining = -1), + weighted = TRUE, subType = "centered", joining = -1 + ), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -1119,33 +1150,44 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "mean", joining = -1) + + alterpop(past_network_DyNAMi, + weighted = TRUE, subType = "mean", joining = -1 + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean", joining = -1) + + weighted = TRUE, subType = "mean", joining = -1 + ) + alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "mean_normalized", joining = -1) + + weighted = TRUE, subType = "mean_normalized", joining = -1 + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean_normalized", joining = -1) + + weighted = TRUE, subType = "mean_normalized", joining = -1 + ) + alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "min", joining = -1) + + weighted = TRUE, subType = "min", joining = -1 + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "min", joining = -1) + + weighted = TRUE, subType = "min", joining = -1 + ) + alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "max", joining = -1) + + weighted = TRUE, subType = "max", joining = -1 + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "max", joining = -1) + + weighted = TRUE, subType = "max", joining = -1 + ) + alterpop(past_network_DyNAMi, - weighted = TRUE, subType = "mean_centered", joining = -1) + + weighted = TRUE, subType = "mean_centered", joining = -1 + ) + alterdeg(covnetwork_DyNAMi, - weighted = TRUE, subType = "mean_centered", joining = -1), + weighted = TRUE, subType = "mean_centered", joining = -1 + ), model = "DyNAMi", subModel = "rate", preprocessingOnly = TRUE ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -1467,7 +1509,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - ego(actors_DyNAMi$attr1, subType = "identity", joining = 1) + + ego(actors_DyNAMi$attr1, subType = "identity", joining = 1) + ego(actors_DyNAMi$attr1, subType = "identity", joining = -1) + ego(actors_DyNAMi$attr1, subType = "normalized", joining = 1) + ego(actors_DyNAMi$attr1, subType = "normalized", joining = -1) + @@ -1480,8 +1522,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -1807,7 +1850,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - alter(actors_DyNAMi$attr1, subType = "mean", joining = -1) + + alter(actors_DyNAMi$attr1, subType = "mean", joining = -1) + alter(actors_DyNAMi$attr1, subType = "mean_squared", joining = -1) + alter(actors_DyNAMi$attr1, subType = "mean_normalized", joining = -1) + alter(actors_DyNAMi$attr1, subType = "min", joining = -1) + @@ -1818,8 +1861,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -2020,7 +2064,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - same(actors_DyNAMi$attr2, subType = "count", joining = -1) + + same(actors_DyNAMi$attr2, subType = "count", joining = -1) + same(actors_DyNAMi$attr2, subType = "proportion", joining = -1) + same(actors_DyNAMi$attr2, subType = "presence", joining = -1), model = "DyNAMi", subModel = "rate", @@ -2028,8 +2072,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -2166,7 +2211,7 @@ test_that( { preproData <- estimate( dependent.depevents_DyNAMi ~ - diff(actors_DyNAMi$attr1, subType = "averaged_sum", joining = -1) + + diff(actors_DyNAMi$attr1, subType = "averaged_sum", joining = -1) + diff(actors_DyNAMi$attr1, subType = "mean", joining = -1) + diff(actors_DyNAMi$attr1, subType = "min", joining = -1) + diff(actors_DyNAMi$attr1, subType = "max", joining = -1), @@ -2175,8 +2220,9 @@ test_that( ) updFun <- function(stat, change) { - if (!is.null(change)) + if (!is.null(change)) { stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R b/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R index 209cde7..3d807ed 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-init_default.R @@ -2,21 +2,24 @@ test_that("DyNAM default and tie init return the same result", { expect_equal( init_DyNAM_choice.tie(effectFUN_tie, m1, NULL, 5, 5), init_DyNAM_choice.default( - effectFUN_tie, network = m1, attribute = NULL, window = NULL, + effectFUN_tie, + network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5 ) ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie, m1, 1, 5, 5), init_DyNAM_choice.default( - effectFUN_tie, network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5 + effectFUN_tie, + network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5 ), label = "when window is not NULL" ) expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m1, NULL, 5, 5), init_DyNAM_choice.default( - effectFUN_tie_weighted, network = m1, attribute = NULL, window = NULL, + effectFUN_tie_weighted, + network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5 ), label = "when weighted is TRUE" @@ -24,7 +27,8 @@ test_that("DyNAM default and tie init return the same result", { expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m1, 1, 5, 5), init_DyNAM_choice.default( - effectFUN_tie_weighted, network = m1, attribute = NULL, window = 1, + effectFUN_tie_weighted, + network = m1, attribute = NULL, window = 1, n1 = 5, n2 = 5 ), label = "when weighted is TRUE and window is not NULL" @@ -32,7 +36,8 @@ test_that("DyNAM default and tie init return the same result", { expect_equal( init_DyNAM_choice.tie(effectFUN_tie_weighted, m0, NULL, 5, 5), init_DyNAM_choice.default( - effectFUN_tie_weighted, network = m0, attribute = NULL, window = NULL, + effectFUN_tie_weighted, + network = m0, attribute = NULL, window = NULL, n1 = 5, n2 = 5 ), label = "when weighted is TRUE and there are no ties in the network" @@ -62,7 +67,8 @@ test_that("DyNAM default and trans init return the same result", { expect_equal( init_DyNAM_choice.trans(effectFUN_trans, m1, NULL, 5, 5), init_DyNAM_choice.default( - effectFUN_trans, network = m1, attribute = NULL, window = NULL, + effectFUN_trans, + network = m1, attribute = NULL, window = NULL, n1 = 5, n2 = 5 ) ) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R index bc4341e..7c3bfd3 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_alter.R @@ -19,12 +19,14 @@ test_that("alter returns a valid object on update", { test_that("alter returns NULL if there is no change", { expect_null( update_DyNAM_choice_alter( - testAttr$fishingSkill, node = 1, replace = 10, n1 = 8, n2 = 0 + testAttr$fishingSkill, + node = 1, replace = 10, n1 = 8, n2 = 0 )$changes ) expect_null( update_DyNAM_choice_alter( - testAttr$fishingSkill, node = 2, replace = NA, n1 = 8, n2 = 0 + testAttr$fishingSkill, + node = 2, replace = NA, n1 = 8, n2 = 0 )$changes, label = "when previous value and replace are NA" ) @@ -33,20 +35,23 @@ test_that("alter returns NULL if there is no change", { test_that("alter returns correct attributes on update", { expect_equal( update_DyNAM_choice_alter( - testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0 + testAttr$fishingSkill, + node = 1, replace = 1, n1 = 8, n2 = 0 )$changes, cbind(node1 = 2:8, node2 = rep(1, 7), replace = rep(1, 7)) ) expect_equal( update_DyNAM_choice_alter( - testAttr$fishingSkill, node = 1, replace = 0, n1 = 8, n2 = 0 + testAttr$fishingSkill, + node = 1, replace = 0, n1 = 8, n2 = 0 )$changes, cbind(node1 = 2:8, node2 = rep(1, 7), replace = rep(0, 7)), label = "when replace is 0" ) expect_equal( update_DyNAM_choice_alter( - testAttr$fishingSkill, node = 8, replace = 1, n1 = 8, n2 = 0 + testAttr$fishingSkill, + node = 8, replace = 1, n1 = 8, n2 = 0 )$changes, cbind(node1 = 1:7, node2 = rep(8, 7), replace = rep(1, 7)), label = "when previous value was NA" diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_diff.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_diff.R index 7605999..fd1e250 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_diff.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_diff.R @@ -23,59 +23,76 @@ test_that("diff equals NULL if there is no change", { node = 7, replace = 3, n1 = 8, n2 = 0 )$changes) - expect_null(update_DyNAM_choice_diff(testAttr$fishingSkill, - node = 2, replace = NA, - n1 = 8, n2 = 0 - )$changes, - label = "when replace is NA" + expect_null( + update_DyNAM_choice_diff(testAttr$fishingSkill, + node = 2, replace = NA, + n1 = 8, n2 = 0 + )$changes, + label = "when replace is NA" ) }) test_that("diff returns correct attributes on update", { + repVal0 <- testAttr$fishingSkill[-1] expect_equal( update_DyNAM_choice_diff(testAttr$fishingSkill, node = 5, replace = 10, n1 = 8, n2 = 0 )$changes, rbind( - cbind(node1 = rep(5, 7), node2 = c(1:4, 6:8), - replace = c(0, NA, 5, 0, 2, 7, NA)), - cbind(node1 = c(1:4, 6:8), node2 = rep(5, 7), - replace = c(0, NA, 5, 0, 2, 7, NA)) + cbind( + node1 = rep(5, 7), node2 = c(1:4, 6:8), + replace = c(0, NA, 5, 0, 2, 7, NA) + ), + cbind( + node1 = c(1:4, 6:8), node2 = rep(5, 7), + replace = c(0, NA, 5, 0, 2, 7, NA) + ) ) ) - expect_equal(update_DyNAM_choice_diff(testAttr$fishingSkill, - node = 1, replace = 0, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(1, 7), node2 = 2:8, replace = testAttr$fishingSkill[-1]), - cbind(node1 = 2:8, node2 = rep(1, 7), replace = testAttr$fishingSkill[-1]) - ), - label = "when replace is 0" + expect_equal( + update_DyNAM_choice_diff(testAttr$fishingSkill, + node = 1, replace = 0, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind(node1 = rep(1, 7), node2 = 2:8, replace = repVal0), + cbind(node1 = 2:8, node2 = rep(1, 7), replace = repVal0) + ), + label = "when replace is 0" ) - expect_equal(update_DyNAM_choice_diff(testAttr$fishingSkill, - node = 1, replace = NA, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(1, 7), node2 = 2:8, - replace = c(NA, 1.8, 3.2, 1.2, 1.2, 3.8, NA)), - cbind(node1 = 2:8, node2 = rep(1, 7), - replace = c(NA, 1.8, 3.2, 1.2, 1.2, 3.8, NA)) - ), - label = "when replace is NA" + expect_equal( + update_DyNAM_choice_diff(testAttr$fishingSkill, + node = 1, replace = NA, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind( + node1 = rep(1, 7), node2 = 2:8, + replace = c(NA, 1.8, 3.2, 1.2, 1.2, 3.8, NA) + ), + cbind( + node1 = 2:8, node2 = rep(1, 7), + replace = c(NA, 1.8, 3.2, 1.2, 1.2, 3.8, NA) + ) + ), + label = "when replace is NA" ) - expect_equal(update_DyNAM_choice_diff(testAttr$fishingSkill, - node = 2, replace = 10, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(2, 7), node2 = c(1, 3:8), - replace = c(0, 5, 0, 2, 2, 7, NA)), - cbind(node1 = c(1, 3:8), node2 = rep(2, 7), - replace = c(0, 5, 0, 2, 2, 7, NA)) - ), - label = "when old value was NA" + expect_equal( + update_DyNAM_choice_diff(testAttr$fishingSkill, + node = 2, replace = 10, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind( + node1 = rep(2, 7), node2 = c(1, 3:8), + replace = c(0, 5, 0, 2, 2, 7, NA) + ), + cbind( + node1 = c(1, 3:8), node2 = rep(2, 7), + replace = c(0, 5, 0, 2, 2, 7, NA) + ) + ), + label = "when old value was NA" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_four.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_four.R index aadb8e3..4bc922c 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_four.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_four.R @@ -33,52 +33,59 @@ test_that("four NULL if there is no change", { sender = 1, receiver = 2, replace = 1, cache = m0 )$changes) - expect_null(update_DyNAM_choice_four(mTwoMode, - sender = 1, receiver = 5, replace = NA, - cache = m0 - )$changes, - label = "when previous value and replace are NA" + expect_null( + update_DyNAM_choice_four(mTwoMode, + sender = 1, receiver = 5, replace = NA, + cache = m0 + )$changes, + label = "when previous value and replace are NA" ) }) test_that("four recognizes tie creation correctly", { - expect_equal(update_DyNAM_choice_four(mTwoMode, - sender = 1, receiver = 4, replace = 1, - cache = m0 - )$changes, - rbind( - c(node1 = 1, node2 = 2, replace = 1), - c(node1 = 3, node2 = 2, replace = 1), - c(node1 = 3, node2 = 4, replace = 1), - c(node1 = 1, node2 = 5, replace = 1) - ), - label = "when tie i -> l is created" + expect_equal( + update_DyNAM_choice_four(mTwoMode, + sender = 1, receiver = 4, replace = 1, + cache = m0 + )$changes, + rbind( + c(node1 = 1, node2 = 2, replace = 1), + c(node1 = 3, node2 = 2, replace = 1), + c(node1 = 3, node2 = 4, replace = 1), + c(node1 = 1, node2 = 5, replace = 1) + ), + label = "when tie i -> l is created" ) - expect_null(update_DyNAM_choice_four(mTwoMode, - sender = 1, receiver = 1, replace = 1, - cache = m0 - )$changes, - label = "when sender and receiver are the same node" + expect_null( + update_DyNAM_choice_four(mTwoMode, + sender = 1, receiver = 1, replace = 1, + cache = m0 + )$changes, + label = "when sender and receiver are the same node" ) # NULL, not self-loops - expect_equal(update_DyNAM_choice_four(mTwoMode, - sender = 1, receiver = 5, replace = 1, - cache = m0 - )$changes, - rbind( - c(node1 = 1, node2 = 2, replace = 1), - c(node1 = 3, node2 = 2, replace = 1), - c(node1 = 1, node2 = 4, replace = 1), - c(node1 = 3, node2 = 5, replace = 1) - ), - label = "when previous value was NA" + expect_equal( + update_DyNAM_choice_four(mTwoMode, + sender = 1, receiver = 5, replace = 1, + cache = m0 + )$changes, + rbind( + c(node1 = 1, node2 = 2, replace = 1), + c(node1 = 3, node2 = 2, replace = 1), + c(node1 = 1, node2 = 4, replace = 1), + c(node1 = 3, node2 = 5, replace = 1) + ), + label = "when previous value was NA" ) - expect_equal(update_DyNAM_choice_four(mTwoMode, - sender = 1, receiver = 2, replace = NA, - cache = m0 - )$changes, - rbind(c(node1 = 1, node2 = 4, replace = 0), - c(node1 = 1, node2 = 5, replace = 0)), - label = "when replace is NA" + expect_equal( + update_DyNAM_choice_four(mTwoMode, + sender = 1, receiver = 2, replace = NA, + cache = m0 + )$changes, + rbind( + c(node1 = 1, node2 = 4, replace = 0), + c(node1 = 1, node2 = 5, replace = 0) + ), + label = "when replace is NA" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_indeg.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_indeg.R index 4f323f2..61d1f66 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_indeg.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_indeg.R @@ -33,29 +33,33 @@ test_that("indeg returns NULL if there is no change", { sender = 1, receiver = 2, replace = 1, cache = vCache, n1 = 5, n2 = 0 )$changes) - expect_null(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 1, replace = 0, - cache = vCache, n1 = 5, n2 = 0 - )$changes, - label = "when sender and receiver are the same node" + expect_null( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 1, replace = 0, + cache = vCache, n1 = 5, n2 = 0 + )$changes, + label = "when sender and receiver are the same node" ) - expect_null(update_DyNAM_choice_indeg(m, - sender = 5, receiver = 1, replace = NA, - cache = vCache, n1 = 5, n2 = 0 - )$changes, - label = "when previous value and replace are NA" + expect_null( + update_DyNAM_choice_indeg(m, + sender = 5, receiver = 1, replace = NA, + cache = vCache, n1 = 5, n2 = 0 + )$changes, + label = "when previous value and replace are NA" ) - expect_null(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 2, replace = 2.5, - weighted = FALSE, cache = vCache, n1 = 5, n2 = 0 - )$changes, - label = "when weighted is set to FALSE and an updated tie already exists" + expect_null( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 2, replace = 2.5, + weighted = FALSE, cache = vCache, n1 = 5, n2 = 0 + )$changes, + label = "when weighted is set to FALSE and an updated tie already exists" ) - expect_null(update_DyNAM_choice_indeg(m, - sender = 4, receiver = 1, replace = 2, - weighted = TRUE, cache = vCache, n1 = 5, n2 = 0 - )$changes, - label = "when weighted is set to TRUE and the updated weight is identical" + expect_null( + update_DyNAM_choice_indeg(m, + sender = 4, receiver = 1, replace = 2, + weighted = TRUE, cache = vCache, n1 = 5, n2 = 0 + )$changes, + label = "when weighted is set to TRUE and the updated weight is identical" ) }) @@ -67,19 +71,21 @@ test_that("indeg recognizes tie creation and updates correctly", { )$changes, cbind(node1 = c(1, 2, 3, 5), node2 = rep(4, 4), replace = rep(2, 4)) ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 5, receiver = 1, replace = 1, - cache = vCache, n1 = 5, n2 = 0 - )$changes, - cbind(node1 = 2:5, node2 = rep(1, 4), replace = rep(1, 4)), - label = "when previous value was NA" + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 5, receiver = 1, replace = 1, + cache = vCache, n1 = 5, n2 = 0 + )$changes, + cbind(node1 = 2:5, node2 = rep(1, 4), replace = rep(1, 4)), + label = "when previous value was NA" ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 2, replace = NA, - cache = vCache, n1 = 5, n2 = 0 - )$changes, - cbind(node1 = c(1, 3:5), node2 = rep(2, 4), replace = rep(1, 4)), - label = "when replace is NA" + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 2, replace = NA, + cache = vCache, n1 = 5, n2 = 0 + )$changes, + cbind(node1 = c(1, 3:5), node2 = rep(2, 4), replace = rep(1, 4)), + label = "when replace is NA" ) }) @@ -91,73 +97,81 @@ test_that("indeg recognizes tie deletion correctly", { )$changes, cbind(node1 = c(1, 3:5), node2 = rep(2, 4), replace = rep(1, 4)) ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 5, receiver = 1, replace = 0, - cache = vCache, n1 = 5, n2 = 0 - )$changes, - cbind(node1 = 2:5, node2 = rep(1, 4), replace = rep(0, 4)), - label = "when previous value was NA" + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 5, receiver = 1, replace = 0, + cache = vCache, n1 = 5, n2 = 0 + )$changes, + cbind(node1 = 2:5, node2 = rep(1, 4), replace = rep(0, 4)), + label = "when previous value was NA" ) }) test_that("indeg recognizes updates to tie weights correctly", { - expect_equal(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 5, replace = 2, - cache = vCache, n1 = 5, n2 = 0, - weighted = TRUE - )$changes, - cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(2, 4)), - label = "when a tie is created" - ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 2, replace = 0.5, - cache = vCache, n1 = 5, n2 = 0, - weighted = TRUE - )$changes, - cbind(node1 = c(1, 3:5), node2 = rep(2, 4), replace = rep(1.5, 4)), - label = "when an existing tie is updated" - ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 5, replace = -2, - cache = vCache, n1 = 5, n2 = 0, - weighted = TRUE - )$changes, - cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(-2, 4)), - label = "when replace is negative" - ) - expect_equal(update_DyNAM_choice_indeg(m, - sender = 1, receiver = 5, replace = 2, - cache = vCache, n1 = 5, n2 = 0, - weighted = TRUE, transformFun = sqrt - )$changes, - cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(sqrt(2), 4)), - label = "when transformFun is specified" + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 5, replace = 2, + cache = vCache, n1 = 5, n2 = 0, + weighted = TRUE + )$changes, + cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(2, 4)), + label = "when a tie is created" + ) + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 2, replace = 0.5, + cache = vCache, n1 = 5, n2 = 0, + weighted = TRUE + )$changes, + cbind(node1 = c(1, 3:5), node2 = rep(2, 4), replace = rep(1.5, 4)), + label = "when an existing tie is updated" + ) + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 5, replace = -2, + cache = vCache, n1 = 5, n2 = 0, + weighted = TRUE + )$changes, + cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(-2, 4)), + label = "when replace is negative" + ) + expect_equal( + update_DyNAM_choice_indeg(m, + sender = 1, receiver = 5, replace = 2, + cache = vCache, n1 = 5, n2 = 0, + weighted = TRUE, transformFun = sqrt + )$changes, + cbind(node1 = 1:4, node2 = rep(5, 4), replace = rep(sqrt(2), 4)), + label = "when transformFun is specified" ) }) test_that("indeg recognizes changes to two-mode networks correctly", { - expect_equal(update_DyNAM_choice_indeg(mBipar, - sender = 1, receiver = 4, replace = 1, - cache = vCache, n1 = 2, n2 = 3, - isTwoMode = TRUE - )$changes, - cbind(node1 = 1:2, node2 = rep(4, 2), replace = rep(2, 2)), - label = "when a tie is created" - ) - expect_equal(update_DyNAM_choice_indeg(mBipar, - sender = 1, receiver = 3, replace = 0, - cache = vCache, n1 = 2, n2 = 3, - isTwoMode = TRUE - )$changes, - cbind(node1 = 1:2, node2 = rep(3, 2), replace = rep(2, 2)), - label = "when a tie is deleted" - ) - expect_equal(update_DyNAM_choice_indeg(mBipar, - sender = 1, receiver = 3, replace = 1.5, - cache = vCache, n1 = 2, n2 = 3, - isTwoMode = TRUE, weighted = TRUE - )$changes, - cbind(node1 = 1:2, node2 = rep(3, 2), replace = rep(3.5, 2)), - label = "when a weighted tie is updated" + expect_equal( + update_DyNAM_choice_indeg(mBipar, + sender = 1, receiver = 4, replace = 1, + cache = vCache, n1 = 2, n2 = 3, + isTwoMode = TRUE + )$changes, + cbind(node1 = 1:2, node2 = rep(4, 2), replace = rep(2, 2)), + label = "when a tie is created" + ) + expect_equal( + update_DyNAM_choice_indeg(mBipar, + sender = 1, receiver = 3, replace = 0, + cache = vCache, n1 = 2, n2 = 3, + isTwoMode = TRUE + )$changes, + cbind(node1 = 1:2, node2 = rep(3, 2), replace = rep(2, 2)), + label = "when a tie is deleted" + ) + expect_equal( + update_DyNAM_choice_indeg(mBipar, + sender = 1, receiver = 3, replace = 1.5, + cache = vCache, n1 = 2, n2 = 3, + isTwoMode = TRUE, weighted = TRUE + )$changes, + cbind(node1 = 1:2, node2 = rep(3, 2), replace = rep(3.5, 2)), + label = "when a weighted tie is updated" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_inertia.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_inertia.R index f533d6a..115b3b7 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_inertia.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_inertia.R @@ -6,40 +6,55 @@ test_that("inertia returns a valid object on update", { expect_true( inherits( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 5, replace = 1)$changes, + m, + sender = 1, receiver = 5, replace = 1 + )$changes, "matrix" ), label = "it doesn't return a matrix" ) expect_length( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 5, replace = 1)$changes, - 3) + m, + sender = 1, receiver = 5, replace = 1 + )$changes, + 3 + ) }) test_that("inertia returns NULL if there is no change on update", { expect_null( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 2, replace = 1)$changes - ) + m, + sender = 1, receiver = 2, replace = 1 + )$changes + ) expect_null( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 1, replace = 0)$changes, + m, + sender = 1, receiver = 1, replace = 0 + )$changes, label = "when sender and receiver are the same node" ) expect_null( update_DyNAM_choice_inertia( - m, sender = 5, receiver = 1, replace = NA)$changes, + m, + sender = 5, receiver = 1, replace = NA + )$changes, label = "when previous value and replace are NA" ) expect_null( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 2, replace = 2.5, weighted = FALSE)$changes, + m, + sender = 1, receiver = 2, replace = 2.5, weighted = FALSE + )$changes, label = "when weighted is set to FALSE and an updated tie already exists" ) expect_null( update_DyNAM_choice_inertia( - m, sender = 4, receiver = 1, replace = 2, weighted = TRUE)$changes, + m, + sender = 4, receiver = 1, replace = 2, weighted = TRUE + )$changes, label = "when weighted is set to TRUE and the updated weight is identical" ) }) @@ -47,22 +62,31 @@ test_that("inertia returns NULL if there is no change on update", { test_that("inertia recognizes tie creation and updates correctly", { expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 5, replace = 1)$changes, + m, + sender = 1, receiver = 5, replace = 1 + )$changes, matrix(c(1, 5, 1), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))) + dimnames = list(NULL, c("node1", "node2", "replace")) + ) ) expect_equal( update_DyNAM_choice_inertia( - m, sender = 5, receiver = 1, replace = 1)$changes, + m, + sender = 5, receiver = 1, replace = 1 + )$changes, matrix(c(5, 1, 1), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when previous value was NA" ) expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 3, replace = NA)$changes, + m, + sender = 1, receiver = 3, replace = NA + )$changes, matrix(c(1, 3, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when replace is NA" ) }) @@ -70,15 +94,21 @@ test_that("inertia recognizes tie creation and updates correctly", { test_that("inertia recognizes tie deletion correctly", { expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 3, replace = 0)$changes, + m, + sender = 1, receiver = 3, replace = 0 + )$changes, matrix(c(1, 3, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))) + dimnames = list(NULL, c("node1", "node2", "replace")) + ) ) expect_equal( update_DyNAM_choice_inertia( - m, sender = 5, receiver = 1, replace = 0)$changes, + m, + sender = 5, receiver = 1, replace = 0 + )$changes, matrix(c(5, 1, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when previous value was NA" ) }) @@ -86,23 +116,32 @@ test_that("inertia recognizes tie deletion correctly", { test_that("inertia recognizes updates to tie weights correctly", { expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 5, replace = 2, weighted = TRUE)$changes, + m, + sender = 1, receiver = 5, replace = 2, weighted = TRUE + )$changes, matrix(c(1, 5, 2), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when a tie is created" ) expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 3, replace = 2, weighted = TRUE)$changes, + m, + sender = 1, receiver = 3, replace = 2, weighted = TRUE + )$changes, matrix(c(1, 3, 2), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when an existing tie is updated" ) expect_equal( update_DyNAM_choice_inertia( - m, sender = 1, receiver = 5, replace = -1, weighted = TRUE)$changes, + m, + sender = 1, receiver = 5, replace = -1, weighted = TRUE + )$changes, matrix(c(1, 5, -1), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when replace is negative" ) expect_equal( @@ -112,7 +151,8 @@ test_that("inertia recognizes updates to tie weights correctly", { transformFun = function(x) `^`(x, 2) )$changes, matrix(c(1, 3, 4), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when transformFun is specified" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_recip.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_recip.R index 1c4af29..cd08a4d 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_recip.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_recip.R @@ -6,59 +6,81 @@ test_that("recip returns a valid object on update", { expect_true( inherits( update_DyNAM_choice_recip( - m, sender = 1, receiver = 5, replace = 1)$changes, + m, + sender = 1, receiver = 5, replace = 1 + )$changes, "matrix" ), label = "it doesn't return a matrix" ) expect_length( update_DyNAM_choice_recip( - m, sender = 1, receiver = 5, replace = 1)$changes[1, ], - 3) + m, + sender = 1, receiver = 5, replace = 1 + )$changes[1, ], + 3 + ) }) test_that("recip returns NULL if there is no change on update", { expect_null( update_DyNAM_choice_recip( - m, sender = 1, receiver = 2, replace = 1)$changes) + m, + sender = 1, receiver = 2, replace = 1 + )$changes + ) expect_null( update_DyNAM_choice_recip( - m, sender = 1, receiver = 1, replace = 0)$changes, + m, + sender = 1, receiver = 1, replace = 0 + )$changes, label = "when sender and receiver are the same node" ) expect_null( update_DyNAM_choice_recip( - m, sender = 5, receiver = 1, replace = NA)$changes, + m, + sender = 5, receiver = 1, replace = NA + )$changes, label = "when previous value and replace are NA" ) - expect_null(update_DyNAM_choice_recip( - m, - sender = 1, receiver = 2, replace = 2.5, - weighted = FALSE - )$changes, - label = "when weighted is set to FALSE and an updated tie already exists" + expect_null( + update_DyNAM_choice_recip( + m, + sender = 1, receiver = 2, replace = 2.5, + weighted = FALSE + )$changes, + label = "when weighted is set to FALSE and an updated tie already exists" ) }) test_that("recip recognizes tie creation and updates correctly", { expect_equal( update_DyNAM_choice_recip( - m, sender = 1, receiver = 4, replace = 1)$changes, + m, + sender = 1, receiver = 4, replace = 1 + )$changes, matrix(c(4, 1, 1), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))) + dimnames = list(NULL, c("node1", "node2", "replace")) + ) ) expect_equal( update_DyNAM_choice_recip( - m, sender = 5, receiver = 1, replace = 1)$changes, + m, + sender = 5, receiver = 1, replace = 1 + )$changes, matrix(c(1, 5, 1), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when previous value was NA" ) expect_equal( update_DyNAM_choice_recip( - m, sender = 1, receiver = 2, replace = NA)$changes, + m, + sender = 1, receiver = 2, replace = NA + )$changes, matrix(c(2, 1, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when replace is NA" ) }) @@ -66,22 +88,31 @@ test_that("recip recognizes tie creation and updates correctly", { test_that("recip recognizes tie deletion correctly", { expect_equal( update_DyNAM_choice_recip( - m, sender = 1, receiver = 2, replace = 0)$changes, + m, + sender = 1, receiver = 2, replace = 0 + )$changes, matrix(c(2, 1, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))) + dimnames = list(NULL, c("node1", "node2", "replace")) + ) ) expect_equal( update_DyNAM_choice_recip( - m, sender = 5, receiver = 1, replace = 0)$changes, + m, + sender = 5, receiver = 1, replace = 0 + )$changes, matrix(c(1, 5, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when previous value was NA" ) expect_equal( update_DyNAM_choice_recip( - m, sender = 1, receiver = 2, replace = NA)$changes, + m, + sender = 1, receiver = 2, replace = NA + )$changes, matrix(c(2, 1, 0), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when replace is NA" ) }) @@ -94,7 +125,8 @@ test_that("recip recognizes updates to tie weights correctly", { weighted = TRUE )$changes, matrix(c(4, 1, 2), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when a tie is created" ) expect_equal( @@ -104,27 +136,30 @@ test_that("recip recognizes updates to tie weights correctly", { weighted = TRUE )$changes, matrix(c(2, 1, 0.5), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), + dimnames = list(NULL, c("node1", "node2", "replace")) + ), label = "when an existing tie is updated" ) expect_equal( update_DyNAM_choice_recip( m, - sender = 1, receiver = 4, replace = -2, - weighted = TRUE - )$changes, - matrix(c(4, 1, -2), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), - label = "when replace is negative" + sender = 1, receiver = 4, replace = -2, + weighted = TRUE + )$changes, + matrix(c(4, 1, -2), 1, 3, + dimnames = list(NULL, c("node1", "node2", "replace")) + ), + label = "when replace is negative" ) expect_equal( update_DyNAM_choice_recip( m, - sender = 1, receiver = 4, replace = 2, - weighted = TRUE, transformFun = function(x) x * x - )$changes, - matrix(c(4, 1, 4), 1, 3, - dimnames = list(NULL, c("node1", "node2", "replace"))), - label = "when transformFun is specified" + sender = 1, receiver = 4, replace = 2, + weighted = TRUE, transformFun = function(x) x * x + )$changes, + matrix(c(4, 1, 4), 1, 3, + dimnames = list(NULL, c("node1", "node2", "replace")) + ), + label = "when transformFun is specified" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_same.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_same.R index cb8e63a..38438e4 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_same.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_same.R @@ -1,13 +1,15 @@ test_that("same returns a valid object on update", { expect_type( update_DyNAM_choice_same( - attribute = testAttr$fishingSkill, node = 1, replace = 1), + attribute = testAttr$fishingSkill, node = 1, replace = 1 + ), "list" ) expect_true( inherits( update_DyNAM_choice_same( - attribute = testAttr$fishingSkill, node = 1, replace = 1)$changes, + attribute = testAttr$fishingSkill, node = 1, replace = 1 + )$changes, "matrix" ), label = "it doesn't return a matrix" @@ -17,20 +19,29 @@ test_that("same returns a valid object on update", { test_that("same returns NULL if there is no change", { expect_null( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 1, replace = 10)$changes) + testAttr$fishingSkill, + node = 1, replace = 10 + )$changes + ) expect_null( update_DyNAM_choice_same( - testAttr$fishSizeMean, node = 1, replace = 0.15)$changes, + testAttr$fishSizeMean, + node = 1, replace = 0.15 + )$changes, label = "when no match results from update" ) expect_null( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 7, replace = 2)$changes, + testAttr$fishingSkill, + node = 7, replace = 2 + )$changes, label = "when new and old attribute have no match" ) expect_null( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 2, replace = NA)$changes, + testAttr$fishingSkill, + node = 2, replace = NA + )$changes, label = "when replace is NA" ) }) @@ -38,7 +49,9 @@ test_that("same returns NULL if there is no change", { test_that("same returns correct attributes on update", { expect_equal( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 2, replace = 10)$changes, + testAttr$fishingSkill, + node = 2, replace = 10 + )$changes, rbind( c(node1 = 2, node2 = 1, replace = 1), c(node1 = 2, node2 = 4, replace = 1), @@ -49,7 +62,9 @@ test_that("same returns correct attributes on update", { ) expect_equal( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 1, replace = 2)$changes, + testAttr$fishingSkill, + node = 1, replace = 2 + )$changes, rbind( c(node1 = 1, node2 = 4, replace = 0), c(node1 = 4, node2 = 1, replace = 0) @@ -58,7 +73,9 @@ test_that("same returns correct attributes on update", { ) expect_equal( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 1, replace = NA)$changes, + testAttr$fishingSkill, + node = 1, replace = NA + )$changes, rbind( c(node1 = 1, node2 = 4, replace = 0), c(node1 = 4, node2 = 1, replace = 0) @@ -67,7 +84,9 @@ test_that("same returns correct attributes on update", { ) expect_equal( update_DyNAM_choice_same( - testAttr$fishingSkill, node = 8, replace = 10)$changes, + testAttr$fishingSkill, + node = 8, replace = 10 + )$changes, rbind( c(node1 = 8, node2 = 1, replace = 1), c(node1 = 8, node2 = 4, replace = 1), diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_sim.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_sim.R index c435632..02793e1 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_sim.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_sim.R @@ -12,7 +12,8 @@ test_that("sim returns a valid object on update", { attribute = testAttr$fishingSkill, node = 1, replace = 1, n1 = 8, n2 = 0 )$changes, - "matrix"), + "matrix" + ), label = "it doesn't return a matrix" ) }) @@ -23,12 +24,13 @@ test_that("sim equals NULL if there is no change", { node = 7, replace = 3, n1 = 8, n2 = 0 )$changes) - expect_null(update_DyNAM_choice_sim( - testAttr$fishingSkill, - node = 2, replace = NA, - n1 = 8, n2 = 0 - )$changes, - label = "when replace is NA" + expect_null( + update_DyNAM_choice_sim( + testAttr$fishingSkill, + node = 2, replace = NA, + n1 = 8, n2 = 0 + )$changes, + label = "when replace is NA" ) }) @@ -40,49 +42,68 @@ test_that("sim returns correct attributes on update", { n1 = 8, n2 = 0 )$changes, rbind( - cbind(node1 = rep(5, 7), node2 = c(1:4, 6:8), - replace = c(0, NA, -5, 0, -2, -7, NA)), - cbind(node1 = c(1:4, 6:8), node2 = rep(5, 7), - replace = c(0, NA, -5, 0, -2, -7, NA)) + cbind( + node1 = rep(5, 7), node2 = c(1:4, 6:8), + replace = c(0, NA, -5, 0, -2, -7, NA) + ), + cbind( + node1 = c(1:4, 6:8), node2 = rep(5, 7), + replace = c(0, NA, -5, 0, -2, -7, NA) + ) ) ) - expect_equal(update_DyNAM_choice_sim( - testAttr$fishingSkill, - node = 1, replace = 0, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(1, 7), node2 = 2:8, - replace = -testAttr$fishingSkill[-1]), - cbind(node1 = 2:8, node2 = rep(1, 7), - replace = -testAttr$fishingSkill[-1]) - ), - label = "when replace is 0" + expect_equal( + update_DyNAM_choice_sim( + testAttr$fishingSkill, + node = 1, replace = 0, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind( + node1 = rep(1, 7), node2 = 2:8, + replace = -testAttr$fishingSkill[-1] + ), + cbind( + node1 = 2:8, node2 = rep(1, 7), + replace = -testAttr$fishingSkill[-1] + ) + ), + label = "when replace is 0" ) - expect_equal(update_DyNAM_choice_sim( - testAttr$fishingSkill, - node = 1, replace = NA, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(1, 7), node2 = 2:8, - replace = c(NA, -1.8, -3.2, -1.2, -1.2, -3.8, NA)), - cbind(node1 = 2:8, node2 = rep(1, 7), - replace = c(NA, -1.8, -3.2, -1.2, -1.2, -3.8, NA)) - ), - label = "when replace is NA" + expect_equal( + update_DyNAM_choice_sim( + testAttr$fishingSkill, + node = 1, replace = NA, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind( + node1 = rep(1, 7), node2 = 2:8, + replace = c(NA, -1.8, -3.2, -1.2, -1.2, -3.8, NA) + ), + cbind( + node1 = 2:8, node2 = rep(1, 7), + replace = c(NA, -1.8, -3.2, -1.2, -1.2, -3.8, NA) + ) + ), + label = "when replace is NA" ) - expect_equal(update_DyNAM_choice_sim( - testAttr$fishingSkill, - node = 2, replace = 10, - n1 = 8, n2 = 0 - )$changes, - rbind( - cbind(node1 = rep(2, 7), node2 = c(1, 3:8), - replace = c(0, -5, 0, -2, -2, -7, NA)), - cbind(ndoe1 = c(1, 3:8), node2 = rep(2, 7), - replace = c(0, -5, 0, -2, -2, -7, NA)) - ), - label = "when old value was NA" + expect_equal( + update_DyNAM_choice_sim( + testAttr$fishingSkill, + node = 2, replace = 10, + n1 = 8, n2 = 0 + )$changes, + rbind( + cbind( + node1 = rep(2, 7), node2 = c(1, 3:8), + replace = c(0, -5, 0, -2, -2, -7, NA) + ), + cbind( + ndoe1 = c(1, 3:8), node2 = rep(2, 7), + replace = c(0, -5, 0, -2, -2, -7, NA) + ) + ), + label = "when old value was NA" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_choice-update_trans.R b/tests/testthat/test-functions_effects_DyNAM_choice-update_trans.R index 8eaf30c..c16032b 100644 --- a/tests/testthat/test-functions_effects_DyNAM_choice-update_trans.R +++ b/tests/testthat/test-functions_effects_DyNAM_choice-update_trans.R @@ -9,12 +9,13 @@ test_that("trans returns a valid object on update", { ) expect_true( inherits( - update_DyNAM_choice_trans( - m, - sender = 1, receiver = 5, replace = 1, - cache = m0 - )$changes, - "matrix"), + update_DyNAM_choice_trans( + m, + sender = 1, receiver = 5, replace = 1, + cache = m0 + )$changes, + "matrix" + ), label = "it doesn't return a matrix" ) expect_length( @@ -33,33 +34,37 @@ test_that("trans returns NULL if there is no change", { sender = 1, receiver = 2, replace = 1, cache = m0 )$changes) - expect_null(update_DyNAM_choice_trans( - m, - sender = 1, receiver = 1, replace = 0, - cache = m0 - )$changes, - label = "when sender and receiver are the same node" + expect_null( + update_DyNAM_choice_trans( + m, + sender = 1, receiver = 1, replace = 0, + cache = m0 + )$changes, + label = "when sender and receiver are the same node" ) - expect_null(update_DyNAM_choice_trans( - m, - sender = 5, receiver = 1, replace = NA, - cache = m0 - )$changes, - label = "when previous value and replace are NA" + expect_null( + update_DyNAM_choice_trans( + m, + sender = 5, receiver = 1, replace = NA, + cache = m0 + )$changes, + label = "when previous value and replace are NA" ) - expect_null(update_DyNAM_choice_trans( - m0, - sender = 5, receiver = 4, replace = 1, - cache = m0 - )$changes, - label = "when change in tie composition has no effect" + expect_null( + update_DyNAM_choice_trans( + m0, + sender = 5, receiver = 4, replace = 1, + cache = m0 + )$changes, + label = "when change in tie composition has no effect" ) - expect_null(update_DyNAM_choice_trans( - m, - sender = 1, receiver = 2, replace = 1.5, - cache = m0 - )$changes, - label = "when weighted is set to FALSE and an updated tie already exists" + expect_null( + update_DyNAM_choice_trans( + m, + sender = 1, receiver = 2, replace = 1.5, + cache = m0 + )$changes, + label = "when weighted is set to FALSE and an updated tie already exists" ) }) diff --git a/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R b/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R index 42bf027..4aeaba5 100644 --- a/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R +++ b/tests/testthat/test-functions_effects_DyNAM_rate-update_ego.R @@ -1,4 +1,3 @@ - test_that("ego returns a valid matrix", { expect_type( update_DyNAM_rate_ego( diff --git a/tests/testthat/test-functions_estimation_engine_c.R b/tests/testthat/test-functions_estimation_engine_c.R index daf2b21..328ad06 100644 --- a/tests/testthat/test-functions_estimation_engine_c.R +++ b/tests/testthat/test-functions_estimation_engine_c.R @@ -16,8 +16,10 @@ test_that( formula, model = model, subModel = subModel, - estimationInit = list(startTime = 0, engine = "default_c", - returnIntervalLogL = TRUE) + estimationInit = list( + startTime = 0, engine = "default_c", + returnIntervalLogL = TRUE + ) ) modCgc <- estimate( formula, diff --git a/tests/testthat/test-functions_postestimate.R b/tests/testthat/test-functions_postestimate.R index 4e99977..5d11646 100644 --- a/tests/testthat/test-functions_postestimate.R +++ b/tests/testthat/test-functions_postestimate.R @@ -88,8 +88,10 @@ test_that("vcov function", { expect_equal( vcov.result.goldfish(resModObject), matrix( - c(0.0241456179209463, -0.00230482755796413, - -0.00230482755796413, 0.0390106272519763), + c( + 0.0241456179209463, -0.00230482755796413, + -0.00230482755796413, 0.0390106272519763 + ), ncol = 2, nrow = 2, dimnames = list(c("inertia", "trans"), c("inertia", "trans")) ), @@ -110,12 +112,16 @@ test_that("vcov function", { expect_equal( vcov.result.goldfish(resModObject, complete = TRUE), matrix( - c(0.0241456179209463, NA, -0.00230482755796413, + c( + 0.0241456179209463, NA, -0.00230482755796413, NA, NA, NA, - -0.00230482755796413, NA, 0.0390106272519763), + -0.00230482755796413, NA, 0.0390106272519763 + ), ncol = 3, nrow = 3, - dimnames = list(c("inertia", "recip", "trans"), - c("inertia", "recip", "trans")) + dimnames = list( + c("inertia", "recip", "trans"), + c("inertia", "recip", "trans") + ) ), label = "correct output when complete = TRUE" ) diff --git a/vignettes/goldfishEffects.Rmd b/vignettes/goldfishEffects.Rmd index e0ad520..33b3ccc 100644 --- a/vignettes/goldfishEffects.Rmd +++ b/vignettes/goldfishEffects.Rmd @@ -141,8 +141,10 @@ Here we refer to ego type when `type = "ego"` and alter type when ### Indegree (`indeg()`) ```{r} -indeg(network, isTwoMode = FALSE, weighted = FALSE, window = Inf, - ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity) +indeg(network, + isTwoMode = FALSE, weighted = FALSE, window = Inf, + ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity +) ``` \begin{align} @@ -177,8 +179,10 @@ The degree can be transform with \code{transformFun}. ### Outdegree (`outdeg()`) ```{r} -outdeg(network, isTwoMode = FALSE, weighted = FALSE, window = Inf, - ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity) +outdeg(network, + isTwoMode = FALSE, weighted = FALSE, window = Inf, + ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity +) ``` \begin{align} @@ -207,8 +211,10 @@ outdeg(network, isTwoMode = FALSE, weighted = FALSE, window = Inf, ### Node embeddedness transitivity (`nodeTrans()`) ```{r} -nodeTrans(network, isTwoMode = FALSE, window = Inf, ignoreRep = FALSE, - type = c("alter", "ego"), transformFun = identity) +nodeTrans(network, + isTwoMode = FALSE, window = Inf, ignoreRep = FALSE, + type = c("alter", "ego"), transformFun = identity +) ``` \begin{align} @@ -285,9 +291,11 @@ alter(attribute, isTwoMode = FALSE) ### Tertius (`tertius()`) ```{r} -tertius(network, attribute, isTwoMode = FALSE, window = Inf, - ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity, - aggregateFun = function(x) mean(x, na.rm = TRUE)) +tertius(network, attribute, + isTwoMode = FALSE, window = Inf, + ignoreRep = FALSE, type = c("alter", "ego"), transformFun = identity, + aggregateFun = function(x) mean(x, na.rm = TRUE) +) ``` \begin{align} @@ -329,8 +337,10 @@ as the average of the aggregate values of nodes with in-neighbors. ### Tie (`tie()`) ```{r} -tie(network, weighted = FALSE, window = Inf, ignoreRep = FALSE, - transformFun = identity) +tie(network, + weighted = FALSE, window = Inf, ignoreRep = FALSE, + transformFun = identity +) ``` \begin{equation} @@ -380,8 +390,10 @@ statistics with zeros. ### Tie reciprocation (`recip()`) ```{r} -recip(network, weighted = FALSE, window = Inf, ignoreRep = FALSE, - transformFun = identity) +recip(network, + weighted = FALSE, window = Inf, ignoreRep = FALSE, + transformFun = identity +) ``` \begin{equation} @@ -487,9 +499,11 @@ when $j$ score high on `attribute2` moderated by the score of ego on ### Tertius difference (`tertiusDiff()`) ```{r} -tertiusDiff(network, attribute, isTwoMode = FALSE, weighted = FALSE, - window = Inf, ignoreRep = FALSE, transformFun = abs, - aggregateFun = function(x) mean(x, na.rm = TRUE)) +tertiusDiff(network, attribute, + isTwoMode = FALSE, weighted = FALSE, + window = Inf, ignoreRep = FALSE, transformFun = abs, + aggregateFun = function(x) mean(x, na.rm = TRUE) +) ``` \begin{equation} @@ -571,8 +585,10 @@ DyNAM-choice_coordination. ### Common receiver closure (`commonReceiver()`) ```{r} -commonReceiver(network, window = Inf, ignoreRep = FALSE, - transformFun = identity) +commonReceiver(network, + window = Inf, ignoreRep = FALSE, + transformFun = identity +) ``` \begin{equation} @@ -589,8 +605,10 @@ DyNAM-choice_coordination. ### Four cycle (`four()`) ```{r} -four(network, isTwoMode = FALSE, window = Inf, ignoreRep = FALSE, - transformFun = identity) +four(network, + isTwoMode = FALSE, window = Inf, ignoreRep = FALSE, + transformFun = identity +) ``` \begin{equation} @@ -608,8 +626,10 @@ DyNAM-choice_coordination. ### Mixed Transitivity (`mixedTrans()`) ```{r} -mixedTrans(network = list(network1, network2), window = Inf, - ignoreRep = FALSE, transformFun = identity) +mixedTrans( + network = list(network1, network2), window = Inf, + ignoreRep = FALSE, transformFun = identity +) ``` \begin{equation} @@ -627,8 +647,10 @@ This effect cannot be used for two-mode networks. ### Mixed Cycle (`mixedCycle()`) ```{r} -mixedCycle(network = list(network1, network2), window = Inf, - ignoreRep = FALSE, transformFun = identity) +mixedCycle( + network = list(network1, network2), window = Inf, + ignoreRep = FALSE, transformFun = identity +) ``` \begin{equation} @@ -647,8 +669,10 @@ DyNAM-choice_coordination. ### Mixed common sender closure (`mixedCommonSender()`) ```{r} -mixedCommonSender(network = list(network1, network2), window = Inf, - ignoreRep = FALSE, transformFun = identity) +mixedCommonSender( + network = list(network1, network2), window = Inf, + ignoreRep = FALSE, transformFun = identity +) ``` \begin{equation} @@ -667,8 +691,10 @@ DyNAM-choice_coordination. ### Mixed common receiver closure (`mixedCommonReceiver()`) ```{r} -mixedCommonReceiver(network = list(network1, network2), window = Inf, - ignoreRep = FALSE, transformFun = identity) +mixedCommonReceiver( + network = list(network1, network2), window = Inf, + ignoreRep = FALSE, transformFun = identity +) ``` \begin{equation} From f95188fa7355f2a6b82ed0413bc87de1506bfb98 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 11 Oct 2023 15:11:21 +0200 Subject: [PATCH 12/36] Solves #86 creating temporal flags and sender position objects --- R/functions_estimation_engine.R | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 7acd573..77e19d4 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -484,7 +484,7 @@ getEventValues <- function( eventProbabilities <- getMultinomialProbabilities( statsArray, activeDyad, parameters, - actorNested = TRUE, allowReflexive = FALSE, isTwoMode = isTwoMode + actorNested = TRUE, allowReflexive = allowReflexive, isTwoMode = isTwoMode ) logLikelihood <- log(eventProbabilities[activeDyad[2]]) firstDerivatives <- getFirstDerivativeM(statsArray, eventProbabilities) @@ -925,12 +925,19 @@ getIterationStepState <- function( ) } + posSender <- activeDyad[1] activeDyad[1] <- position } + } else { + posSender <- activeDyad[1] } if (updatepresence2 || updateopportunities) { subset <- presence2 & opportunities - statsArrayComp <- statsArrayComp[, subset, , drop = TRUE] + if (!allowReflexive) { + subset[posSender] <- FALSE + allowReflexiveCorrected <- TRUE + } + statsArrayComp <- statsArrayComp[, subset, , drop = FALSE] if (isDependent) { position <- which(activeDyad[2] == which(subset)) if (length(position) == 0) { @@ -941,6 +948,8 @@ getIterationStepState <- function( activeDyad[2] <- position } + } else { + allowReflexiveCorrected <- allowReflexive } # TEMPORARY: handle the reductions here for now @@ -989,7 +998,7 @@ getIterationStepState <- function( modelType = modelType, isRightCensored = isRightCensored, timespan = timespan, - allowReflexive = allowReflexive, + allowReflexive = allowReflexiveCorrected, isTwoMode = isTwoMode ) From 501614144ca1dcfc6a9b9f42375d1680a79f4f05 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 11 Oct 2023 15:16:08 +0200 Subject: [PATCH 13/36] Solves bug in printing output objects when DyNAM-choice formula has intercept --- R/functions_estimation.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/functions_estimation.R b/R/functions_estimation.R index dbc8b32..53820ad 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -411,7 +411,7 @@ estimate.formula <- function( " ignores the time intercept.", call. = FALSE, immediate. = TRUE ) - hasIntercept <- FALSE + parsedformula$hasIntercept <- hasIntercept <- FALSE } rightCensored <- hasIntercept From 6e02e2844bb0557cbd47d6295d2b3c9673d81051 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 11 Oct 2023 15:53:09 +0200 Subject: [PATCH 14/36] Update vignettes to the latest release of `manynet` and `migraph` --- DESCRIPTION | 1 + vignettes/teaching/plot-teaching1-1.png | Bin 1722 -> 1738 bytes vignettes/teaching/plot-teaching2-1.png | Bin 9986 -> 11946 bytes vignettes/teaching1.R | 58 +++++++++++------------ vignettes/teaching1.Rmd | 12 +---- vignettes/teaching2.R | 60 ++++++++++++------------ vignettes/teaching2.Rmd | 59 +++++------------------ vignettes/teaching2.Rmd.orig | 10 ++-- 8 files changed, 82 insertions(+), 118 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 6519253..5bcf9c2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -54,6 +54,7 @@ Suggests: igraph, ggraph, migraph, + manynet, broom, lmtest VignetteBuilder: knitr diff --git a/vignettes/teaching/plot-teaching1-1.png b/vignettes/teaching/plot-teaching1-1.png index 28d7eab45e688cbc399cc74e137428a99868a5e5..6ef4e52c95fcff5764a9b340d65b56a8e1a6b31b 100644 GIT binary patch literal 1738 zcmeAS@N?(olHy`uVBq!ia0y~yVEh5X9LzwGiQo8rffQSSPlzj!{{R2~(wp<|0$H2| z9+AZi4BSE>%y{W;-5;Q;EKe85kcv5P?=a@wwh(Z*`0lU%-Wz&cTQcSxnWn@0^S(8s zW&Bnb%@_Uk9={5|Gwo>q5O~O)Q(m=Z3PFY__kZPW_m3wv3;Yvr?hvx``l0dAe)C7= zgZr$ln?Jm919BIO@$LV}`-6#_-~Wd)k3LAn;+B4p(#dPejz#3`Eap5f1QCGCKp9yP zKd#=ZSf71kLF@i5N4S&X^N$F>X)(RRalRI$FYEUQ<-8Tlx%OfY?bCEnoc@3N5zY-8 zj;C{;-v?6pYSxF&-Or+0`h!&9&d56Z!H=_jt)=5be&d6Wr|sbhkNIqJXfq$sk@9cm zeiwMiE_r4`U5`$4GcsI-TAk^*KB%w?3|*_Y(a1sPA`4))A>g#=Xq{O$gG%p`2Fvww@ljS z{eCc?(Sw;~wMTu``n3ki5AP?mO6qQKx#tKB-Q_!9*eU)oIrP~N6pN+BKScfZR14Xi zdH@Y})KEUv`hC)m`kjUx|Lv2Z5eQYcw&wqas=5mHr_!9~#Y4J4G4?#CSowCUe7NAe zt;)y8TFJUYe>*@P&4zjOkJ7oi6Jm9Ohl;si zNdWGa6}J!lK3A{*aB+`4B5JOG;Ny+IQEI2(zCOlqVs7314{P3C&W`v|%X$7jBwQ}9 zE!49}otT~TRV&-a`G>~IMG$egxp2k`_lLFRJ8xWN7O(5je0cMY(8Irf=Hz!yh(JFhts!~>`LBc{lEXi6%Ish|N8dB!^!8Twd_CG z63G|g)c@g5+TRbt|9imvf3&Wf%onsa+4Ud4 zF;joI|KuDjY4siF`@gr|0t+YwcrHL?yn47fo_E#nf36kxvhJ{&<=T2zE?V}%S~C1I zC%67wWo)TGO6$+5^&ZP3v!)!He_R78R=|ZYFoBivy?4E@UN*1y!+e9;8V}`f{bo;o neO6Z4Mj9om;aLeM<5m2NPxs{v1)g*Rt0D$ZS3j3^P6%y{W;-5;Q;C{Gv1kcv5P??&g{aT8$(O#eTdZ-N4w(&=kGKVID~J-0of z{Qjc}&Rq?4e_Sv1FBd;x+|n;(=k-J5;bI~f|35D_?Yfrt-=%`9rT>;`&6^{C_r*R} z{v&=y9cIM8hLiUd*!BNb9y0Fx5O~O)Q(m=Z3WQ;*`{zlzn)ggI_lN#TeW-E}Me+G3 zm-lL~%QQc~lZ0P1?HsLyjA& z2jWlm_Vc#HcYcWRMUl|s+yB0s=Q7YuK2SHQ)?DfNkjLj|p1kPL{BthQKscOM$0)h; z#a52}Ei)zGZNEFCrM}nD70D|g=aff3aXc)wT0?N2Iz&cZr-<|4)sx)OrL+45=dA?^ zUYY!G`rbKW9P+8(p#Ht0`LNb|w)+o_lZ%K5@Wo0G_bPu0Oi?&gZvrId=ALk9wV&OX z_rO}7`=NjN|C^paRL|_t>5Wi%E?mdEeZE>teDjAp&M;5Ediudw&ijMb!^KZ}cIod4 zJ{Hu{AN08Yn{CwgyEiOb(v4B#2Pur%1_Sv2|wYHmjAB&epBoHIUm~Jlz-oGw{4x`pY{I_lqqKl z*m-U1Ui<4{L`mdtfq6?g5b0I*PgUMd<~J?zU)z3#ADW-#_anN-j@S9tybpo>qGdU@ z-aj-RlaP5pX{#0ciY5B@F<`usTg#RfX`pf~!ufLLiEMM;&158Yr(1Z&#Pmc3_-owg6?w$g` z(mJH< zs{iocZ1IQF75+r+yPSMta(i}|Wyw}K}8I6a>EuWv!{$p{d zxB;yofG4z2&iAQJ{92y{{xN^sI{0DUBD>6-iuSXH$;Z|I7#>=YOT<$?K^2(uy z%lBS3I(_J{=s&MEX}HYR=!)%3`nxjywtp4)=eoP~xoeXPFsJ`Xdbdl1Yrn+9ov<7O zF7@^&FIGSQ`^^)+L&kGI1m681J$Kvw#k;E?Y6|_6J3Ti(Ec*PqmULe1xo~U9kEe1O z`8g{Cx$ET@_hAN)l=QveeaXlA{C_0(=!3F|zv25s#(4*`h2|;3^Am*Oe`dFKeSAXq s`*M*w{?@*H)Vwl!IGDrM*&YkfyYR}HO+_z&*(o` zLb^C9k84_5s1Z-X^lPH7M%}nXb$l)$23UTW)@{l3L?&gcme-P`p51rm&rhp`--6yv z;Z*lO6N^g@>GBORlz^-Bj;?-l$vTHj8m7#F3J!}7^PO1hB~QACCB+t zXqnbM)_6JW_BeZs%kGXFX7}hk`Ki;&Op1Id8~keV-Q}!x%Cm=@hi!@GJl2P)>PSB< z2SipL*ykI1`0lU{7ERMsXS_`gM40yWN!Cr9`R!6|tnkA2IcFE>`bcswC9-C32e#P} zBUh@5t_in|cv78=q2{XiF9|#) z(#6zs?KNCBaT1lrpO{&xfvL)-8Zp=@Lp`v)`lCJKF+zNxgszme?Q=_~nzroI8#jCId8~jFV^z@C@H%8?)n#)g79g`T zB5oCUjXKz1bHyp)sO}8Yp9_+6ifI2-;7+e|RYXuv8nUe7z%Y zY+~8)l6m~DTz`MEaXx&pBU5S+XwipD;lju6)B9sTOXzCYdD68!t^3X++*I-8CCjSv zgvIST^5MnS=WK7j(F>Vw42zIJ0=wp2iQ)c#qwt~6vmXwRdF83n&?tsaATsv#rx@d zu6a@(OXs-b%JT{rZ$TVmKS=??y7C@d<0zNQXovlUu851C!L;EQEqQOQ$f`VQTFy9< zNPq88L7ZPQY)I?3!_zynfPjzs0~?%>ihUuuqS^+ELjRWYUPPw9(8E99J$QFFPxMHw zPjUd-0~2DUI=X<~_j%MU`>00$c&T!7McqhLvF^KqW7B(&=&%h4bg?&+L7)#!`H5Zx zWqh5x3Dg?3mh?_U+)6Xi+V@(q2kowtndt`(RZW7#sB!38x z9_cuaCiyo{+8HnzgR-iF2C!-BAAmoPcF{zXf`QE&;w=4+@@;7M8I;V^L95wnTTCEI z5SzgbUirU0u3~~n=Z!P9lF?%4EiRXID6-P^%9#VA`xeO|1?wTE*)5l6TdX$!|FqUK zU~{A0c|$7bpC^I>sk*D#_!_JT;B?J85A^*{^a%x0vvrDvQl{4c74Qn)-vi6@9xKB< z-I|iBK+>h=rV-p!E=0sVCvJW2ihpjF<(e~11iL7n;cKX5t|Sl&HY?yBtSuyei_$>?oMF0BaoN~AhkN4d3TL8`(6F|m&~6W0xa%*yDG9yG+fx_7F`e5=)75LFp`OJxhH@=lK5W~v zwiJN{{iS{LdHx}8k?HmC6O~aW>mS--Tn`xp(6FCKgotL>N9ADVC4gmB(i)YT`v6QE zffHMQybYhA)YiJ`m@|}{+&=jJKQWj+X9fXssh{zjO^eJbwWCq{u%AR^A}ScQ<@n*7 zFV~Ve^Rwc}s81E-bhR*bTI?W&U*3IJGX0O*j4E?61w5Z7XCdNu*9^jEv&=E)f&*B}vvGKida=()vmPu8^)S-1 zA(x`^6Q+Lplj3KwksV<-J!e2D^L)j9UHM;9nVfE`O``i$(tK>U7fY)Auxs83FMm%r zqU>^&*M_c#mj09wOx>M%V`FDhYvZ-XzcMiK(S|@L0;Oo2$eqJflAt2z{nsdt`4+Jd z4wZ8yGQfB>FT`5lq}uXg@9!6~bI!#pO&6;|@ZjDCSQg$e;U>oep3z>V&MY!(DQdw(Ug|V}N75VNmSHryQ@8c4e=SI*lv*2ijM^*asD| z$cs$ug;i-+MhZtgsZ`q}MwCd=4$*nDkJ<}(Gx0rJ>5cmgidJra(4{ZhXeG2BqK%{4 zIWqk{MOLN0sMjZL^bbQ67Z6ayht`zqY$aH6Esi|}sU|I-TL&%b&?>O0}|m%-+L*+ZUwgI!-c zQHeSf-k`;}cP!-&yWp^Xm;zm@UP~nc6Qw@X_KTGF2kNjB=B6wY;Mb>&KsHa zY4X>=_U=kj!)NNM%Cb)NL`I)7>Bi6MC&sz#0U~be;Lhbqp7-Y&QCR(+Wdq16o5^!W zA@YnTWAy`J_Q45AiV;5+sVT0*wI!1%?#A~=Ajc>({oQU^@JERmGE!nZxf*nGWOT88 zXO@3CjZo#9R^WiT5Ce4!GBz-%fu}0mMwk^I8TWU}kO7wy!#?sXib(0Ka3n2lrH~j9 z-RYXCl`)VRH4K>@Xqxn7Y$HV$b*56cs2F0Mm|i!Ya!bj>9Gz0WF|~F1bcLmmP4IcD z=Pukt=XgOP9OFrG`NJGFc+!Q^dDUiE@4Z(*RwwkuJ#`m{L?O`L%?sQZ(c8A~L#}i+ z^ro+Jpujmt$$^fwCr?GQWnfZWTEGqy$DDpdkd;?l57vJ-Pi&3&BL@P#z#=)i*e1_w zSl?xNL7DY9VHqEluG?+S1KT9cr{38QAn6RD0XmlUqE{m(i6I+2tQ*h1U1==&@n5h0E--h4Cy&iQFzVI&lVyUSbFFVd zqxO?k1u~z9>qCucej{eM!NYxWNlmMntTE`j;E7+a6nzP=bgno{$rTL_{yn#pXAVc3 zLzFb4M4Sw^x*!@r92>HiCd?jG9KcRF{dUBD!$C(e^$g~TLjWsdz@Z)w^pr4GfOTASj z5VFTN$*jy{e+gNUT$F%s6CEw1fHzgQu`X%egy5fLsYFM;J9Cbs8*Fh>^s7>4l(0r^ zGt`z&ZO;+OQZc5p=LTkNrREg^>Gm_G#QnzS*8}81&QX%u_{CNCk9wVcTljUNh25hy zkJOE^Q&NCf1&8q!mXI@WaT}b#R5{!8ln0D{*{BO<;1-NLR2u0PpB3Z&4o(#Bq&$Z% zZmtt*Hu_VYy!1JI$MPg(UQmyZ@$eZ3%_Vy?l|zNJG>p@<_KewAiJtc}!7lCd?(tjW z1d8jwwSRnLJt8_%a{ck}9eEJR)B@FK$dB`v$<4Ze5up`Z7*Bf_103c>21=df%q0q| z$N1l*Cbs^yFo0#F>N~H|Bk~&&d|#-pPh38Ne_k z0SIfUkmGbz;@`A?GX-GXA5+TIWN$>AdNO*!yhfCQ_kQzEf7Y_PDz+Q^R$0t4Nsezz#VxMml}Vqhyf{sLlF=OWx8z z`?%VC(p~58uIm#quxlMoo|k3haG))Z&B?=k_H~>Z_h`aIU0`>{%s9rOAs~JL96Z9A z^TG6s9If+gz|Q(a@58XGrb%Yx)$i!t(@t&_nj;ZoB3cqF-zgi7u4qmrXkdko3~w9O z2=AfpaQJ@k8;kohJZ^tuO;cvIaHb@u%hmaFA4)umUvi{h1!s-2;N8wVX)AFV@CRBn>|b1o-R z!P{4tz=rx7(YchEDqo#as-=x{0wKF{j>fIZ-r5WkgM!DwW)v;LX4UFBXOCdRt zHSR!8gBsK{1|SzrDERdx-yp{}Fxtx4db`X37(Vblx?BnZgV@V9PaE4jf{^FUp zxrJSg)Y#Est_qDPCq1K<>)T^-`oc~7H#RJGJrwXP3s&l`1PVm7kNKv~Fa-6iRy0sg zTW@vDqhG!kby5mg@1FADIEYz4F+2nvnu`E(P9wT*{S}qGwK$>(`$27jQWlVh9leVa za{o#jhH23x$vUy~k`~*6yfY@otjKb!>q*WUcu~{#&fr6C?|j>0F1oV?eEMFzdtSM# z)Ic|ACnJUfO6;@>>{m2Coa1{dqP=e(bX9*zVJ;HtxXe@uZ5rfA@6cbqCQ8AU!ilCD z5sp0fwT;Ig$G%RZd^u+VWm-uHo?k+>+7x(wSMr%z3_mb2*tg>KXr)U?H#bJB>3wQ2 z3}%}aWgM=re0Y*XlA(5LSM{pur{4nszjC^IYfV8w_T$&JfMtAWT>RxE+hhFmH-*8* z=arF;WghJ98z@%kvjHC2k3S8jocQJGiAwjX_Si zv-c)2uuiYyp(~4n4kPyj!EmKoNtPW|Wo@c!SVZwKSWz!J7lT|Jk&Qp_bGezYZ+(UM zzyWwy%eVH{?#*nkW!5hs#^$CZ#Q1fj{2;IPH&yLCsyzl;HI(&z=eO6gYmf6JZG45m zVIo|a!5h`}Jd#uc3o;Aov+&$Me)nU3X(u3^c;o2a9(oo1lS`{zSDN%{90*4u<9>LO z_PwuOawDdJ46$N>OR3>5_o{67X#xmPr<~Z^Fj8xV`yd*xyeY-whsD1Hk3K35^FPh8 z2qr<3-aHn$(_%;_@Ke-d%Tj`RH@IJq2p4A8_dJTwEdYh441o@fKBH0DBH@sJ`M&fmLDq@KaPr^=qN0Uk!VzAs^NVB;IE_Z(O|y3<)k! zw4g&)@JWt8dv_|q`+~98mE@_lnyQf^p-A(>t~Fe^l*}nF#*-`g^YCHcsqhG15u)yW zdfd@27BweJH%=r;rYP)K_cOe;*wojUhA2yS!)o~TtW*^r{EN~03pxM_DHWH*y~6fp zt9p@xT;)%19)6CJoG%(oroglAO<%EBeMGp*DJ!2e@W&F4ruGWvw;ORIgc9$jVcK+$ z-_#~gW?7&TPu_b37gWmGcf2FVh$xJ43Yz)XzZEkH0@DcL^Q=D*zNxdfrrz${U{&k6 z_or>@TXBK;1NOaA;Tho7UYoSK`5qXei(=gu#y^+6ijiq^Ut`I}L%Q9pBf@sP)^YRO zY@#oDKBPGCjZBWToHA=Zq5Ixf+cqy!+;wHKBq~h+p?EV)mG^P?_93jRj$U>XFK&Va z^Kgcwx#5k9#E~%%VmgV`>S|N2&HT>UWB1qx)#hy+J}#7VAyB}iCe~VD2I5r%iiyG` zYv(CZH0JQBGGhvUB_7z_eKDUyReAF=e7MMss2c+WXYm~DvSFm)3aC3LWrixCFG5(| zWMcWuONFbfvvil62wEAn{8l7ThbS-{qWJkcy(V}rV+Eo~AC^S&gFMTvZiCcj;ftwW z2*;nCN_G-c6i}cSs{Yu-`5lfIA z28X~h*x-wfy`x=P@0~cpWmruA@GDXa<6&I_-p}3;cmn7Khe-SRBl6tMb5Wc%id{%@ zEVKIEIO&_UH{a*_k&K(Vk%W((8qln)$ap{4kc3WnDk=HWg}|IZtJOXV+2j3)>t1m2oZ6=PI!#qu`OYt zPU}FZ-v&~(c5%5Nb?Y8kPg&MOm>WfihM9dl`2LpjJ5liD)A8a_vmZO7uj<=DYT!#Vg*sJ}QH1KD?LO-IGE@*;yT(~Mg zRNVWt_`%10Pw(KAs^<)8;I9fPUKsDL6KSss6#{-fJna;Z*l8trV?vWs8^w07Kg6qx z$M|u-d_p7T33zF2izkxF23xrQ%fiE!bSkwp%UsU0lCe+KYHE*~+JF)!2KsEY5_uZ? z3fKvbpsACC$q$*8y@X>{eY_`W4}5PIXwZ;hCz$J)t>bq-Aj8zE8ixyJ`x%Nx0UyKo z>Jgv&d@-5a3ZtZG2rf)S%6B!_LHD-nVS3kL$1|CI(XrG}<)F7U+gF|XOt3I7SDrEt z$H8{$`PTEL81I5^M)>_r_+oV#Uu~Q~Q*?ck&Pd3b4N2DGh&xRx?oYBjOlF^Aee=LR zM}LiYYuC zyW?Mu>Y_XJzVP5s#WCKix$18d-SOvT4N+(JP9AVjnIlaEynj^1P}s^#wU>@^8a8`l zyArdxdMU6_SlI1agLMKcC05bCN|i_I`>0pKSPV0=GsUp1(?P4!KqfgnG64BVu9`f^ ztPpkflo3+ZY>YMV3Q+ps+6OQ@avI{vb_^-*KI%k+K#nE(i}b6iGTh)ctsxu+4; zeqao~IvSY(QvYqaG$UpQxmIcj32IT!5?LOLrCM;Op0ef9LAg{a6j18AwRXw$&z#w-5)WDyl$eS_}Fd*LdsfriJ8zM&47 z7yj@x%E1n8fXSTH{l^&LYRJ2YW^Q?4UEhYa@$L2{J#9~x!q`J<#Tw&Q0vOw1NAT6s z-qYucR{mG##x(F{S&}HyY`wsecl^gWCrxog8Dlq~RE^2Y+dVo=dBGxK5EDC&hpS{u z@^l5EKhMbDf&oG;No6gR*hh@z8$UCRET7%RUUQCyE%D%Y$%DzB%t>=RZ@w~ByEKV4hsi)ka-=#N-WknR5 zE+y31Vxl{^b@)U3DW@8n&m@U*1Wg~WBJ^$XQ^L2()YYD=d;q? zQg;xJD2wvsYg%hDco5Y+eZJP(xU`JB9Cv`YSH=7d0Jz$Bsc2SDPbT_89$xvGqSlzr ze{qK=bocIEls*GX&)9p}*M0xo4;82wH>Su+%9q#O`NOJjjP7zkqc`e7wxyl-03$2z zd43_lJI?r9nGqRp(y7w-#*?4j+|xegW!(B&>I2cEOQgJQCwb7PXl?0Uff!4hF={iU zcu$n!FJILgZyQ<-={w$EzqPVT#zySrl^kgp60iCMdZW~=oeNE33e3zpixttUNW)(d zSBqSuE0;zw#s(CZq5R%k$@@aXKs9b**)n>eC?w@>KN|BHA8umhpTyTezaE8;mdu9; zzfk_hv&(=zf6pk5eW0;YwX@1> zbSC5y`-6c#%Ec-*@5#50?o#idcMapKrm*hQ+dajzgQe8A`9^69Z2>Lp0%Jej%yOlt zK}xb=+u9{O6{_m&ZxO~o>fDsMAfCwf>>Q`s@nsvqGJ(5=4iz+_@Jj?0ytOoOK2i3O zFSVaAc8^BW&RFEnth(6yH#dZq;8k$31G=irY`6JhPR+QYdpCLNSoapO2v5R|9_N(k z=3ZwEdiz&qra7f;7PMUaEZFfKU9Bvq0KXIJ(atB9d-GTpw<)3y5!#5V%KTiQX3fmX;!fy%*a0h8|%^ zP#}7ug>?2dfXIfWP_DswEywaSI4~D1q~K9e+C1Om||- zl*}ltXKq~B1X%=)rEf--Rk?TAJJt&=zhKr~pnv5Q084AP_dbc~$_!;^SW^qwJ)epZH^E zEw?L_KU>Dv5?PdCF{RgebImP!_gOn)0OAY|7MBGp*;}L z&tEKK^YT^8Vo@9^L{%2NWpEybsEc<)Jdo}O<(8=F@W`OcD(Xz6ofXNt%b?Z z1(ab5&RkdbGzofRgR|vot4**xtcd_D@P=HMYYN;4`e$L*>&J|_+tmw)ofhy;tdJ!U z&Z;E`bZwYaG<^soO%&P;dZQ`de&N)1>=jPrZk;OzNJ{(eQu1dfz6^Dw6=F|ZVBY;u zDGgf_kDGTqxA)n>$_juK8(WOn2VXm-q%1%GltP3|G!M+=$7^lW%OlVp{Qxt#rrz=wzFhu1ylO86L3fDTL@m4IbF#dZ`P zO@&x};KakDf@rEdHsDoM^*MB75~1lhX$W50aG^UzP`ApY$92M)4F z7quJT&%9oQfoy8zixw$pmYp14 zxtju*a?svmDsP232#aKz&+OC6D|!-Pc6i6*iJ%bdzqI)oe-EGSSRnz%bNZm*U`TSZ zz%Sg6EEvXQKklh&v^~h0Y4;spq?Y|X=gWX{OJK%rUy5?l405*8j;XEU+&U9LRe5Rq z+B#=Jx(#N=c8PIr6#SyFd6|LR*y{MX@9av+h7O`VXd&k8S04r(hT?A2i z^NZfL^NaV(iUN4QEj@JFo@2V|*Xg-!iC~lBzpXzl?D%&+(&GAvIDXjWN27qpI9`9- z?E^Dy^(PAbUa-4ZeTS^Rf8=)EBkU|gIS{7HQ}7{$D67+*LF|5*m!&P1e!N~1UGpgX z?cp_!0A9-x*fU`vK|E6sR7*~e(5*;q&Sww5{Stk?JVP^3u12D|-gxTeNxu^8n4(OO zm1cEwPB57bk~ZaX1M+7xdjZjQfQzv=-d2cvvSfGXhPus018KQ$=pb=OD%E!iAg=N1 zM(RI%q{Ewt{kMlc*awoFzEAzs?06J>X=IpqKkccu>+C@s*j@KpNB?Mi>4Ro5FI6;M zv)5Vd&w3?ZsFM+`xNdA}s!zo#eljP=2d=!bxg5iu(Dbskq^B*a{(?*=26YI(BBBY} z+?v7SVmS8dl_BKMnXnF3lz?>!pK@$@8GFzewQOskTbY!JsY`BU@26}dvbJ<9_vN>A zt$UWVzUvPsykmQ0QW}oUW7ffPo$M#YcQWn+35MrjMU#_98je%y5t4?Kt7jPMedpN{3=Pj zpA}YXua~Cuz^9G8;iEE6{^aj0Q5Kaf)^RkHVm=UUw@k~maXDSr@Vb8^xojZyt^%y| z;3yhA>}Q(uF1zEbS7mFymp$AT(aYP+8SqfrhnLUPS>!W2a?nq{hvj=e*Lmiw=r{aw z!OUI^SqUxdQ(4d=ut%oTLTlBqFWfaa(+(L4F-9b2FK<|xO%UB=)%wK1Q)}xLCCxoa zk&Snr(;1gpCxLK`QBPXAKo`9n3=#-wt<%lTJu7zd8c_=gF(APzul*5)`tp*t{_u|d z>23Pn-uN~wWT?&jM|}<`+PW|OqA#P?C?2yx@>vn&gi28$YNoYi`uwBM zVZpI`$A;DXw}OBKidD9Ry|}mck4slbq0~8GLBK`J0zXZfSG1Ur&{Mx%oosUf?Cl7F zgs}Vlz(6p1L(NH&ou9zHs?VN8X}60lMx3R9Z(oZTlM<&tPe`ojDAn}33CvVu-6GCz zD3-Rk#{}W@%LyCLGi{SM{n*C7FUZcP_OJD86@T}KS+y2cLijO_Bt2~P^@95=?|XK# zZ;KO_e7>^n7g?KNV>bLLPsCo>H;P6G;1>D-IL-Ma)vPH=w#c7k76TMb+p$PF3xtA1 zbM6FPi9MgDgXxjZUYQ&GZ0nR_gHTXmGP6F-7Ic}q>}~FB%hL_H0WF5uUsq=fjAU4U zMY(m+TM&wq2Z-H3{AyJKm7h;HQy9vk4CIv;kX?`pkoNd0Kix-_w@|o@Yq?k5v)SS!`Go zS28wC-dP2)#+5CL>wea>@MyFr_Eo#3LdcWz)}k$`Vxo8VsL#Qi*=|wuyTNzclzu7I zAJ9Tzi&qzqd{hs#IBgoZQO5z#r-8*p_XLlW*+z*^y$sJ~s&Y_?JX8>wYWPTyom1sRj1}=OECxhVxshd1o% z-Q)_`oHZvjKp|i6b+=osQ$yD)WHIzUnS5q~U(8Zz*=*$VkP%L%_2cKu z7lc(^MySwxJh1l9$Yi)>yiQ&QNHw9rq0)1iARv7rvn*E!xrdz=1bQyh1f)CtYy%K$ z-OLpnzn`}tvX%W%RfJCqClq`Ll@!HgCuAK2jeW2kU$u{>>O)f1`TFapj$7|J2zGv5 zAQ~-wt;E2I8UDeA+s;w)U_8$#$|em&?V;? z?C?KU|A_{Hhs&;KO_HfY9gg2;87Q-|B9{STO!cyDzo&eZWW(-oztQgL>+a-{c;fLI z;l51)>HGfK9ht33jL14~LsLqaW5e&gg8DAqEGKiYxwrgaPuBotUgL0GwYYyuTav7# zBS^L(XgK)G?~Yx!YP<(?n1tw*ggtus=~1G~6UWyNe)ZiRroehr{ciaWQzzj$Ag=mu zqI9Dy9!Ugc;@cMFdd9-{%n2*#@>cx!ekDVAY(Md?Wnyf`_(_hqHYX|e zt_j85tor!M$@e)GoA^U?_;oMcf2~Hq-XNjnJw96&x0WVi)rz7`S>r+Hc^-qwA# zD`Z-Ai>D8N_l`I;Nc`37R)&G0$s#?2XOBu*39X>i>kECN5vx@YzQXLnqj#q^?tx4& z%km^nGi5I+A0q^jW|wdEpp82-d6wez>YZkW-(y>eZ}8Esj}{}a&xAP6XH`GR0_ki5 zjzm_lLZ(1FUdqRSgUF){H84D4^SAqh1|};d2 znKeLUtD;@P3%yqxY(dBSIP9sr{0nRchp*>1odvTsiLCDQ&I0SYPtQI#Qy-Afn_`Z delta 9824 zcma*NXEdDO7dAY~7+oTIFA+T?I-?|r7F~#_i9{P?L>+Y)LPT_l7KZ3V2{Jk}L=ZuQ z7>qKa1u=#w6ZP@?KkI$JykFjX-5>USUDw`cueH}Y>)dDWYA2*w+I2M^i~BbEfd3v5 z06-l8&;$V70V1{lb$5Vz8bA{Ya7SMfA^;H)fToCut%&C33l*`2ilp0#af@gIG&MzR zHKDn-A^_X}OKWP{+S;b4-ewYk{zt?@b8};DMbZbosHebtzL`oC!U!hB96EA9F4x*% zyLr^#y8l5(+qQE5!RE94#*r$%XP+XJN1cL#(0U=Pix+sVT^#`(z;%Ihz#Tx(*ua!g z2WvuDMUo^ zE9R({N3~kr3#bLErITDY#%u3aBaE{a-YNn4XjQpeD`D zD4Twq437L0c)m+QZ$#PX+wo&0ZT?2Pu-h+Y_-mRt`$4n^p07W6R3}aLG#(CuZZ1no z;v`qa!i(D!FjdIZ%F7fH|8I`BSbrr?Nor#a zvHmXQgIyaAvU`9f*7^-J6X`@kFxaXQYN+1;wWY*X$xLc;4^C6`uw#R$s!u+s`b&ol0a33G~X(= zQG7tEQcEeN*HRjYQDju%Q4Xwna~H^ReS!ukolKS&#KiDh;C_E8AE38HONJSdOKC15J1CQ%FB z2q?8y+h}s;>$BSw$b_3ZFw)6ba$dI&hWEJaD|bZGzva*wkY|KBO#tY zd0}CNYT=ulbsb^k4G0dog$Fnx-jyNcvcRlSfKuukhNO}Zz8R#-^MVCB7P_d2*TQzB zYogLGPZkZ>BfP5#6*Sp(&Ts8l6y&o=WWO_YqmNbO>dnK za*SZ!Igwq49yRey)50=d(e)2eIq}^DCq%51C<13fWuDOFb=s>&$83gBVP0@b5Dwil z_CK3iJfOs8rup&peCNO(+52M#Z%;cr57-qrQyflGrS;7Njy*8@kX$!W`b1_#Rpdh8^#rCsUgZ4xDYovBV#!?D9diWzip2*9$Nzp&% zzbD(kt&2=(%wb+i9F4759FXAY<`-D@IHwu)YqWIyQ<#0UUEA;3&{fHLX{M5_NcIro zySkrL%E}XEy1|H;<0dE2!eE>I?sQv1t4+3+Fzlr}w4xfa?hrj_3^Fq7BsY}T~ z$%X56`7M(Ncq3dAP&-2G=`L|5Hhbg*XQvV(*BwsTc;h(_A)UGq(GnCHTe+ou8u;~- zJ&U{=f@Bz`Hn@Cf*>u*z*>Yre5r7W7gc3`=$C@>Dza5Bjk;-#RUv*S9OpaqMUmn#L zDxV;vWs<;A`;Q-h-1;jsk%S zf?Fj7+4gp^dAXTxod84SO7F9(Ei|Ohu>_$~Qg>jeh977NM)$?qog?>A&#x}@FA+lm zOUjo`&_^iPd$SB4_@@gjY#CS-Y1a@5@z78tFEx2?yx31l8ax}nI2UxGlv_*u^|rmf zS_8b1y_=GIXex-0!9r9fXlCChCOV1!Q)YPr#@zW~_@Wy+VMFPZNBBqPR)M-*cr z2o|6~Hs-bI8Oi>gzr6V_2Q@h^FHCZHbINr6_2gslR+cYgu{JX={j#wunrY*EtCB3- z*AezRtg}j7`}@LFuntMJHIS_G2__4F@+27Tv$4hiO3w|ji?`a-q7elB>%xX-) zDEWJ3RjWVz5+u55N!8CM3_cBCZ`GS_&($^b$nU-t*d;-FH7a9u8cErC@p##IPr?-S z1mR1Ay0$3)ujD7lhMo%HY(2ipO;En+>9vF zr1}i=l#4T?$W(|CobF!nkq&PaJ>WN;qpVp`rr_l`y_zT_w$-U5MM`e&ZDH=Te!1^R zNZihT>ZHrZ5=}$kP3%H6T#(+t23b^>D}q&9@M$?wr)VR&y+vR_EaZ=$DzWP|&?_E1Nm27elvrT=M{*nDo%h7Abw7b*6>KDRbT<BX~y-xyapLAWo3jw~EG8;JeWEl(&Esx@iF>Z4s5ImBw;s{=wJaWK|#S zE-VDNQ&BkISMzC}gtmk^WM5d~`smd16mz!GU)5%qgEVk!UKM%#B6y*iyI!n{!eb)L zyv-M5<^Ja{mR+|Z$TpIMhoJIC8K(`%$|^c^gM*Uu{A?g3k>d3t|FP&ALeEBo3Wz2RyvU#Z~oJ&%J zD7sVCUBN#pXcTKI-xKhOiDrSc014wWHuf}qZ`Ov_1yAggl#^8>^hTr6AMw1G>5Tt& zW49(%|BaF|?#C&!!6(9fONL`|rjN-SAqba$&tqhJh8Pl6BSQ2ydx@T~<39p=Joszh zvv$1h-D>u7#i!0esbW+FAjPOHqWW&vZ_7m(=a1#y6(+h**>N^1Jy($jk<-Cd*uRBi10L-kEljgG;8E;I ze8FmOAS1YK>kk%HnYVM!+grkCig+xuw@IJ%U78hDDPPWcnY z#Sf3b4JjQgPk<{pLR4Isr=6(qD6^yX>!f$<*_nmOjve@5z?k{KfSBviHZ!<;Yegdj zE)gt)a?>X~pe$#F_HehZxR9B`EMfc#=l;8c=J927c1VP@+WxI zRlN7(%XeJjot`KDy=a<<9d7Q>FLen^Rj0QisyjgN_8;HLNYg*w@aMEce&3{dHtvTK z_uV8O|4gRCXP!MzI`tkpc@Tmt?{*1!N`D%%@0BM`9(S0P5btat_hvy2Nh6%?ik;OR zkagk=w?otu*3;t7m+x*PG_>h0@(=*3Zd5K5FUacj$^b; z13=pB0X(~LDnaw)Xgiv`p_NFd@Mx8Pj`<_oLFFoud@1KY0Fa96s6!UX}9@jrSb?m9~oCWoK*`CQo{9x}? z|Lzk*NbpER{FMFBsG)I|ZgE?C`g5ON*K{AR?a#{ z6B6qZ49=tnt~1lKEc~mv(N&^nPTpk+kM?jm=*mVw9I+>Sxc!cj`yEFBW6a%P!U5CU zzq=i@deOl*?Mch){+yBd-X`W+zGv}wGOn{+sha?5?<$9CONBV#C@>0pO)*F9jd@xt zIp-MfH;V9W(?l16=(UvAm?O3KL)pphvj(YUsBe=(-(_gw68J=1g1wmN(eY{6eQ`!{a{l@h^rZbyec*v*h0m z1lbIgkHphkCa&>pT$C zOs;>b@bF);w4dGo28KVT6c|u=`0d*RkC9{E&3d&`(Mz=*C%%G)FyJIk6Lp#&ORJ|o z9ML%Lmd?bX5b!`PUl81sOgtyjn6Kw*8QgOc2QI`3bH=o4_SL)?2$kOoV>2X8D$i<( zpxw+XNpc=X6}C^PpR`oEvF(k5xDip~3}E!gThcrA)rzbud&jk5k5F^K7qRNL0J4RXwR|_uXuR_ z)PWJOUA;E`!sP4VVaG7F_Whz3Xx^h}u89+0NtsZ2lDuYV>{b_mUy>Iv@?W>JU<2lrgv>mx}$S9aW3|kR>d538u|IT1vD>H4B z&l4;>z!fAQt{h;Zg8 z+AobNjk7Pw6Z=@s+DJ1NeCbJGV)jY3XHA1(Zc1eQu#{zX^W&2yrCLldrSV3YN~UuN z!Tt95;VwA8kb>LfrDqF%4+oe}g-iQL5Mv7T7^Xy2H;54F1VRAiKELBhU9(5_>;!Ax zKFza=F5t%yk;WEveMoJ`HE8_KcIu`qCR~1lMi_IQffgs_Ox$3+c8qLAhu?)+n^~-1 zTd5otdU0i<`Ul9or5tTC-`kAfhPdK`Q;1B(1N0y@J$=cP+w`RPHPQT6tu^I#?agF z1n-+d_RKK`e)nk_q@|f0?RTc+IpL&~U!ND}SOD1*I)tmTW3F9c7NmyS0TL{2g(855 z2E5tMvJpF=Qefeg9yh3Wt8-NxU(K5VE`{tUQj-wh4h%jYXbj8$Rl~$CK#mBzjvo^i z$7|b#c~43mO$g?&t3jq15Ko&)HLdzCVV70$X^rpTaD>(6@f>a<^XGUTR<~XEd@VNy zqJ0Ns&m1I(+6}x^d@En!p{sA$S{@!%qJd@FGmzF2@0nCxtqT@hej!M*olhGu96~dm zBL=!4lncMOW}?MoEW_I$sI1(vYLty}5p+}_eE|&tz%z|ipwyPl8;As6I0dT={Lis} zq~F=qWY$}#2djQIE)=ng{2W*3n`+yKc(L&`9wv#P#rCLIsyOX7w1zPaAy(i<6|XLH zr{ZxUIfRi71a?j$Fi+|}8lB+png^FSn5YErS zzf%Zhg3H*2S#E=1sB!0~0>^qnf9I`}$>x76NkW&wP8COAR*uKz2_ zLUd?g(u(`v$)M*(Z*I`s#V)r%si6*@n*$4CE&uQgq56hqmY7WE(RqbO2Se3yW=SUP zo@S))Xz{&X)E;c(`WW_ATIc&{gt)ALz_a2brIbs-P-etkbVXxt&&7f0k5s-7v_sOY zWO+$${*fI&x*0TJ(R7b3`yQKCfhL(NysY2Q8?o2?;)p;K@?E=o;a9wyXbR19(C?|J ztfNxm8*O;~a@lg&#f-T_mUho$1r>b9rzO78zN>??sZUetJH>-4R$~Sb!wso+kr=8Q z%k9vQ7rTeV;Tq=C`M=sMoU7a^E6IY-V+h*ew=ECKsM3VU}{Dz=-^|^(>k}qA1_PO6~Hm+;i{Y1_xNRaQzTyO;G{K19!wFijG z`xwN<>Q7WS>10CC*{A~1Nrprb#B0ti>=h3Nv?ESdx|@%`>dIZKSH$ z(-U%VQnvR1)BNV*ZjNgcKO>Dj|C7W^KdpB^K0?!U4*xTAer)`(C0PQ0tACjg$#=6M zxfu@z0b$iuSJLCu_0<@htzqO1hS)mq{1>HR#5O{;TWLnLm#Wh} zLM4W^!K!7HY)Jb`=o1uk{&JoBVre3tOh@B z`jLo|h>yA7KUJ}a9z1#~*;-z?gNU@%2zgxEURXiMD~>vPwJ@4&{s}!}hyQIYx$j>| z`9}wvB>@+4!x0F{6AbUHUh+$*580daquaLV7w)`bnj`!;JPvjx`4qE0rbrdV?-TsX zZB>c%dqdOA_{pZklh_~=nTgn8`|GdGbghv24PvRAp2-FaL)S*J*nc({>JHw{*3iDU4k}>?=l7t=IAfnCPxeLFI zeoJ4%30|#9e{p6s_UXOt&B1oG&_Jg#Vn(Qh5XB`_qNfAy` zMO`7BM62Ca)u{-2@nD0{Q2^TQYU?|Q@%_%2maJvPntCze<@6ZXrZhx}vf93+jTSM* zZqY)AfE%V~eR$&Q)CrXrR4iS>o{R??EE%6zoL=GGo`Z#X$rpkXy9ni4=>`M_qkB)I zpV~ZFpfstpH5&ABUgcmV&SRpz)0*Gza>E~u)lj$ek0QZOdw65_%z_;IRSuvb=Lgck z8taX_oUYd9>LJ?4kt(&)AA~eQTst$ud9+1zaF$RzQsJWykfuI;px|v~o>M=eqk!`n z+91_f^Pzkmb*U8}T5{i=7=-!cr>o@7B%Kmg><)9jIRE%k0_{mm@9?2tj8DbJqXS8_ z6kn2dzltaf0rWr04PG>BPG0`7*z1#&QwkM>t1n=GnGYHMU5tILB4$t7rH7|JO^Sd@ zq?QPcgNfmv>%+w(@+QUbRX=eMZ zroybMi8jmkGn@WPo!v={vfj>3)sPB5QFi!c7Wu|aCxNT*xi%lb+QZ_5>Wm5EA|q6AoF zDc(rI75DOM|7VfuosUPPs{(DXH8$9iahL5Z@2i7S*dSp2clin}HS?dJn8;@vVu^={ zB8PycBIjk%vPYEk4@ghy9A;lqA!s+1tg6L|z8AGK)XCO_H=;E$M|Zm1jXzPdWnk(H z{zGaps1NO)UX+Ev10JcLtQMZM-S!%GM^B;n!rh3g4Monnmk}F<{*%gL8G=wW2YHvW zG^Hi=)XP6`fq_9-YWwB72vIQy>I}BJ)TSC@2?5mRt{2j^YAM zgerf0a>6Fq^j@|Z(~PHsfPz+Z9Vt`-!S`Knz3RNkdP8F`>R{*xG1G-=y!F2t=U;$^ z-tq`kAY6)F(6o)zt&d&ek<sNA4}mMVZVzJCA%Y( zc&8Ir8nW$%`TI<$HatN)^i-mp!6AiN^i1asN=Hu)dG>## z5F60;ns6g%k5O|s2)gM-*I@ZEW0Y(QoB1*+STL3+SWAi89eE5PX4LI65l1tVt1`E7 z382M5F@!~2<@S7R_Dkq}CkePOgm_y|`FRgPrQA%h0sLFZStcffx~;{COYHR2bLeg! zZle;(B3vA5-c(yp(4|d2eS6s=y>eN@$>_igXe3ZjCv9s!!3xMCmlyyR+gI$+K9ItT48mK<4N6P7+ai_9*L?BnB;X==G z@Nb=$kW(5_Ol?V;{A4m#{CT`CX(PR!5c3%$=%PHbwgd&b#WZfFxwk2bc1S9K+?RyTd(sZZ_pl+sFd$AFA zl!T^j4U*`cJnNfEBLkjlPtQBnN(Y~9I*Rw-QtbHU04FCiVlr-tG;pURCZ-(5pDQC_@fk#@hv*_iEmBH7qbzyzP24)Or!x2APb zC(=J zL)cXjvg_!(@3-Bow86?b{>M4rsYSY=rO3Bey9X?RJ)Uj#Z*nEzXh)G2a@d=@0{MAm z^xZB(pOAv-1HW47Vk=BU>`0wYJn^?YFNob6L*}n=k9;uBX`%oCHEGtztY~(%&4FzZt&S%BK-cV<_w+ z*D)sr_mJ(JYb4y%dIeU7%Tu^&Bp@ByKl_PZBLS)j>)BksHds#4TXU62ImEp~931d~ z^w)$|>!BSC>&#B7Hc1}m(H6{-HfThN5*d7x!bN5GUiUj zvh#>eD;gp}f(GYZ&Ng(Pa8sV1v0o~J17`Dj>_?`5fc$DH1$&ja$fG;OC-xZX96(){ zs0<@;Y7%C<(w(st#R1TY-s+DT;4DC2X(xIJ6R=L<13z-Q{aW^!zX1l9L>BL{q;mL*&u5#dWrZKJm`2)tGup%gezW4rZ++f?YVp zw6ijNv32KcBY{0p5mWMHc!rHfWUdQNGI$COMEKia6D%`KHGzvhHxDZoo#jBC_#5@_ zIhYr$8BY&=5QyXXOkfP`)L=o19FOdYya=--IP7Wtd7nIegGoT;pygyN8@RyYtVooM z9VqCSz`Hkf{`LylX9sr_^qFf4$T4?@hr6hf8CMLukuIHcX2-v<>+)+`I$H0y6&X}B z#ms!h2b%dmzOv`LygHQ)l@_!|wkW&-g+Q{@ln>ev?>+|`2<4#ApQ}%qib50E!&8_U$XP # 1 linkEvents(changeEvent = calls, nodes = actors) # 2 @@ -34,42 +34,42 @@ mod00Choice <- estimate( summary(mod00Choice) -## ----actors------------------------------------------------------------------------------------------------------------ +## ----actors---------------------------------------------------------------------------------------------------------------- class(actors) head(actors) -## ----define-actors----------------------------------------------------------------------------------------------------- +## ----define-actors--------------------------------------------------------------------------------------------------------- actors <- defineNodes(actors) actors -## ----calls-events------------------------------------------------------------------------------------------------------ +## ----calls-events---------------------------------------------------------------------------------------------------------- head(calls) -## ----hlp1, eval=FALSE-------------------------------------------------------------------------------------------------- +## ----hlp1, eval=FALSE------------------------------------------------------------------------------------------------------ ## ?defineNetwork -## ----call-net---------------------------------------------------------------------------------------------------------- +## ----call-net-------------------------------------------------------------------------------------------------------------- callNetwork <- defineNetwork(nodes = actors, directed = TRUE) -## ----strNet------------------------------------------------------------------------------------------------------------ +## ----strNet---------------------------------------------------------------------------------------------------------------- callNetwork -## ----hlp2, eval=FALSE-------------------------------------------------------------------------------------------------- +## ----hlp2, eval=FALSE------------------------------------------------------------------------------------------------------ ## ?linkEvents -## ----link-call-net----------------------------------------------------------------------------------------------------- +## ----link-call-net--------------------------------------------------------------------------------------------------------- callNetwork <- linkEvents(x = callNetwork, changeEvent = calls, nodes = actors) callNetwork -## ----frdshp-net-------------------------------------------------------------------------------------------------------- +## ----frdshp-net------------------------------------------------------------------------------------------------------------ head(friendship) friendshipNetwork <- defineNetwork(nodes = actors, directed = TRUE) friendshipNetwork <- linkEvents( @@ -80,11 +80,11 @@ friendshipNetwork <- linkEvents( friendshipNetwork -## ----hlp3, eval=FALSE-------------------------------------------------------------------------------------------------- +## ----hlp3, eval=FALSE------------------------------------------------------------------------------------------------------ ## ?defineDependentEvents -## ----call-dep-events--------------------------------------------------------------------------------------------------- +## ----call-dep-events------------------------------------------------------------------------------------------------------- callsDependent <- defineDependentEvents( events = calls, nodes = actors, defaultNetwork = callNetwork @@ -92,7 +92,7 @@ callsDependent <- defineDependentEvents( callsDependent -## ----plot-teaching1, message=FALSE, warning=FALSE---------------------------------------------------------------------- +## ----plot-teaching1, message=FALSE, warning=FALSE-------------------------------------------------------------------------- library(ggraph) library(migraph) # The network at the beginning @@ -119,15 +119,15 @@ autographr(callNetworkEnd, labels = FALSE, layout = "fr") + table(as.matrix(callNetwork, time = max(calls$time) + 1)) -## ----effects, eval=FALSE----------------------------------------------------------------------------------------------- +## ----effects, eval=FALSE--------------------------------------------------------------------------------------------------- ## vignette("goldfishEffects") -## ----simple-formula---------------------------------------------------------------------------------------------------- +## ----simple-formula-------------------------------------------------------------------------------------------------------- simpleFormulaChoice <- callsDependent ~ tie(friendshipNetwork) -## ----simple-choice----------------------------------------------------------------------------------------------------- +## ----simple-choice--------------------------------------------------------------------------------------------------------- mod01Choice <- estimate( simpleFormulaChoice, model = "DyNAM", subModel = "choice" @@ -135,7 +135,7 @@ mod01Choice <- estimate( summary(mod01Choice) -## ----complex-choice---------------------------------------------------------------------------------------------------- +## ----complex-choice-------------------------------------------------------------------------------------------------------- complexFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + tie(friendshipNetwork) + recip(friendshipNetwork) + @@ -148,7 +148,7 @@ mod02Choice <- estimate( summary(mod02Choice) -## ----simple-rate------------------------------------------------------------------------------------------------------- +## ----simple-rate----------------------------------------------------------------------------------------------------------- simpleFormulaRate <- callsDependent ~ indeg(friendshipNetwork) mod01Rate <- estimate( simpleFormulaRate, @@ -156,7 +156,7 @@ mod01Rate <- estimate( ) -## ----estimate-init----------------------------------------------------------------------------------------------------- +## ----estimate-init--------------------------------------------------------------------------------------------------------- mod01Rate <- estimate( simpleFormulaRate, model = "DyNAM", subModel = "rate", @@ -165,7 +165,7 @@ mod01Rate <- estimate( summary(mod01Rate) -## ----complex-rate------------------------------------------------------------------------------------------------------ +## ----complex-rate---------------------------------------------------------------------------------------------------------- complexFormulaRate <- callsDependent ~ indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -174,7 +174,7 @@ mod02Rate <- estimate(complexFormulaRate, model = "DyNAM", subModel = "rate") summary(mod02Rate) -## ----intcpt-rate------------------------------------------------------------------------------------------------------- +## ----intcpt-rate----------------------------------------------------------------------------------------------------------- interceptFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -183,7 +183,7 @@ mod03Rate <- estimate(interceptFormulaRate, model = "DyNAM", subModel = "rate") summary(mod03Rate) -## ----waiting-time------------------------------------------------------------------------------------------------------ +## ----waiting-time---------------------------------------------------------------------------------------------------------- mod03RateCoef <- coef(mod03Rate) 1 / exp(mod03RateCoef[["Intercept"]]) / 3600 # or days: @@ -204,7 +204,7 @@ mod03RateCoef <- coef(mod03Rate) ) / 3600 -## ----windows-rate------------------------------------------------------------------------------------------------------ +## ----windows-rate---------------------------------------------------------------------------------------------------------- windowFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(callNetwork, window = 300) + @@ -215,7 +215,7 @@ mod04Rate <- estimate(windowFormulaRate, model = "DyNAM", subModel = "rate") summary(mod04Rate) -## ----windows-choice---------------------------------------------------------------------------------------------------- +## ----windows-choice-------------------------------------------------------------------------------------------------------- windowFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + inertia(callNetwork, window = 300) + @@ -228,7 +228,7 @@ mod03Choice <- estimate(windowFormulaChoice, summary(mod03Choice) -## ----aic--------------------------------------------------------------------------------------------------------------- +## ----aic------------------------------------------------------------------------------------------------------------------- # Compare different specifications of the subModel = "choice" AIC(mod02Choice, mod03Choice) @@ -236,7 +236,7 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) -## ----rem--------------------------------------------------------------------------------------------------------------- +## ----rem------------------------------------------------------------------------------------------------------------------- allFormulaREM <- callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + inertia(callNetwork, window = 300) + @@ -245,14 +245,14 @@ allFormulaREM <- same(actors$gradeType) + same(actors$floor) -## ----rem-gather, eval=FALSE-------------------------------------------------------------------------------------------- +## ----rem-gather, eval=FALSE------------------------------------------------------------------------------------------------ ## mod01REM <- estimate( ## allFormulaREM, model = "REM", ## estimationInit = list(initialDamping = 40, engine = "default_c") ## ) -## ----rem-c------------------------------------------------------------------------------------------------------------- +## ----rem-c----------------------------------------------------------------------------------------------------------------- mod01REM <- estimate( allFormulaREM, model = "REM", estimationInit = list(engine = "gather_compute") diff --git a/vignettes/teaching1.Rmd b/vignettes/teaching1.Rmd index 8c96102..acffe17 100644 --- a/vignettes/teaching1.Rmd +++ b/vignettes/teaching1.Rmd @@ -377,11 +377,7 @@ callNetworkHlf <- as.matrix(callNetwork, autographr(callNetworkHlf, labels = FALSE, layout = "fr") + geom_node_point(aes(color = as.factor(floor)), size = 2, show.legend = FALSE) -``` - -![plot of chunk plot-teaching1](teaching/plot-teaching1-2.png) - -```r +#> Error in UseMethod("as_tidygraph"): no applicable method for 'as_tidygraph' applied to an object of class "NULL" # The network at the end callNetworkEnd <- as.matrix(callNetwork, time = max(calls$time) + 1) |> @@ -389,11 +385,7 @@ callNetworkEnd <- as.matrix(callNetwork, time = max(calls$time) + 1) |> autographr(callNetworkEnd, labels = FALSE, layout = "fr") + geom_node_point(aes(color = as.factor(floor)), size = 2, show.legend = FALSE) -``` - -![plot of chunk plot-teaching1](teaching/plot-teaching1-3.png) - -```r +#> Error in UseMethod("as_tidygraph"): no applicable method for 'as_tidygraph' applied to an object of class "NULL" # The tie strength at the end diff --git a/vignettes/teaching2.R b/vignettes/teaching2.R index bf588df..7099fb6 100644 --- a/vignettes/teaching2.R +++ b/vignettes/teaching2.R @@ -1,76 +1,76 @@ -## ----setup, message=FALSE---------------------------------------------------------------------------------------------- +## ----setup, message=FALSE-------------------------------------------------------------------------------------------------- library(goldfish) -## ----load-data--------------------------------------------------------------------------------------------------------- +## ----load-data------------------------------------------------------------------------------------------------------------- data("Fisheries_Treaties_6070") # ?Fisheries_Treaties_6070 -## ----examine-states---------------------------------------------------------------------------------------------------- +## ----examine-states-------------------------------------------------------------------------------------------------------- tail(states) class(states) -## ----defineNodes------------------------------------------------------------------------------------------------------- +## ----defineNodes----------------------------------------------------------------------------------------------------------- states <- defineNodes(states) head(states) class(states) -## ----examine-node-changes---------------------------------------------------------------------------------------------- +## ----examine-node-changes-------------------------------------------------------------------------------------------------- head(sovchanges) head(regchanges) head(gdpchanges) -## ----present----------------------------------------------------------------------------------------------------------- +## ----present--------------------------------------------------------------------------------------------------------------- head(states$present) # or states[,2] -## ----link-present------------------------------------------------------------------------------------------------------ +## ----link-present---------------------------------------------------------------------------------------------------------- states <- linkEvents(states, sovchanges, attribute = "present") # If you call the object now, what happens? states -## ----states------------------------------------------------------------------------------------------------------------ +## ----states---------------------------------------------------------------------------------------------------------------- str(states) -## ----link-states-vars-------------------------------------------------------------------------------------------------- +## ----link-states-vars------------------------------------------------------------------------------------------------------ states <- linkEvents(states, regchanges, attribute = "regime") |> linkEvents(gdpchanges, attribute = "gdp") str(states) -## ----examine-bilat-mat------------------------------------------------------------------------------------------------- +## ----examine-bilat-mat----------------------------------------------------------------------------------------------------- bilatnet[1:12, 1:12] # head(bilatnet, n = c(12, 12)) -## ----define-bilat-net-------------------------------------------------------------------------------------------------- +## ----define-bilat-net------------------------------------------------------------------------------------------------------ bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) -## ----examine-bilat-net------------------------------------------------------------------------------------------------- +## ----examine-bilat-net----------------------------------------------------------------------------------------------------- class(bilatnet) str(bilatnet) bilatnet -## ----link-bilat-net---------------------------------------------------------------------------------------------------- +## ----link-bilat-net-------------------------------------------------------------------------------------------------------- bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) bilatnet -## ----contig-net-------------------------------------------------------------------------------------------------------- +## ----contig-net------------------------------------------------------------------------------------------------------------ contignet <- defineNetwork(contignet, nodes = states, directed = FALSE) |> linkEvents(contigchanges, nodes = states) class(contignet) contignet -## ----define-dep-events------------------------------------------------------------------------------------------------- +## ----define-dep-events----------------------------------------------------------------------------------------------------- createBilat <- defineDependentEvents( events = bilatchanges[bilatchanges$increment == 1,], nodes = states, @@ -78,19 +78,19 @@ createBilat <- defineDependentEvents( ) -## ----examine-dep-events------------------------------------------------------------------------------------------------ +## ----examine-dep-events---------------------------------------------------------------------------------------------------- class(createBilat) createBilat -## ----hlp, eval = FALSE------------------------------------------------------------------------------------------------- +## ----hlp, eval = FALSE----------------------------------------------------------------------------------------------------- ## ?as.data.frame.nodes.goldfish ## ?as.matrix.network.goldfish -## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'-------------------------------------------------- +## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'------------------------------------------------------ library(igraph) -library(migraph) +library(manynet) # network at the beginning of the event sequence startStates <- as.data.frame( @@ -98,6 +98,7 @@ startStates <- as.data.frame( time = as.numeric(as.POSIXct("1960-01-02")) ) startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> + as_igraph() |> add_node_attribute("present", startStates$present) |> add_node_attribute("regime", startStates$regime) |> add_node_attribute("gdp", startStates$gdp) @@ -105,6 +106,7 @@ startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> # network at the end of the event sequence endStates <- as.data.frame(states, time = as.numeric(as.POSIXct("1970-01-01"))) endNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1970-01-01"))) |> + as_igraph() |> add_node_attribute("present", endStates$present) |> add_node_attribute("regime", endStates$regime) |> add_node_attribute("gdp", endStates$gdp) @@ -115,17 +117,17 @@ isStateActiveEnd <- endStates$present & node_degree(endNet) > 0 isStateActive <- isStateActiveStart | isStateActiveEnd # subset networks to active states -startNet <- delete_vertices(startNet, !isStateActive) -endNet <- delete_vertices(endNet, !isStateActive) +startNet <- delete_nodes(startNet, !isStateActive) +endNet <- delete_nodes(endNet, !isStateActive) -ggevolution(startNet, endNet, layout = "fr", based_on = "last") +autographs(list(startNet, endNet), layout = "fr") -## ----hlp-effects, eval=FALSE------------------------------------------------------------------------------------------- +## ----hlp-effects, eval=FALSE----------------------------------------------------------------------------------------------- ## vignette("goldfishEffects") -## ----estimate-init----------------------------------------------------------------------------------------------------- +## ----estimate-init--------------------------------------------------------------------------------------------------------- formula1 <- createBilat ~ inertia(bilatnet) + indeg(bilatnet, ignoreRep = TRUE) + trans(bilatnet, ignoreRep = TRUE) + @@ -148,7 +150,7 @@ system.time( ) -## ----estimate-rerun---------------------------------------------------------------------------------------------------- +## ----estimate-rerun-------------------------------------------------------------------------------------------------------- estPrefs <- list( returnIntervalLogL = TRUE, initialDamping = 40, @@ -164,7 +166,7 @@ partnerModel <- estimate( summary(partnerModel) -## ----estimate-c-------------------------------------------------------------------------------------------------------- +## ----estimate-c------------------------------------------------------------------------------------------------------------ formula2 <- createBilat ~ inertia(bilatnet, weighted = TRUE) + indeg(bilatnet) + trans(bilatnet) + @@ -187,7 +189,7 @@ system.time( ) -## ----broom, message=FALSE---------------------------------------------------------------------------------------------- +## ----broom, message=FALSE-------------------------------------------------------------------------------------------------- library(broom) library(pixiedust) dust(tidy(tieModel, conf.int = TRUE)) |> @@ -195,11 +197,11 @@ dust(tidy(tieModel, conf.int = TRUE)) |> sprinkle(col = 5, fn = quote(pvalString(value))) -## ----glance------------------------------------------------------------------------------------------------------------ +## ----glance---------------------------------------------------------------------------------------------------------------- glance(tieModel) -## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3---------------------------------------------- +## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3-------------------------------------------------- examineOutliers(tieModel) examineChangepoints(tieModel) diff --git a/vignettes/teaching2.Rmd b/vignettes/teaching2.Rmd index 992c209..1b927f8 100644 --- a/vignettes/teaching2.Rmd +++ b/vignettes/teaching2.Rmd @@ -377,7 +377,7 @@ at two (or more) different time periods using igraph. ```r library(igraph) -library(migraph) +library(manynet) # network at the beginning of the event sequence startStates <- as.data.frame( @@ -385,6 +385,7 @@ startStates <- as.data.frame( time = as.numeric(as.POSIXct("1960-01-02")) ) startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> + as_igraph() |> add_node_attribute("present", startStates$present) |> add_node_attribute("regime", startStates$regime) |> add_node_attribute("gdp", startStates$gdp) @@ -392,6 +393,7 @@ startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> # network at the end of the event sequence endStates <- as.data.frame(states, time = as.numeric(as.POSIXct("1970-01-01"))) endNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1970-01-01"))) |> + as_igraph() |> add_node_attribute("present", endStates$present) |> add_node_attribute("regime", endStates$regime) |> add_node_attribute("gdp", endStates$gdp) @@ -402,10 +404,10 @@ isStateActiveEnd <- endStates$present & node_degree(endNet) > 0 isStateActive <- isStateActiveStart | isStateActiveEnd # subset networks to active states -startNet <- delete_vertices(startNet, !isStateActive) -endNet <- delete_vertices(endNet, !isStateActive) +startNet <- delete_nodes(startNet, !isStateActive) +endNet <- delete_nodes(endNet, !isStateActive) -ggevolution(startNet, endNet, layout = "fr", based_on = "last") +autographs(list(startNet, endNet), layout = "fr") ``` plot of chunk plot-teaching2 @@ -458,8 +460,8 @@ system.time( estimationInit = estPrefs ) ) -#> user system elapsed -#> 155.92 5.78 162.42 +#> Error: Error in DyNAM choice_coordination estimation: Error in multinomialProbabilities * t(multinomialProbabilities): non-conformable arrays +#> Timing stopped at: 106.2 1.63 110.7 ``` Did the model converge? If not, you can restart the estimation process using @@ -473,52 +475,16 @@ estPrefs <- list( maxIterations = 30, initialParameters = coef(partnerModel) ) +#> Error in coef(partnerModel): object 'partnerModel' not found partnerModel <- estimate( formula1, model = "DyNAM", subModel = "choice_coordination", estimationInit = estPrefs ) +#> Error: Error in DyNAM choice_coordination estimation: Error in multinomialProbabilities * t(multinomialProbabilities): non-conformable arrays summary(partnerModel) -#> -#> Call: -#> estimate(x = createBilat ~ inertia(bilatnet) + indeg(bilatnet, -#> ignoreRep = TRUE) + trans(bilatnet, ignoreRep = TRUE) + tie(contignet) + -#> alter(states$regime) + diff(states$regime) + alter(states$gdp) + -#> diff(states$gdp), model = "DyNAM", subModel = "choice_coordination", -#> estimationInit = estPrefs) -#> -#> -#> Effects details : -#> Object ignoreRep -#> inertia bilatnet -#> indeg bilatnet B -#> trans bilatnet B -#> tie contignet -#> alter states$regime -#> diff states$regime -#> alter states$gdp -#> diff states$gdp -#> -#> Coefficients : -#> Estimate Std. Error z-value Pr(>|z|) -#> inertia 2.8318525 0.2698244 10.4952 < 2.2e-16 *** -#> indeg 0.4975580 0.0662465 7.5107 5.884e-14 *** -#> trans 0.3083405 0.2138535 1.4418 0.149350 -#> tie 1.0821380 0.2195159 4.9297 8.237e-07 *** -#> alter 0.0047377 0.0143109 0.3311 0.740602 -#> diff 0.0010369 0.0116815 0.0888 0.929268 -#> alter 5.0326922 1.5429641 3.2617 0.001107 ** -#> diff -3.0780228 1.5940179 -1.9310 0.053485 . -#> --- -#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -#> -#> Converged with max abs. score of 0.00029 -#> Log-Likelihood: -386.36 -#> AIC: 788.72 -#> AICc: 791.12 -#> BIC: 806.6 -#> model: "DyNAM" subModel: "choice_coordination" +#> Error in summary(partnerModel): object 'partnerModel' not found ``` Let's interpret... @@ -551,7 +517,7 @@ system.time( ) ) #> user system elapsed -#> 109.36 0.82 109.22 +#> 112.96 1.67 115.58 ``` # Extensions... @@ -569,6 +535,7 @@ Here is an example on the current results object: ```r library(broom) +#> Warning: package 'broom' was built under R version 4.2.3 library(pixiedust) dust(tidy(tieModel, conf.int = TRUE)) |> sprinkle(col = c(2:4, 6, 7), round = 3) |> diff --git a/vignettes/teaching2.Rmd.orig b/vignettes/teaching2.Rmd.orig index 042ada4..eed90f2 100644 --- a/vignettes/teaching2.Rmd.orig +++ b/vignettes/teaching2.Rmd.orig @@ -221,7 +221,7 @@ at two (or more) different time periods using igraph. ```{r plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'} library(igraph) -library(migraph) +library(manynet) # network at the beginning of the event sequence startStates <- as.data.frame( @@ -229,6 +229,7 @@ startStates <- as.data.frame( time = as.numeric(as.POSIXct("1960-01-02")) ) startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> + as_igraph() |> add_node_attribute("present", startStates$present) |> add_node_attribute("regime", startStates$regime) |> add_node_attribute("gdp", startStates$gdp) @@ -236,6 +237,7 @@ startNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1960-01-02"))) |> # network at the end of the event sequence endStates <- as.data.frame(states, time = as.numeric(as.POSIXct("1970-01-01"))) endNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1970-01-01"))) |> + as_igraph() |> add_node_attribute("present", endStates$present) |> add_node_attribute("regime", endStates$regime) |> add_node_attribute("gdp", endStates$gdp) @@ -246,10 +248,10 @@ isStateActiveEnd <- endStates$present & node_degree(endNet) > 0 isStateActive <- isStateActiveStart | isStateActiveEnd # subset networks to active states -startNet <- delete_vertices(startNet, !isStateActive) -endNet <- delete_vertices(endNet, !isStateActive) +startNet <- delete_nodes(startNet, !isStateActive) +endNet <- delete_nodes(endNet, !isStateActive) -ggevolution(startNet, endNet, layout = "fr", based_on = "last") +autographs(list(startNet, endNet), layout = "fr") ``` What can we observe? From be1598e55bfdbab3ffaef2cc9e2b4415ae012a84 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 19 Oct 2023 16:35:04 +0200 Subject: [PATCH 15/36] WIP debbuging compositional change behavior in R implementation --- R/functions_estimation_engine.R | 46 ++++++++++++------- R/functions_gather.R | 4 +- src/DyNAM_rate_default.cpp | 16 ++++++- .../test-functions_estimation_engine_c.R | 9 +++- 4 files changed, 55 insertions(+), 20 deletions(-) diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index c8c96f6..93eac47 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -139,7 +139,8 @@ estimate_int <- function( compChangeName2 <- attr(nodes2, "events")[ "present" == attr(nodes2, "dynamicAttribute") ] - hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 + hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 && + !modelType %in% c("DyNAM-M-Rate", "DyNAM-M-Rate-ordered") if (hasCompChange1) { compChange1 <- get(compChangeName1, envir = prepEnvir) # add prepEnvir @@ -600,6 +601,11 @@ getEventValues <- function( pVector <- objectiveFunctions + (-timespan * ratesSum) if (modelType == "REM") dim(pVector) <- c(dimMatrix[1], dimMatrix[2]) + # cat("\ntimespan:", timespan) + # cat("\nderivative:") + # print(ratesStatsSum) + # cat("\nfisher:") + # print(ratesStatsStatsSum) return(list( logLikelihood = logL, score = score, @@ -789,6 +795,11 @@ getIterationStepState <- function( startTime <- -Inf } + # opportunities list initialization + opportunities <- rep(TRUE, nrow(nodes2)) + updateopportunities <- !is.null(opportunitiesList) && + !modelType %in% c("DyNAM-M-Rate", "DyNAM-M-Rate-ordered") + # utility function for the statistics update updFun <- function(stat, change) { # stat: current statistics (for one effect only) @@ -887,8 +898,6 @@ getIterationStepState <- function( } # update opportunity set - opportunities <- rep(TRUE, nrow(nodes2)) - updateopportunities <- !is.null(opportunitiesList) if (updateopportunities) { opportunities <- seq_len(nrow(nodes2)) %in% opportunitiesList[[i]] } @@ -914,14 +923,21 @@ getIterationStepState <- function( } oldTime <- current_time + # patch to avoid collision with dropping absent people + if (!isTwoMode) { + for (parmPos in seq_len(dim(statsArrayComp)[3])) { + diag(statsArrayComp[, , parmPos]) <- 0 + } + } + # remove potential absent lines and columns from the stats array if (updatepresence) { # || (updateopportunities && !isTwoMode) - subset <- presence + keepIn <- presence # if (updateopportunities && !isTwoMode) - # subset <- presence & opportunities - statsArrayComp <- statsArrayComp[subset, , , drop = FALSE] + # keepIn <- presence & opportunities + statsArrayComp <- statsArrayComp[keepIn, , , drop = FALSE] if (isDependent) { - position <- which(activeDyad[1] == which(subset)) + position <- which(activeDyad[1] == which(keepIn)) if (length(position) == 0) { stop("Active node ", activeDyad[1], " not present in event ", i, call. = FALSE @@ -934,15 +950,15 @@ getIterationStepState <- function( } else { posSender <- activeDyad[1] } - if (updatepresence2 || updateopportunities) { - subset <- presence2 & opportunities + if ((updatepresence2 || updateopportunities)) { + keepIn <- presence2 & opportunities if (!allowReflexive) { - subset[posSender] <- FALSE + keepIn[posSender] <- FALSE allowReflexiveCorrected <- TRUE } - statsArrayComp <- statsArrayComp[, subset, , drop = FALSE] + statsArrayComp <- statsArrayComp[, keepIn, , drop = FALSE] if (isDependent) { - position <- which(activeDyad[2] == which(subset)) + position <- which(activeDyad[2] == which(keepIn)) if (length(position) == 0) { stop("Active node ", activeDyad[2], " not available in event ", i, call. = FALSE @@ -969,12 +985,10 @@ getIterationStepState <- function( statsArrayComp, 3, \(stat) { - if (!isTwoMode) diag(stat) <- 0 - m <- stat if (!isTwoMode) { - rowSums(m, na.rm = TRUE) / (dim(m)[1] - 1) + rowSums(stat, na.rm = TRUE) / (dim(stat)[2] - 1) } else { - rowMeans(m, na.rm = TRUE) + rowMeans(stat, na.rm = TRUE) } } ) diff --git a/R/functions_gather.R b/R/functions_gather.R index 894d4a1..9a9a38d 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -86,7 +86,7 @@ GatherPreprocessing <- function( ) } - if (!is.null(preprocessArgs["opportunitiesList"])) { + if (!is.null(preprocessArgs[["opportunitiesList"]])) { warning( dQuote("GatherPreprocessing"), " doesn't implement yet the ", dQuote("opportunitiesList"), " functionality" @@ -102,6 +102,7 @@ GatherPreprocessing <- function( depName <- parsedformula$depName hasIntercept <- parsedformula$hasIntercept windowParameters <- parsedformula$windowParameters + ignoreRepParameter <- unlist(parsedformula$ignoreRepParameter) # # C implementation doesn't have ignoreRep option issue #105 if (any(unlist(parsedformula$ignoreRepParameter))) { @@ -186,6 +187,7 @@ GatherPreprocessing <- function( events = events, effects = effects, windowParameters = parsedformula$windowParameters, + ignoreRepParameter = ignoreRepParameter, eventsObjectsLink = eventsObjectsLink, # for data update eventsEffectsLink = eventsEffectsLink, objectsEffectsLink = objectsEffectsLink, # for parameterization diff --git a/src/DyNAM_rate_default.cpp b/src/DyNAM_rate_default.cpp index 0b8d237..dfa7177 100644 --- a/src/DyNAM_rate_default.cpp +++ b/src/DyNAM_rate_default.cpp @@ -135,6 +135,7 @@ inline arma::mat reduce_mat_to_vector( double timespan_current_event = timespan(id_event); // declare the ids of the sender and the receiver, const int id_sender = dep_event_mat(0, id_event) - 1; + //int sender_corr = 0; arma::mat reduce_stat_mat = reduce_mat_to_vector(stat_mat, n_actors_1, n_actors_2, twomode_or_reflexive); @@ -148,15 +149,24 @@ inline arma::mat reduce_mat_to_vector( weighted_sum_current_event += exp_current_sender * (reduce_stat_mat.row(i)); fisher_current_event += exp_current_sender * - ((reduce_stat_mat.row(i).t()) * (reduce_stat_mat.row(i))); - } + ((reduce_stat_mat.row(i).t()) * (reduce_stat_mat.row(i))); + }// else if (i < id_sender) { + // sender_corr += 1; + //} } + //id_sender -= sender_corr; // add the quantities of a current event to the variables to be returned // derivative + //Rcpp::Rcout << std::endl << "Event:" << id_event + 1 << std::endl; + //Rcpp::Rcout << "presence:" << presence1 << std::endl; + //Rcpp::Rcout << "mat:" << std::endl << reduce_stat_mat << std::endl; + //Rcpp::Rcout << "timespan:" << timespan_current_event << std::endl; + //Rcpp::Rcout << "Derivative:" << weighted_sum_current_event << std::endl; derivative -= timespan_current_event * weighted_sum_current_event; // fisher matrix fisher += timespan_current_event * fisher_current_event; + //Rcpp::Rcout << "fisher:" << std::endl << fisher_current_event << std::endl; // logLikelihood intervalLogL(id_event) = - timespan_current_event * normalizer; // update id_dep_event @@ -164,6 +174,8 @@ inline arma::mat reduce_mat_to_vector( intervalLogL(id_event) += dot(reduce_stat_mat.row(id_sender), parameters); derivative += reduce_stat_mat.row(id_sender); + //Rcpp::Rcout << "Der +:" << reduce_stat_mat.row(id_sender) << std::endl; + //Rcpp::Rcout << "sender:" << id_sender << std::endl; id_dep_event++; } // loglikelihood diff --git a/tests/testthat/test-functions_estimation_engine_c.R b/tests/testthat/test-functions_estimation_engine_c.R index 328ad06..7758e5f 100644 --- a/tests/testthat/test-functions_estimation_engine_c.R +++ b/tests/testthat/test-functions_estimation_engine_c.R @@ -10,7 +10,13 @@ test_that( formula, model = model, subModel = subModel, - estimationInit = list(startTime = 0, returnIntervalLogL = TRUE) + estimationInit = list( + startTime = 0, + # fixedParameters = c(offsetInt, 0, 0), + returnIntervalLogL = TRUE + ), + progress = FALSE, + verbose = FALSE ) modCd <- estimate( formula, @@ -18,6 +24,7 @@ test_that( subModel = subModel, estimationInit = list( startTime = 0, engine = "default_c", + # fixedParameters = c(offsetInt, 0, 0), returnIntervalLogL = TRUE ) ) From 1af3114b14cc1e248929db47f0a4b0bd2a13ab7e Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 1 Nov 2023 13:07:50 +0100 Subject: [PATCH 16/36] Debugging gather adding envir argument to calls --- R/functions_gather.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/functions_gather.R b/R/functions_gather.R index 9a9a38d..fdb5211 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -141,7 +141,7 @@ GatherPreprocessing <- function( ## 2.0 Set isTwoMode to define effects functions # get node sets of dependent variable - .nodes <- attr(get(parsedformula$depName), "nodes") + .nodes <- attr(get(parsedformula$depName, envir = envir), "nodes") # two-mode networks(2 kinds of nodes) if (length(.nodes) == 2) { @@ -241,8 +241,8 @@ GatherPreprocessing <- function( ) # nEvents <- length(preprocessingStat$orderEvents)# number of events - nodes <- get(.nodes) - nodes2 <- get(.nodes2) + nodes <- get(.nodes, envir = envir) + nodes2 <- get(.nodes2, envir = envir) ## SET VARIABLES BASED ON STATSLIST twomode_or_reflexive <- (allowReflexive || isTwoMode) @@ -287,7 +287,7 @@ GatherPreprocessing <- function( hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 if (hasCompChange1) { - temp <- get(compChangeName1) + temp <- get(compChangeName1, envir = envir) temp <- sanitizeEvents(temp, nodes) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence1_update <- temp$presenceUpdate @@ -298,7 +298,7 @@ GatherPreprocessing <- function( } if (hasCompChange2) { - temp <- get(compChangeName2) + temp <- get(compChangeName2, envir = envir) temp <- sanitizeEvents(temp, nodes2) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence2_update <- temp$presenceUpdate From c745c730a1b11031506fadfc2b4e5d87a5ae1169 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 1 Nov 2023 16:18:32 +0100 Subject: [PATCH 17/36] Debugging compositional change behavior in R implementation --- R/functions_estimation_engine.R | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 93eac47..0afafe2 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -952,9 +952,11 @@ getIterationStepState <- function( } if ((updatepresence2 || updateopportunities)) { keepIn <- presence2 & opportunities - if (!allowReflexive) { + if (!allowReflexive && grepl("DyNAM-M(-|$)?", modelType)) { keepIn[posSender] <- FALSE allowReflexiveCorrected <- TRUE + } else { + allowReflexiveCorrected <- FALSE } statsArrayComp <- statsArrayComp[, keepIn, , drop = FALSE] if (isDependent) { From 1d97e570638695323b0cd4abdfce0821c680526c Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 1 Nov 2023 16:36:43 +0100 Subject: [PATCH 18/36] Debugging compositional change --- R/functions_estimation_engine.R | 55 ++++++++++++++++++++++----------- man/defineNodes.Rd | 2 +- man/estimate.Rd | 22 ++++++++----- man/examine.Rd | 6 ++-- man/update-method.Rd | 3 +- 5 files changed, 58 insertions(+), 30 deletions(-) diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 77e19d4..0afafe2 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -139,7 +139,8 @@ estimate_int <- function( compChangeName2 <- attr(nodes2, "events")[ "present" == attr(nodes2, "dynamicAttribute") ] - hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 + hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 && + !modelType %in% c("DyNAM-M-Rate", "DyNAM-M-Rate-ordered") if (hasCompChange1) { compChange1 <- get(compChangeName1, envir = prepEnvir) # add prepEnvir @@ -168,6 +169,8 @@ estimate_int <- function( nEvents <- length(statsList$orderEvents) + nEvents <- length(statsList$orderEvents) + ## ADD INTERCEPT # CHANGED MARION # replace first parameter with an initial estimate of the intercept @@ -484,7 +487,8 @@ getEventValues <- function( eventProbabilities <- getMultinomialProbabilities( statsArray, activeDyad, parameters, - actorNested = TRUE, allowReflexive = allowReflexive, isTwoMode = isTwoMode + actorNested = TRUE, allowReflexive = allowReflexive, + isTwoMode = isTwoMode ) logLikelihood <- log(eventProbabilities[activeDyad[2]]) firstDerivatives <- getFirstDerivativeM(statsArray, eventProbabilities) @@ -597,6 +601,11 @@ getEventValues <- function( pVector <- objectiveFunctions + (-timespan * ratesSum) if (modelType == "REM") dim(pVector) <- c(dimMatrix[1], dimMatrix[2]) + # cat("\ntimespan:", timespan) + # cat("\nderivative:") + # print(ratesStatsSum) + # cat("\nfisher:") + # print(ratesStatsStatsSum) return(list( logLikelihood = logL, score = score, @@ -786,6 +795,11 @@ getIterationStepState <- function( startTime <- -Inf } + # opportunities list initialization + opportunities <- rep(TRUE, nrow(nodes2)) + updateopportunities <- !is.null(opportunitiesList) && + !modelType %in% c("DyNAM-M-Rate", "DyNAM-M-Rate-ordered") + # utility function for the statistics update updFun <- function(stat, change) { # stat: current statistics (for one effect only) @@ -884,8 +898,6 @@ getIterationStepState <- function( } # update opportunity set - opportunities <- rep(TRUE, nrow(nodes2)) - updateopportunities <- !is.null(opportunitiesList) if (updateopportunities) { opportunities <- seq_len(nrow(nodes2)) %in% opportunitiesList[[i]] } @@ -911,14 +923,21 @@ getIterationStepState <- function( } oldTime <- current_time + # patch to avoid collision with dropping absent people + if (!isTwoMode) { + for (parmPos in seq_len(dim(statsArrayComp)[3])) { + diag(statsArrayComp[, , parmPos]) <- 0 + } + } + # remove potential absent lines and columns from the stats array if (updatepresence) { # || (updateopportunities && !isTwoMode) - subset <- presence + keepIn <- presence # if (updateopportunities && !isTwoMode) - # subset <- presence & opportunities - statsArrayComp <- statsArrayComp[subset, , , drop = FALSE] + # keepIn <- presence & opportunities + statsArrayComp <- statsArrayComp[keepIn, , , drop = FALSE] if (isDependent) { - position <- which(activeDyad[1] == which(subset)) + position <- which(activeDyad[1] == which(keepIn)) if (length(position) == 0) { stop("Active node ", activeDyad[1], " not present in event ", i, call. = FALSE @@ -931,15 +950,17 @@ getIterationStepState <- function( } else { posSender <- activeDyad[1] } - if (updatepresence2 || updateopportunities) { - subset <- presence2 & opportunities - if (!allowReflexive) { - subset[posSender] <- FALSE + if ((updatepresence2 || updateopportunities)) { + keepIn <- presence2 & opportunities + if (!allowReflexive && grepl("DyNAM-M(-|$)?", modelType)) { + keepIn[posSender] <- FALSE allowReflexiveCorrected <- TRUE + } else { + allowReflexiveCorrected <- FALSE } - statsArrayComp <- statsArrayComp[, subset, , drop = FALSE] + statsArrayComp <- statsArrayComp[, keepIn, , drop = FALSE] if (isDependent) { - position <- which(activeDyad[2] == which(subset)) + position <- which(activeDyad[2] == which(keepIn)) if (length(position) == 0) { stop("Active node ", activeDyad[2], " not available in event ", i, call. = FALSE @@ -966,12 +987,10 @@ getIterationStepState <- function( statsArrayComp, 3, \(stat) { - if (!isTwoMode) diag(stat) <- 0 - m <- stat if (!isTwoMode) { - rowSums(m, na.rm = TRUE) / (dim(m)[1] - 1) + rowSums(stat, na.rm = TRUE) / (dim(stat)[2] - 1) } else { - rowMeans(m, na.rm = TRUE) + rowMeans(stat, na.rm = TRUE) } } ) diff --git a/man/defineNodes.Rd b/man/defineNodes.Rd index 81ba57a..9a0ebd5 100644 --- a/man/defineNodes.Rd +++ b/man/defineNodes.Rd @@ -62,7 +62,7 @@ nodesAttr <- data.frame( label = paste("Actor", 1:5), present = c(TRUE, FALSE, TRUE, TRUE, FALSE), gender = c(1, 2, 1, 1, 2) - ) +) nodesAttr <- defineNodes(nodes = nodesAttr) # Social evolution nodes definition diff --git a/man/estimate.Rd b/man/estimate.Rd index 99d114d..ef4cd72 100644 --- a/man/estimate.Rd +++ b/man/estimate.Rd @@ -206,24 +206,30 @@ multinomial probability (Butts, 2008). # A multinomial receiver choice model 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) +callNetwork <- linkEvents( + x = callNetwork, changeEvent = calls, + nodes = actors +) +callsDependent <- defineDependentEvents( + events = calls, nodes = actors, + defaultNetwork = callNetwork +) \dontshow{ callsDependent <- callsDependent[1:50, ] } mod01 <- estimate(callsDependent ~ inertia + recip + trans, - model = "DyNAM", subModel = "choice", - estimationInit = list(engine = "default_c")) + model = "DyNAM", subModel = "choice", + estimationInit = list(engine = "default_c") +) summary(mod01) # A individual activity rates model mod02 <- estimate(callsDependent ~ 1 + nodeTrans + indeg + outdeg, - model = "DyNAM", subModel = "rate", - estimationInit = list(engine = "default_c")) + model = "DyNAM", subModel = "rate", + estimationInit = list(engine = "default_c") +) summary(mod02) \donttest{ diff --git a/man/examine.Rd b/man/examine.Rd index d6a5e2d..5dc5f13 100644 --- a/man/examine.Rd +++ b/man/examine.Rd @@ -96,8 +96,10 @@ callsDependent <- callsDependent[1:50, ] } mod01 <- estimate(callsDependent ~ inertia + recip + trans, model = "DyNAM", subModel = "choice", - estimationInit = list(returnIntervalLogL = TRUE, - engine = "default_c") + estimationInit = list( + returnIntervalLogL = TRUE, + engine = "default_c" + ) ) examineOutliers(mod01) diff --git a/man/update-method.Rd b/man/update-method.Rd index 6293c96..306c4d3 100644 --- a/man/update-method.Rd +++ b/man/update-method.Rd @@ -49,7 +49,8 @@ bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) updateStates <- as.data.frame(states, - time = as.numeric(as.POSIXct("1965-12-31"))) + time = as.numeric(as.POSIXct("1965-12-31")) +) updateNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1965-12-31"))) From 0ed392db6fec773e4044abc7683d80e5450be082 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Mon, 6 Nov 2023 10:01:43 +0100 Subject: [PATCH 19/36] Add `envir` argument to `sanitizeEvents()` --- R/functions_data.R | 10 ++++++---- R/functions_estimation_engine.R | 4 ++-- R/functions_estimation_engine_c.r | 4 ++-- R/functions_gather.R | 4 ++-- R/functions_parsing.R | 6 +++--- R/functions_preprocessing_interaction.R | 26 ++++++++++++++++++++----- R/functions_utility.R | 11 +++-------- 7 files changed, 39 insertions(+), 26 deletions(-) diff --git a/R/functions_data.R b/R/functions_data.R index 2634ae3..b356bbe 100644 --- a/R/functions_data.R +++ b/R/functions_data.R @@ -52,8 +52,10 @@ NULL # Create a data frame from a dynamic nodes object #' @export #' @rdname update-method -as.data.frame.nodes.goldfish <- function(x, ..., time = -Inf, - startTime = -Inf) { +as.data.frame.nodes.goldfish <- function( + x, ..., time = -Inf, + startTime = -Inf, envir = new.env() +) { df <- x dynamicAttributes <- attr(df, "dynamicAttribute") eventNames <- attr(df, "events") @@ -64,8 +66,8 @@ as.data.frame.nodes.goldfish <- function(x, ..., time = -Inf, return(df) } for (i in seq_along(eventNames)) { - events <- get(eventNames[i]) - events <- sanitizeEvents(events, df) + events <- get(eventNames[i], envir = envir) + events <- sanitizeEvents(events, df, envir = envir) events <- events[events$time >= startTime & events$time < time, ] if (nrow(events) > 0 && !is.null(events$replace)) { diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 0afafe2..58798d7 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -144,14 +144,14 @@ estimate_int <- function( if (hasCompChange1) { compChange1 <- get(compChangeName1, envir = prepEnvir) # add prepEnvir - compChange1 <- sanitizeEvents(compChange1, nodes) + compChange1 <- sanitizeEvents(compChange1, nodes, envir = prepEnvir) } else { compChange1 <- NULL } if (hasCompChange2) { compChange2 <- get(compChangeName2, envir = prepEnvir) # add prepEnvir - compChange2 <- sanitizeEvents(compChange2, nodes2) + compChange2 <- sanitizeEvents(compChange2, nodes2, envir = prepEnvir) } else { compChange2 <- NULL } diff --git a/R/functions_estimation_engine_c.r b/R/functions_estimation_engine_c.r index 1620923..fe01a40 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -143,7 +143,7 @@ estimate_c_int <- function( ## CONVERT COMPOSITION CHANGES INTO THE FORMAT ACCEPTED BY C FUNCTIONS if (hasCompChange1) { compChange1 <- get(compChangeName1, envir = prepEnvir) - compChange1 <- sanitizeEvents(compChange1, nodes) + compChange1 <- sanitizeEvents(compChange1, nodes, envir = prepEnvir) temp <- C_convert_composition_change(compChange1, statsList$eventTime) presence1_update <- temp$presenceUpdate presence1_update_pointer <- temp$presenceUpdatePointer @@ -155,7 +155,7 @@ estimate_c_int <- function( if (hasCompChange2) { compChange2 <- get(compChangeName2, envir = prepEnvir) - compChange2 <- sanitizeEvents(compChange2, nodes2) + compChange2 <- sanitizeEvents(compChange2, nodes2, envir = prepEnvir) temp <- C_convert_composition_change(compChange2, statsList$eventTime) presence2_update <- temp$presenceUpdate presence2_update_pointer <- temp$presenceUpdatePointer diff --git a/R/functions_gather.R b/R/functions_gather.R index fdb5211..bf7f445 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -288,7 +288,7 @@ GatherPreprocessing <- function( if (hasCompChange1) { temp <- get(compChangeName1, envir = envir) - temp <- sanitizeEvents(temp, nodes) + temp <- sanitizeEvents(temp, nodes, envir = envir) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence1_update <- temp$presenceUpdate presence1_update_pointer <- temp$presenceUpdatePointer @@ -299,7 +299,7 @@ GatherPreprocessing <- function( if (hasCompChange2) { temp <- get(compChangeName2, envir = envir) - temp <- sanitizeEvents(temp, nodes2) + temp <- sanitizeEvents(temp, nodes2, envir = envir) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence2_update <- temp$presenceUpdate presence2_update_pointer <- temp$presenceUpdatePointer diff --git a/R/functions_parsing.R b/R/functions_parsing.R index eb52900..f539494 100644 --- a/R/functions_parsing.R +++ b/R/functions_parsing.R @@ -419,7 +419,7 @@ getEventsAndObjectsLink <- function( ) # replace dependent labels with ids - events[[1]] <- sanitizeEvents(events[[1]], nodes, nodes2) + events[[1]] <- sanitizeEvents(events[[1]], nodes, nodes2, envir = envir) # if(is.character(events[[1]]$sender) && is.character(events[[1]]$receiver)) { # events[[1]]$sender <- match(events[[1]]$sender, get(nodes)$label) # events[[1]]$receiver <- match(events[[1]]$receiver, get(nodes2)$label) @@ -447,7 +447,7 @@ getEventsAndObjectsLink <- function( ) evs <- lapply( evName, - function(x) sanitizeEvents(get(x), nodeSet) + function(x) sanitizeEvents(get(x, envir = envir), nodeSet, envir = envir) ) events <- append(events, evs) @@ -471,7 +471,7 @@ getEventsAndObjectsLink <- function( # replace labels with ids if (length(evNames) > 0) { for (j in seq_along(evs)) { - evs[[j]] <- sanitizeEvents(evs[[j]], nodes, nodes2) + evs[[j]] <- sanitizeEvents(evs[[j]], nodes, nodes2, envir = envir) } eventsObjectsLink <- rbind( eventsObjectsLink, diff --git a/R/functions_preprocessing_interaction.R b/R/functions_preprocessing_interaction.R index 75e7310..6b20c3d 100644 --- a/R/functions_preprocessing_interaction.R +++ b/R/functions_preprocessing_interaction.R @@ -124,7 +124,11 @@ preprocessInteraction <- function( # and of the past interaction updates dname <- eventsObjectsLink[1, 1] # PATCH Marion: the depdendent.depevents_DyNAMi is not sanitized yet - dnameObject <- sanitizeEvents(get(dname, envir = prepEnvir), nodes, nodes2) + dnameObject <- sanitizeEvents( + get(dname, envir = prepEnvir), + nodes, nodes2, + envir = prepEnvir + ) assign(dname, dnameObject, envir = prepEnvir) depindex <- 0 @@ -163,11 +167,15 @@ preprocessInteraction <- function( # PATCH Marion: the groups update events were not sanitized groupsupdates1Object <- sanitizeEvents( - get(groupsupdates[1], envir = prepEnvir), nodes, nodes2 + get(groupsupdates[1], envir = prepEnvir), + nodes, nodes2, + envir = prepEnvir ) assign(groupsupdates[1], groupsupdates1Object, envir = prepEnvir) groupsupdates2Object <- sanitizeEvents( - get(groupsupdates[2], envir = prepEnvir), nodes, nodes2 + get(groupsupdates[2], envir = prepEnvir), + nodes, nodes2, + envir = prepEnvir ) assign(groupsupdates[2], groupsupdates2Object, envir = prepEnvir) @@ -197,8 +205,16 @@ preprocessInteraction <- function( } else { nodes <- nodes2 <- nodesObject } - events[[depindex]] <- sanitizeEvents(events[[depindex]], nodes, nodes2) - events[[exoindex]] <- sanitizeEvents(events[[exoindex]], nodes, nodes2) + events[[depindex]] <- sanitizeEvents( + events[[depindex]], + nodes, nodes2, + envir = prepEnvir + ) + events[[exoindex]] <- sanitizeEvents( + events[[exoindex]], + nodes, nodes2, + envir = prepEnvir + ) # augment the link objects eventsObjectsLink <- rbind( diff --git a/R/functions_utility.R b/R/functions_utility.R index 88b56af..02f82c8 100644 --- a/R/functions_utility.R +++ b/R/functions_utility.R @@ -134,9 +134,9 @@ isReservedElementName <- function(x) { #' data("Social_Evolution") #' afterSanitize <- sanitizeEvents(calls, "actors") #' } -sanitizeEvents <- function(events, nodes, nodes2 = nodes) { - if (is.character(nodes)) nodes <- get(nodes) - if (is.character(nodes2)) nodes2 <- get(nodes2) +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) } @@ -150,11 +150,6 @@ sanitizeEvents <- function(events, nodes, nodes2 = nodes) { events } - - - - - #' Reduce preprocess output #' #' It took a preprocess object and return a matrix with all the From f6cf9f99af5c1066849f52c607cca0f031867f75 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Mon, 6 Nov 2023 11:31:56 +0100 Subject: [PATCH 20/36] Adding `envir` argument to `estimate()`, and update the documentation accordingly --- R/functions_data.R | 5 ++++- R/functions_estimation.R | 44 +++++++++++++++++++++----------------- R/functions_gather.R | 7 +++--- man/GatherPreprocessing.Rd | 3 ++- man/estimate.Rd | 4 ++++ man/simulate.Rd | 12 +++++++---- man/update-method.Rd | 8 +++++-- 7 files changed, 51 insertions(+), 32 deletions(-) diff --git a/R/functions_data.R b/R/functions_data.R index b356bbe..f690447 100644 --- a/R/functions_data.R +++ b/R/functions_data.R @@ -21,6 +21,8 @@ #' @param startTime a numeric `as.Date` format value; prior events are #' disregarded. #' @param ... Not further arguments are required. +#' @param envir an `environment` where the nodes and linked events +#' objects are available. #' @return The respective object updated accordingly to the events link to it. #' For `nodes.goldfish` object the attributes are updated according to the #' events linked to them. @@ -38,7 +40,8 @@ #' bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) #' bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) #' -#' updateStates <- as.data.frame(states, +#' updateStates <- as.data.frame( +#' states, #' time = as.numeric(as.POSIXct("1965-12-31")) #' ) #' diff --git a/R/functions_estimation.R b/R/functions_estimation.R index 2e89e85..0e0d7dc 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -131,6 +131,8 @@ #' network (see [defineDependentEvents()]) and at the right-hand side the #' effects and the variables for which the effects are expected to occur #' (see `vignette("goldfishEffects")`). +#' @param envir an `environment` where `formula` objects and their linked +#' objects are available. #' #' @return returns an object of [class()] `"result.goldfish"` #' when `preprocessingOnly = FALSE` or @@ -269,8 +271,10 @@ estimate <- function( estimationInit = NULL, preprocessingInit = NULL, preprocessingOnly = FALSE, + envir = new.env(), progress = getOption("progress"), - verbose = getOption("verbose")) { + verbose = getOption("verbose") +) { UseMethod("estimate", x) } @@ -285,6 +289,7 @@ estimate.formula <- function( estimationInit = NULL, preprocessingInit = NULL, preprocessingOnly = FALSE, + envir = new.env(), progress = getOption("progress"), verbose = getOption("verbose")) { # Steps: @@ -379,13 +384,11 @@ estimate.formula <- function( ### 1. PARSE the formula---- - PreprocessEnvir <- new.env() - if (progress) cat("Parsing formula.\n") formula <- x ## 1.1 PARSE for all cases: preprocessingInit or not - parsedformula <- parseFormula(formula, envir = PreprocessEnvir) + parsedformula <- parseFormula(formula, envir = envir) rhsNames <- parsedformula$rhsNames depName <- parsedformula$depName hasIntercept <- parsedformula$hasIntercept @@ -444,7 +447,7 @@ estimate.formula <- function( ## 2.0 Set isTwoMode to define effects functions # get node sets of dependent variable - .nodes <- attr(get(depName, envir = PreprocessEnvir), "nodes") + .nodes <- attr(get(depName, envir = envir), "nodes") isTwoMode <- FALSE # two-mode networks(2 kinds of nodes) if (length(.nodes) == 2) { @@ -459,8 +462,9 @@ estimate.formula <- function( ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not # enviroment from which get the objects - effects <- createEffectsFunctions(rhsNames, model, subModel, - envir = PreprocessEnvir + effects <- createEffectsFunctions( + rhsNames, model, subModel, + envir = envir ) # Get links between objects and effects for printing results objectsEffectsLink <- getObjectsEffectsLink(rhsNames) @@ -470,12 +474,12 @@ estimate.formula <- function( # Initialize events list and link to objects events <- getEventsAndObjectsLink( depName, rhsNames, .nodes, .nodes2, - envir = PreprocessEnvir + envir = envir )[[1]] # moved cleanInteractionEvents in getEventsAndObjectsLink eventsObjectsLink <- getEventsAndObjectsLink( depName, rhsNames, .nodes, .nodes2, - envir = PreprocessEnvir + envir = envir )[[2]] eventsEffectsLink <- getEventsEffectsLink( events, rhsNames, eventsObjectsLink @@ -489,7 +493,7 @@ estimate.formula <- function( events <- cleanInteractionEvents( events, eventsEffectsLink, windowParameters, subModel, depName, eventsObjectsLink, - envir = PreprocessEnvir + envir = envir ) } @@ -510,7 +514,7 @@ estimate.formula <- function( newWindowParameters <- windowParameters[which(effectsindexes == 0)] neweffects <- createEffectsFunctions( newrhsNames, model, subModel, - envir = PreprocessEnvir + envir = envir ) # Get links between objects and effects for printing results newobjectsEffectsLink <- getObjectsEffectsLink(newrhsNames) @@ -531,11 +535,11 @@ estimate.formula <- function( # Retrieve again the events to calculate new statistics newevents <- getEventsAndObjectsLink( depName, newrhsNames, .nodes, .nodes2, - envir = PreprocessEnvir + envir = envir )[[1]] neweventsObjectsLink <- getEventsAndObjectsLink( depName, newrhsNames, .nodes, .nodes2, - envir = PreprocessEnvir + envir = envir )[[2]] neweventsEffectsLink <- getEventsEffectsLink( newevents, newrhsNames, neweventsObjectsLink @@ -561,7 +565,7 @@ estimate.formula <- function( endTime = preprocessingInit[["endTime"]], rightCensored = rightCensored, progress = progress, - prepEnvir = PreprocessEnvir + prepEnvir = envir ) # test the length of the dependent and RC updates (in case the events @@ -591,8 +595,8 @@ estimate.formula <- function( allprep <- preprocessingInit allprep$initialStats <- array(0, dim = c( - nrow(get(.nodes, envir = PreprocessEnvir)), - nrow(get(.nodes2, envir = PreprocessEnvir)), + nrow(get(.nodes, envir = envir)), + nrow(get(.nodes2, envir = envir)), length(effectsindexes) ) ) @@ -695,7 +699,7 @@ estimate.formula <- function( rightCensored = rightCensored, progress = progress, groupsNetwork = parsedformula$defaultNetworkName, - prepEnvir = PreprocessEnvir + prepEnvir = envir ) } else { prep <- preprocess( @@ -716,7 +720,7 @@ estimate.formula <- function( endTime = estimationInit[["endTime"]], rightCensored = rightCensored, progress = progress, - prepEnvir = PreprocessEnvir + prepEnvir = envir ) } # The formula, nodes, nodes2 are added to the preprocessed object so that @@ -778,8 +782,8 @@ estimate.formula <- function( # Default estimation additionalArgs <- list( statsList = prep, - nodes = get(.nodes, envir = PreprocessEnvir), - nodes2 = get(.nodes2, envir = PreprocessEnvir), + nodes = get(.nodes, envir = envir), + nodes2 = get(.nodes2, envir = envir), defaultNetworkName = parsedformula$defaultNetworkName, hasIntercept = hasIntercept, modelType = modelTypeCall, diff --git a/R/functions_gather.R b/R/functions_gather.R index bf7f445..0cf727e 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -1,10 +1,8 @@ -# # Goldfish package ---- # # # # Author(s): AU # # # # -# # Description: Helper functions to gather the preprocess data for -# # DyNAM-choice and DyNAM-choice-coordination +# # Description: Helper functions to gather the preprocess data from a model #' Gather preprocess data from a formula @@ -20,7 +18,8 @@ #' @param preprocessArgs Additional preprocess arguments like `startTime`, #' `endTime` and `opportunitiesList`. See [estimate()]. #' @param progress Default `FALSE`. -#' @param envir an `environment` where `formula` objects are available. +#' @param envir an `environment` where `formula` objects and their linked +#' objectsare available. #' #' @return a list with the data and relevant information. #' @export diff --git a/man/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd index a7e5df5..5d77d19 100644 --- a/man/GatherPreprocessing.Rd +++ b/man/GatherPreprocessing.Rd @@ -28,7 +28,8 @@ in \code{vignette("goldfishEffects")}.} \item{progress}{Default \code{FALSE}.} -\item{envir}{an \code{environment} where \code{formula} objects are available.} +\item{envir}{an \code{environment} where \code{formula} objects and their linked +objectsare available.} } \value{ a list with the data and relevant information. diff --git a/man/estimate.Rd b/man/estimate.Rd index ef4cd72..5e8cf13 100644 --- a/man/estimate.Rd +++ b/man/estimate.Rd @@ -11,6 +11,7 @@ estimate( estimationInit = NULL, preprocessingInit = NULL, preprocessingOnly = FALSE, + envir = new.env(), progress = getOption("progress"), verbose = getOption("verbose") ) @@ -104,6 +105,9 @@ the current formula, allows skipping the preprocessing step.} statistics should be returned rather than a \code{result.goldfish} object with the estimated coefficients.} +\item{envir}{an \code{environment} where \code{formula} objects and their linked +objects are available.} + \item{progress}{logical indicating whether should print a minimal output to the console of the progress of the preprocessing and estimation processes.} diff --git a/man/simulate.Rd b/man/simulate.Rd index b49c770..75620e4 100644 --- a/man/simulate.Rd +++ b/man/simulate.Rd @@ -73,10 +73,14 @@ oppose to the general case of simulate events until end time is reached. \examples{ 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) +callNetwork <- linkEvents( + x = callNetwork, changeEvent = calls, + nodes = actors +) +callsDependent <- defineDependentEvents( + events = calls, nodes = actors, + defaultNetwork = callNetwork +) simulateEvents <- simulate( formulaRate = callsDependent ~ 1 + indeg + outdeg, diff --git a/man/update-method.Rd b/man/update-method.Rd index 306c4d3..10258ec 100644 --- a/man/update-method.Rd +++ b/man/update-method.Rd @@ -6,7 +6,7 @@ \alias{as.matrix.network.goldfish} \title{Methods to update a nodes or network object} \usage{ -\method{as.data.frame}{nodes.goldfish}(x, ..., time = -Inf, startTime = -Inf) +\method{as.data.frame}{nodes.goldfish}(x, ..., time = -Inf, startTime = -Inf, envir = new.env()) \method{as.matrix}{network.goldfish}(x, ..., time = -Inf, startTime = -Inf) } @@ -22,6 +22,9 @@ to update the state of the object \code{x} until this time value \item{startTime}{a numeric \code{as.Date} format value; prior events are disregarded.} + +\item{envir}{an \code{environment} where the nodes and linked events +objects are available.} } \value{ The respective object updated accordingly to the events link to it. @@ -48,7 +51,8 @@ states <- linkEvents(states, gdpchanges, attribute = "gdp") bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) -updateStates <- as.data.frame(states, +updateStates <- as.data.frame( + states, time = as.numeric(as.POSIXct("1965-12-31")) ) From c9f19fd3abcc5de7af7cb9f7ee946af1f21ddeae Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 6 Mar 2024 13:50:21 +0100 Subject: [PATCH 21/36] Add helper objects for two-mode testing --- R/testthat-helpers.R | 159 ++++++++++++++++++++++++++++++------------- 1 file changed, 113 insertions(+), 46 deletions(-) diff --git a/R/testthat-helpers.R b/R/testthat-helpers.R index 6a39601..c28ddf9 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -1,10 +1,3 @@ -##################### ## -# -# Goldfish package -# Helper data testing ----------------------------------------------- -# -#################### ### - # DyNAM ------------------------------------------------------------- # Networks --------------------------------------------------------- @@ -222,24 +215,6 @@ effectFUN_REM_sim <- function( } # Preprocessing DyNAM --------------------------------------------------------- -# direct network -eventsIncrement <- data.frame( - time = cumsum( - c(1, 5, 3, 4, 2, 1, 3, 4, 5, 1, 3, 4) - ), - sender = sprintf( - "Actor %d", - c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5, 1) - ), - receiver = sprintf( - "Actor %d", - c(2, 2, 3, 3, 1, 5, 4, 4, 2, 3, 2, 2) - ), - increment = - c(1, 2, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1), - stringsAsFactors = FALSE -) - actorsEx <- data.frame( label = sprintf("Actor %d", 1:5), present = c(rep(TRUE, 4), FALSE), @@ -253,6 +228,48 @@ compChange <- data.frame( replace = c(TRUE, FALSE, TRUE, FALSE, FALSE, TRUE, TRUE) ) +actorsEx <- defineNodes(actorsEx) +actorsEx <- linkEvents( + x = actorsEx, + changeEvent = compChange, + attribute = "present" +) + +# changing attribute +attrChange <- data.frame( + node = sprintf("Actor %d", c(5, 4, 3, 1, 2, 3, 4)), + time = c(11, 18, 23, 31, 32, 33, 35), + replace = c(1.2, 1.67, 2.46, 7.89, 3.32, 2.32, 3.44) +) +actorsEx <- linkEvents( + x = actorsEx, + changeEvent = attrChange, + attribute = "attr1" +) + +# two-mode +clubsEx <- data.frame( + label = sprintf("Club %d", 1:3), + present = c(rep(TRUE, 2), FALSE), + clubSize = c(7, 9, 2), + stringsAsFactors = FALSE +) + +clubsChange <- data.frame( + node = sprintf("Club %d", c(3, 1, 1)), + time = c(14, 17, 19), + replace = c(TRUE, FALSE, TRUE) +) + +clubsEx <- defineNodes(clubsEx) +clubsEx <- linkEvents( + x = clubsEx, + changeEvent = clubsChange, + attribute = "present" +) + + +# direct network networkState <- matrix( c( 0, 3, 0, 0, 0, @@ -268,12 +285,21 @@ networkState <- matrix( ) ) -# defining objects -actorsEx <- defineNodes(actorsEx) -actorsEx <- linkEvents( - x = actorsEx, - changeEvent = compChange, - attribute = "present" +eventsIncrement <- data.frame( + time = cumsum( + c(1, 5, 3, 4, 2, 1, 3, 4, 5, 1, 3, 4) + ), + sender = sprintf( + "Actor %d", + c(1, 3, 2, 2, 5, 1, 3, 3, 4, 2, 5, 1) + ), + receiver = sprintf( + "Actor %d", + c(2, 2, 3, 3, 1, 5, 4, 4, 2, 3, 2, 2) + ), + increment = + c(1, 2, 1, 1, 1, 2, 1, 1, 1, 1, 1, 1), + stringsAsFactors = FALSE ) networkState <- defineNetwork( @@ -292,6 +318,21 @@ depNetwork <- defineDependentEvents( ) # exogenous network +networkExog <- matrix( + c( + 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, + 0, 2, 0, 0, 0, + 1, 0, 0, 0, 0, + 1, 2, 0, 0, 0 + ), + nrow = 5, ncol = 5, byrow = TRUE, + dimnames = list( + sprintf("Actor %d", 1:5), + sprintf("Actor %d", 1:5) + ) +) + eventsExogenous <- data.frame( time = c(7, 14, 15, 18, 18, 25, 25), @@ -308,21 +349,6 @@ eventsExogenous <- data.frame( stringsAsFactors = FALSE ) -networkExog <- matrix( - c( - 0, 0, 0, 1, 0, - 0, 0, 0, 0, 0, - 0, 2, 0, 0, 0, - 1, 0, 0, 0, 0, - 1, 2, 0, 0, 0 - ), - nrow = 5, ncol = 5, byrow = TRUE, - dimnames = list( - sprintf("Actor %d", 1:5), - sprintf("Actor %d", 1:5) - ) -) - # define goldfish objects networkExog <- defineNetwork( matrix = networkExog, @@ -334,6 +360,47 @@ networkExog <- linkEvents( nodes = actorsEx ) +# two-mode network + +networkActorClub <- matrix( + c( + 1, 0, 0, + 1, 0, 1, + 0, 0, 0, + 0, 1, 0, + 0, 1, 0 + ), + nrow = 5, ncol = 3, byrow = TRUE, + dimnames = list( + sprintf("Actor %d", 1:5), + sprintf("Club %d", 1:3) + ) +) + +eventsActorClub <- data.frame( + time = + c(3, 8, 12, 17, 20, 30, 35), + sender = sprintf( + "Actor %d", + c(1, 4, 5, 2, 3, 1, 3) + ), + receiver = sprintf( + "Club %d", + c(2, 1, 2, 2, 1, 1, 3) + ), + replace = + c(1, 1, 0, 1, 1, 0, 1) +) + +networkActorClub <- defineNetwork( + matrix = networkActorClub, + nodes = actorsEx, nodes2 = clubsEx, directed = TRUE +) +networkActorClub <- linkEvents( + x = networkActorClub, + changeEvent = eventsActorClub, + nodes = actorsEx, nodes2 = clubsEx +) # DyNAM-i ----------------------------------------------------------- # Attributes -------------------------------------------------------- From 07fd137a52526e0fc586b61cfb7e253177927be1 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 6 Mar 2024 15:01:17 +0100 Subject: [PATCH 22/36] Update URLs for project repository and Mac installation --- .github/OpenMP_mac.md | 52 +++++++++++++++++++++++++++++++++++++++++++ DESCRIPTION | 4 ++-- README.md | 21 ++++++++--------- _pkgdown.yml | 4 ++-- 4 files changed, 67 insertions(+), 14 deletions(-) diff --git a/.github/OpenMP_mac.md b/.github/OpenMP_mac.md index f7a0b5c..8b7d2eb 100644 --- a/.github/OpenMP_mac.md +++ b/.github/OpenMP_mac.md @@ -33,3 +33,55 @@ SHLIB_LIBADD = -L/usr/local/lib ``` 6. Installing goldfish from source should work now. Otherwise get in contact with the developer team. + +### Update for M1, M2, ... machines + +If you are using an M1, M2, ... machine, you could follow the previous instructions to install a `gcc` compiler and setting up the compilers for `R`. +Thanks to @eugeniagilpa, here there is an alternative version of the `Makevars` file that should work for M1, M2, ... machines: + +``` +XCBASE:=$(shell xcrun --show-sdk-path) +GCCBASE:=$(shell brew --prefix gcc) +GETTEXT:=$(shell brew --prefix gettext) + +CC=$(GCCBASE)/bin/gcc-13 +CXX=$(GCCBASE)/bin/g++-13 +CXX11=$(GCCBASE)/bin/g++-13 +CXX14=$(GCCBASE)/bin/g++-13 +CXX17=$(GCCBASE)/bin/g++-13 +CXX20=$(GCCBASE)/bin/g++-13 +CXX23=$(GCCBASE)/bin/g++-13 +SHLIB_CXXLD=$(GCCBASE)/bin/g++-13 +FC=$(GCCBASE)/bin/gfortran +F77=$(GCCBASE)/bin/gfortran +FLIBS=-L/$(GCCBASE)/lib/gcc/13/ -lm -lgfortran + +CPPFLAGS=-isystem "$(GCCBASE)/include" -isysroot "$(XCBASE)" +LDFLAGS=-L"$(GCCBASE)/lib" -L"$(GETTEXT)/lib" --sysroot="$(XCBASE)" + +MAKE=make -j8 + +SHLIB_OPENMP_CFLAGS=-fopenmp +SHLIB_OPENMP_CXXFLAGS=-fopenmp +SHLIB_OPENMP_FCFLAGS=-fopenmp +SHLIB_OPENMP_FFLAGS=-fopenmp + +SHLIB_CXXLDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXXFLAGS) $(CXXPICFLAGS) $(LTO_LD) +SHLIB_CXX11LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXX11FLAGS) $(CXX11PICFLAGS) $(LTO_LD) +SHLIB_CXX14LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXX14FLAGS) $(CXX14PICFLAGS) $(LTO_LD) +SHLIB_CXX17LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXX17FLAGS) $(CXX17PICFLAGS) $(LTO_LD) +SHLIB_CXX20LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXX20FLAGS) $(CXX20PICFLAGS) $(LTO_LD) +SHLIB_CXX23LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CXX23FLAGS) $(CXX23PICFLAGS) $(LTO_LD) + +SHLIB_FCLDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(FCFLAGS) $(FPICFLAGS) +SHLIB_LDFLAGS = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CFLAGS) $(CPICFLAGS) $(LTO_LD) +SHLIB_LDFLAGS_R = -dynamiclib -Wl,-ld_classic,-headerpad_max_install_names -undefined dynamic_lookup $(CFLAGS) $(CPICFLAGS) $(LTO_LD) +``` + +In step 5 the path to the library should be: + +``` +SHLIB_LIBADD = -L/opt/homebrew/opt/gfortran/lib +``` + +Please share feedback on which of these work (shortcuts or unnecessary parts) and we will update the installation guide accordingly. diff --git a/DESCRIPTION b/DESCRIPTION index c741ba8..c908569 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,8 +28,8 @@ Description: Tools for fitting statistical network models to dynamic network dat Stadtfeld, Hollway, and Block (2017b) , Stadtfeld and Block (2017) , Hoffman et al. (2020) . -URL: https://snlab-ch.github.io/goldfish/ -BugReports: https://github.com/snlab-ch/goldfish/issues +URL: https://stocnet.github.io/goldfish/ +BugReports: https://github.com/snlab-ch/goldfish/issues/ Depends: R (>= 3.5.0) Imports: Rcpp (>= 1.0.1), diff --git a/README.md b/README.md index 1f4f8d5..878ddce 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,13 @@ # goldfish -![GitHub release (latest by date)](https://img.shields.io/github/v/release/snlab-ch/goldfish) -![GitHub Release Date](https://img.shields.io/github/release-date/snlab-ch/goldfish) -![GitHub issues](https://img.shields.io/github/issues-raw/snlab-ch/goldfish) -![GitHub All Releases](https://img.shields.io/github/downloads/snlab-ch/goldfish/total) -[![R-CMD-check](https://github.com/snlab-ch/goldfish/actions/workflows/R-CMD-check.yml/badge.svg)](https://github.com/snlab-ch/goldfish/actions/workflows/R-CMD-check.yml) -[![Codecov test coverage](https://codecov.io/gh/snlab-ch/goldfish/branch/master/graph/badge.svg)](https://app.codecov.io/gh/snlab-ch/goldfish?branch=master) -[![CodeFactor](https://www.codefactor.io/repository/github/snlab-ch/goldfish/badge)](https://www.codefactor.io/repository/github/snlab-ch/goldfish) +![GitHub release (latest by date)](https://img.shields.io/github/v/release/stocnet/goldfish) +![GitHub Release Date](https://img.shields.io/github/release-date/stocnet/goldfish) +![GitHub issues](https://img.shields.io/github/issues-raw/stocnet/goldfish) +![GitHub All Releases](https://img.shields.io/github/downloads/stocnet/goldfish/total) +[![R-CMD-check](https://github.com/stocnet/goldfish/actions/workflows/R-CMD-check.yml/badge.svg)](https://github.com/stocnet/goldfish/actions/workflows/R-CMD-check.yml) +[![Codecov test coverage](https://codecov.io/gh/stocnet/goldfish/branch/master/graph/badge.svg)](https://app.codecov.io/gh/stocnet/goldfish?branch=master) +[![CodeFactor](https://www.codefactor.io/repository/github/stocnet/goldfish/badge)](https://www.codefactor.io/repository/github/stocnet/goldfish) [![CII Best Practices](https://bestpractices.coreinfrastructure.org/projects/4563/badge)](https://bestpractices.coreinfrastructure.org/projects/4563) @@ -38,10 +38,10 @@ between initial and repeated creation of ties (multiplicity of ties). You can install the latest version of the `goldfish` package from source using `remotes`: ```r -remotes::install_github("snlab-ch/goldfish", build_vignettes = TRUE) +remotes::install_github("stocnet/goldfish", build_vignettes = TRUE) ``` -Or by downloading and install the latest binary from [the releases page](https://github.com/snlab-ch/goldfish/releases). +Or by downloading and install the latest binary from [the releases page](https://github.com/stocnet/goldfish/releases). ### Installing OpenMP on Mac OSX @@ -51,12 +51,13 @@ The error may relate to compiling the parts of `goldfish` that are written in C+ or whether OpenMP (for parallelisation) can be found. Many installation woes can be solved by directing R to use [Homebrew](https://brew.sh) installed `gcc`. -An updated setting up instructions thanks to @timonelmer are available [here](https://github.com/snlab-ch/goldfish/blob/main/.github/OpenMP_mac.md). +An updated setting up instructions thanks to @timonelmer are available [here](https://github.com/stocnet/goldfish/blob/main/.github/OpenMP_mac.md). More details can be found [here](https://medium.com/biosyntax/following-up-library-dependency-when-compiling-r-packages-89f191b9f227) (Thank you @Knieps for identifying this.). Other links that may be helpful include: - https://asieira.github.io/using-openmp-with-r-packages-in-os-x.html - https://thecoatlessprofessor.com/programming/cpp/r-compiler-tools-for-rcpp-on-macos/ - https://ryanhomer.github.io/posts/build-openmp-macos-catalina-complete +- https://pat-s.me/transitioning-from-x86-to-arm64-on-macos-experiences-of-an-r-user/ Please share feedback on which of these work and we will update the installation guide accordingly. diff --git a/_pkgdown.yml b/_pkgdown.yml index b5bb4e9..ca2f1ae 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -1,5 +1,5 @@ destination: docs -url: https://snlab-ch.github.io/goldfish/ +url: https://stocnet.github.io/goldfish/ development: mode: auto template: @@ -32,7 +32,7 @@ navbar: href: news/index.html github: icon: "fab fa-github fa-lg" - href: https://github.com/snlab-ch/goldfish + href: https://github.com/stocnet/goldfish reference: - title: "Define" contents: From de3e9a6259f52008b464bab76df2776213571f9b Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 6 Mar 2024 16:03:08 +0100 Subject: [PATCH 23/36] Update vignettes --- vignettes/dynami-example.R | 50 ++++++++++---------- vignettes/teaching/plot-teaching1-1.png | Bin 1738 -> 1738 bytes vignettes/teaching/plot-teaching2-1.png | Bin 11946 -> 13085 bytes vignettes/teaching1.R | 58 +++++++++++------------ vignettes/teaching1.Rmd | 53 +++++++++++---------- vignettes/teaching2.R | 50 ++++++++++---------- vignettes/teaching2.Rmd | 60 ++++++++++++++++++++---- 7 files changed, 157 insertions(+), 114 deletions(-) diff --git a/vignettes/dynami-example.R b/vignettes/dynami-example.R index 3e51ccf..9d62a7c 100644 --- a/vignettes/dynami-example.R +++ b/vignettes/dynami-example.R @@ -1,67 +1,67 @@ -## ----setup, include=FALSE---------------------------------------------------------------------------------------------- +## ----setup, include=FALSE-------------------------------------------------------------------------------------------- knitr::opts_chunk$set(echo = TRUE) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- library(goldfish) data("RFID_Validity_Study") #?RFID_Validity_Study -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- head(participants) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- head(rfid) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- head(video) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- #?defineGroups_interaction prepdata <- defineGroups_interaction(video, participants, seed.randomization = 1) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- groups <- prepdata$groups head(groups) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- dependent.events <- prepdata$dependent.events head(dependent.events) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- exogenous.events <- prepdata$exogenous.events head(exogenous.events) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- interaction.updates <- prepdata$interaction.updates head(interaction.updates) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- opportunities <- prepdata$opportunities head(opportunities) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- # goldfish requires character names participants$label <- as.character(participants$label) actors <- defineNodes(participants) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- groups <- defineNodes(groups) -## ----warning=FALSE----------------------------------------------------------------------------------------------------- +## ----warning=FALSE--------------------------------------------------------------------------------------------------- init.network <- diag(x = 1, nrow(actors), nrow(groups)) network.interactions <- defineNetwork( matrix = init.network, nodes = actors, nodes2 = groups, directed = TRUE @@ -76,21 +76,21 @@ network.interactions <- linkEvents( ) -## ----warning=FALSE----------------------------------------------------------------------------------------------------- +## ----warning=FALSE--------------------------------------------------------------------------------------------------- network.past <- defineNetwork(nodes = actors, directed = FALSE) network.past <- linkEvents( x = network.past, changeEvents = interaction.updates, nodes = actors ) # don't worry about the warnings -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- dependent.events <- defineDependentEvents( events = dependent.events, nodes = actors, nodes2 = groups, defaultNetwork = network.interactions ) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- formula.rate.M1 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -102,7 +102,7 @@ formula.rate.M1 <- dependent.events ~ 1 + tie(known.before, joining = -1, subType = "proportion") -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- formula.choice.M1 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -111,12 +111,12 @@ formula.choice.M1 <- dependent.events ~ tie(known.before, subType = "proportion") -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- est.rate.M1 <- estimate(formula.rate.M1, model = "DyNAMi", subModel = "rate") summary(est.rate.M1) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- est.choice.M1 <- estimate( formula.choice.M1, model = "DyNAMi", subModel = "choice", @@ -125,7 +125,7 @@ est.choice.M1 <- estimate( summary(est.choice.M1) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- formula.rate.M2 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -140,7 +140,7 @@ formula.rate.M2 <- dependent.events ~ 1 + egopop(network.past, joining = -1, subType = "normalized") -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- formula.choice.M2 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -154,12 +154,12 @@ formula.choice.M2 <- dependent.events ~ inertia(network.past, window = 300, subType = "mean") -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- est.rate.M2 <- estimate(formula.rate.M2, model = "DyNAMi", subModel = "rate") summary(est.rate.M2) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- est.choice.M2 <- estimate( formula.choice.M2, model = "DyNAMi", subModel = "choice", @@ -168,7 +168,7 @@ est.choice.M2 <- estimate( summary(est.choice.M2) -## ---------------------------------------------------------------------------------------------------------------------- +## -------------------------------------------------------------------------------------------------------------------- cov.matrix <- vcov(est.rate.M2) est.interceptjoining <- coef(est.rate.M2)[1] + coef(est.rate.M2)[2] diff --git a/vignettes/teaching/plot-teaching1-1.png b/vignettes/teaching/plot-teaching1-1.png index 6ef4e52c95fcff5764a9b340d65b56a8e1a6b31b..133b7d22055565d1d5da4c8eab1079387901811e 100644 GIT binary patch literal 1738 zcmeAS@N?(olHy`uVBq!ia0y~yVEh5X9LzwGiQo8rffQSSPlzj!{{R2~(wp<|0$H2| z9+AZi4BSE>%y{W;-5;Q;EKe85kcv5P??e~fb`xO;O#eUIZ|R&O)lDg$3UbBE&;Q(R zQY_8FIN?+Oeve-tzc5v_eF!|{&MB{2GlekYkA2;jV;63JtZrGJbo|4?>+iq6wNQSz z|3J^8mVO~SuOAu@7q{4F{n&f>%~gBP3N@GzT&{nXaNUo|o35Ujx$MJoqq898P`Uh# z_jFGdao?K!LB|PfOn;TdpDJ-%(L?T%$S#w=@wYDd^V`2ADvLfy->`io=q7~Q<@+aC z+xrOBDIO}egxMtQ`>X5vf~D*HE2gPK%stC%|I#bVQQY@^o7SQIDR~ufN&(=Y&=tNH zdT{SF$?YG$8@)qvD%{OrhL-rh1MQC9wRI)elEQ9X)@}L!{rQ~F$ury_z7YDys2!uL zx1mMuVPy~Y0G8$5f9P>qoI=f%I@Fjb4X^nAw_DII>!w`alx$t=xQFXg_XJkA)_*WD ze9L2+vva<{zte5H(>HU-tNyvPu9{h}F7r^a5zMP7PQHJlTL)?e& zzwE@^Pt(v{^ha2%!t2W)uCA8nnupwLrRo|t3yBNZd0ks!eAwEON2z8?7^)jpYpzWB zAjda1=afyW{me=?PI*y|_py&`8y9l?mvinEvU|1i!@2$UOFtcHnV&TI!*0oP1^?*x zt6I|8Fq~QY_v6AzAASqXyN@L`{%q#(&=JcKe~#D*yS-YVRM%InFb; z^jF#L;XXLAr9Vg)k_eGfoWwol#lk*w7Jg7SIIQu|z3T50^*O-24u|%q@0b0X_Fq;`(PlSh z1_6n5`c*8^`Qvh^7(GXBjs9`qy2|;Dx97C{S1RrTsjb%eF1F=XRhge^OF(ecepX{kjh;+d=;PtGFlo!(5{;lTG0!5(x*5|j6 zPn&Hu{lor$XQxf>5Ui8@-WPf}mE(VR@afWNa%(?aH@tqbShpjdK^R|pt zj)z75`Ls!*L%y{W;-5;Q;EKe85kcv5P?=a@wwh(Z*`0lU%-Wz&cTQcSxnWn@0^S(8s zW&Bnb%@_Uk9={5|Gwo>q5O~O)Q(m=Z3PFY__kZPW_m3wv3;Yvr?hvx``l0dAe)C7= zgZr$ln?Jm919BIO@$LV}`-6#_-~Wd)k3LAn;+B4p(#dPejz#3`Eap5f1QCGCKp9yP zKd#=ZSf71kLF@i5N4S&X^N$F>X)(RRalRI$FYEUQ<-8Tlx%OfY?bCEnoc@3N5zY-8 zj;C{;-v?6pYSxF&-Or+0`h!&9&d56Z!H=_jt)=5be&d6Wr|sbhkNIqJXfq$sk@9cm zeiwMiE_r4`U5`$4GcsI-TAk^*KB%w?3|*_Y(a1sPA`4))A>g#=Xq{O$gG%p`2Fvww@ljS z{eCc?(Sw;~wMTu``n3ki5AP?mO6qQKx#tKB-Q_!9*eU)oIrP~N6pN+BKScfZR14Xi zdH@Y})KEUv`hC)m`kjUx|Lv2Z5eQYcw&wqas=5mHr_!9~#Y4J4G4?#CSowCUe7NAe zt;)y8TFJUYe>*@P&4zjOkJ7oi6Jm9Ohl;si zNdWGa6}J!lK3A{*aB+`4B5JOG;Ny+IQEI2(zCOlqVs7314{P3C&W`v|%X$7jBwQ}9 zE!49}otT~TRV&-a`G>~IMG$egxp2k`_lLFRJ8xWN7O(5je0cMY(8Irf=Hz!yh(JFhts!~>`LBc{lEXi6%Ish|N8dB!^!8Twd_CG z63G|g)c@g5+TRbt|9imvf3&Wf%onsa+4Ud4 zF;joI|KuDjY4siF`@gr|0t+YwcrHL?yn47fo_E#nf36kxvhJ{&<=T2zE?V}%S~C1I zC%67wWo)TGO6$+5^&ZP3v!)!He_R78R=|ZYFoBivy?4E@UN*1y!+e9;8V}`f{bo;o neO6Z4Mj9om;aLeM<5m2NPxs{v1)g*Rt0D$ZS3j3^P6_r$1k0q(d*oBNeTMQ%nU?$nKlULL*k9k@@4xqYulM=u+~>YOXL-)Ku5+KyeV@xo=z* zxg&g8BvTg_wh~tN6}E~M(Xy9OQo3`M?9SDzcZ}_ol$26zq^@d-kZIZ58{6Ak36oj< zkFAxua7wClN|zs%KS%6HngY2XkdQy87>wiTtx=yY_ZzF(c>md;u}U=eesR#6-)tRk zf54wQpTyL>w+(Fwu8WHcAufT3e_pUWCkSEm5%4>Qjv9AQ2_o~z8k}$1#5fV-7vw|R zX*!Gb{}oK&ZQwh7;QRj#D5eeL z`7eJj^yQg8pbVik)@(?mqeK1v;Tr`3Q&wf-fWA+2M_=VRg}p*4u}-dkQuQf*r{;fy$5Q*&9sD0 z=;?yizLfC_e@DlZK_c?jr9D3e*p)Kg`oxOQp7X@T;0AbToh*aTFjqrQ=N1DMhB*8q z|La+s-^n!i0JHfTFgx2kvGx*Q*&3^&Ikg&ftLQ*%tVK&;53|7Yi3it?>N{`@wv*PG z4r-m0h#igV~3Nbzq zXx5mcfTpf3(g1tJS>_nA3XOovmV9qllvUIicibSI@3s$J-Fj0AzkXU6ApadSZ4{JL zehkF|U0aGj9ytvEtAukxCLB_*Z!>XxC^#RUD|OEAwu@P=sIkKJQ!~^obN7q{ZMs6@ zsmtK~bf)evSud;co|UGA<~CUbw%Ylo=u-pq!ifoON92XqO+KeRp4VAo)v;ogJy_vN zCF*l7rGy{aRK(66Un z6lRDYOQgkiI{rQ%_fGluHhXFA=y{Q^Yx<*BMo4*>9Ug#O9Qv1qbatNOM1G<-9#Ftj zbS?cEPr<;+afmtVZ}p?q@lYHpt2ED4Iv|SnKb0{K62TpdUszAbc)4E^b6E#4o(>(X zb|udSUBHpxQKzcC-nyQl8Q*a6Y)EB}fLdRgRP5o$a*gim^*0ES)BmWSs0#{m$#~5_ z@Q$CHWSqx!WmWhh9SHLsH9@f<$suKnyky(5TR|O>i8uEg5yUg)%J#-v57zwPo2lEo z<$io<;YD`A=co`Bb2IrmE`EqxF^+)Vef$tq0r2P?cvdzIF)UwXY$&*9u%L z!hm+GKcuwB!VS#7|7m2p@P(>Z05Hg^GeNz_X0q|8XK>E^g)id<-j**14k znr_fKK78dv+!O9V;G&2_{o4PaR!i0586Eh?CCK1P0nFXNN3OCpiqWiXK3Zt+2}0+f z6`Rn6X!761HHrO?y$wdqZN;RWhVYQ}&a7LmV44SsI@b$>?Q5FWOJjuiWLsE+gmcF8 zL)qQ>@eZaM@M@~lfxeagrG!c&%1-B^ch>%#K**W#%PRv1Rj`$T3L{>+Hn-q+!Ok*< z2*NkO2R~Th2!iU;`>SZO=6?XeWXG%Y)`WXLr^{K#R(?tBJ|1nA{4rtHyhuZ%m1mZ} zT~Tt=`16QXR%w+Z2lTGAZ>>K09z;nD`mk}*7g^1K7HM`789Dp6WPm8tM2~#35g^TM zx_#fND$uHo*p%VHW+n46Xw1F66DSrP#}o!M%`NfeN%mM`%jA~*yeYS(wlZ&dVR7DP4)k+$WZY@z!IBPE#VE zO}^M$ffT22;p&piDIo&6g(&?h7MX03a5t9duHG~M*E4J#Pu-o_ZN9-4K*>#Vp(ex- zLDb0oDihJ&tF7)0tjYD~Tb<2V$QT6_Dd_O`CdrhDyyuqBT+#O;ii_hEX^aCL3lKKc z(1OAt2*W_6#z%4{N?g4#*@%3bdE`UM)#%qzXnUV&m2_H-9vP&&^Q)pBT{C*KP)ZkmcD&heywZKbnfsvz zNVgn_%aJJ_W?K;xdyqixcT|U%#88c6K^iGEYz>6RI>RgStzU#P%%ntx-8ExR>8kigX@mL z=C1{2vC^rL;UA=(m9K zr(tm{J1=gLnvpL}gO8`#w>_?mRR7u!qK&EhEQU8^s2B-_eG3ufb75?{qib2V+?rBW)Yh7&RM zQ63SY1Vj+owYpRMrtXaatNz9LAu=&l|kOSND~5nIG(l&*AJVi zf7bzw1&~q3)gx?}_+(w|g|fk*A02EbJ1wu&R{9>Ru_HCuNP`EQ>d`HK=`^DRd7+LiyXW9U$mjEIlF625OK(!*fs@fb>$6f8$-SY)vi@f`*? zr0y}G0V?5^(O3GR*S^H1I4J)4w`^ z^QXG-Qlp5keAZ{^&huwhd6MBe`0$RT?bRx*xAVk8pH`Pg zPMcQ-{*m14m!{~ruMKV;s28KEoxPX8Ee8MG&XD!D!j#_|v(x{Y57-!pks15OJ7u@f zB1PIkNhhW0+FS0@a)m;wWp0G4F}d2hyr>vFx6g(zTmIDg7TLB?XRQD9uWuS0q#bT*n9*(vCgH5W z9nM;(9vY|kAoNE`PiG|xn6SyCeR?P8$3e3HmD4#7WSO`JfTm3u^*}!|XAjpW3WrCL z(Vw2GJ}LX;zZu;L>C~9SoV=#3{*`{yzdzCqPF?>@r4PxD-dMB#3E3tTWXu@wXUt7= z@#@~Swx&n;6JVi!pF(>X5n{yh4LZWViXJRnjc-KoE;s)dvs~vK6z;JrHp-0mLDD!C zyy1RmTVyy8@h~5HK;IQRbK64U&(Yhby)UQzKi4^%yxnc{Oh@> zn{UyhQ+(1Nt;Ori|DvgQgwHZui*=8E8zD#Hf4Ig)q4__pjZ<`fV4k6H*EZ!}Ny<0} zOg&O`RkoQGt1N(sO2vo1RIqZNsM8!QjwJ#8p4luQ_|K16cyjfhs2orG{_t3QcwOJ@ zFBUNmvCExpt9_SCY*rLZi5NYvvp3sD_iS1~AU-?yW@6JMoBORke5JJ7e6zGCvq;aR zj3y)Dw;0AsjSeecd{|@ry6~B^BFqoS+$x|@qAadHVytM8Vb=H|SXC;AXS<5kouP^} z*f4CKCD)96OQ|V2T_hctIu=On^D3Qc-sH@TpGI1mMWgj@27{yI&;1%s((`Hajr3nb z27I)d7aL6DSFycZrDYljrLIa|t=P}w?$cgT@D%mC%D;(o3x7RYH&_Yp)-qy%tUNyd z*H>HKFa{bbfwnb3jiB`?&|L5{D&TO%o(OcByK5?)CY2oI6^51SwSN=oMWjqPTlm%F z_JUB^cV^W8plZO-yg6|c;NEyrh-V%*zvbfa`{jbs%i!9baj|Nw@*G5FaN_Pl5|QE| zfp!`QOFny$a%Q?srD;uXFb+si%c!b#u>UkZc~jECLnxL#?Jid`viN?rs z@7pX&linz1xkYN{v<)Xs4(}uuRA&?C?{An`Ddo8VOo+BeZ*9pRVA;e%1cWm3l&En| zy_o*ha3IS;-yk$g?dVH5sPN-IB^AwVDh>V7Z;}_Sj5hGotr(5o5!7@Lo1w*>K2oM; z+WaVQd3hto${qVsE3Oc=x%iAP3cWBpu{h3HmwCUI29-bgF=hE$Q=i)Z2iL5g$~L0 zYONT`sWhI2eiWuKhG3ZpCafmd+1?SiIc$*ms~?#7kJECb6ir*ckn7JK`>qdRUp$~f zGQD2_=i3uj`teB;b1w=ltqCp86aH8qsKKqHmBwF>Q2jLX2M!g8ElpGKJ%+ z z4^k~Y?R#Xmbxe)*nC0VtK^=-Ke4+e(UTKD7nFAwy&YY4rWd*nIyb`)`l#NNFeB3yv z(r-Q%rU||BJd#kTxAr2cOsqn#Pzk%fDTQ}vWWyAncN^Vs*b)E2Mg{5woX?`qb#jezbekzeYp5|JHvz=!40TTG|k1!w6 z&e#!W9TcFDqgHe&<&&eO+5||PD+5{Lq>8{lLk^TzcMmX>s6lLnNi)$dl<=1$-S*Oj zFKQtsz^iZY)MqC*FfWL35KB5*yWzO8`XC?Oe^EE{!RQDlQ)NTW?b`|9QMb$$Nxwx8 zw{#qqtKk`e)5OPA4S4=qUcB0v8uZ&rQKiO^f3UIeW83<&&y?MZbGP48g4ZF9>EkYV zaa4Vbv9IQ^Urp-Ah)u{zZYQN1A#z+;`nmX>N1|XFehK&eO3p9EVnweQnbrKRq9fiJ z=W}}im!#u%1>VMEL0P*mtr#W*{jCBfH6JiWr};SGmwg_~0$&BmPovSHKL|}MP@24Z z81uRPyw5BMxFvMkC5LhRFsp1)e0|1KaYF?B{Q=bohr%srGNkk|n8`71s7W^sr60}J zb^c9wQ*6A}=-b@vAyV{`cVj;JCXDa)nOX<+O2yzM6c+Kg52($d*VRAVY+e`HA? zF%~Yqz>)?qA&rkhPV^K$w_RnzIU3+)Mvx=nqpowxyqVk5zv8102N9}IeP2>zyis6r z6g^(}QS&X*s-C6y%Q<{@r2ULbPGnR}=gHEn^{%^^p@B;~4S$w8aYTxOKf{m=Z2Hv_ zGh+OR7Hp2?_FqP{Y_#sl_9Wm4^N(Lp+wz@C&H^F$*JW96Icn9R>$)u$cODJxTOn(87-9Si4w+Pf8hm?c9+ewFm;MzBjmoqKF};tPv7lG(aUYnXW&DINW8hRW z{xs$VCK?&H_?VDZN#=_2(LZ{-W8xF<^&@@g?if*+@^?^@YYv{{ zMOo0=W9(Ai{rKXvV*$oP(d$52J?4e0IOMcnPp^G&;RmOunV}Hwy>E3XHa;8}qtp-| zs6u%Vo>V%-Oi-Mk?^XT5YoDzetfuhu1f*NL`*WV!BUgtLq&+$Rnu4Gq>663QOCmzB zGS4e>RbBsvv1X2!7XRgsKu}?0m3$dsJq)iWDPU{ca+H0-+NIG-R91Y8nxmX+GRPSf zUbmO|4`OJy14Aah_ESv*1;8fWP&hn;g5N7E{$|YCoxMqJ0zx9|nqb-ttO@^+zsOqr z_QuVTFv5E+jQ+H#xn~jutOdd+m*eD#U+k~931))g;?$s+n~0#S{uOy6f^>l{g+?|^ z)PFP)Z^I6af{blFk2QX{);=l4S@8BBr!?O&SeFuK6VYhUN$t-FIIoSbQ|EtpEaNCa zP#+!J5;ZKJFy_V2Elrc8uAnbae6Zgf9N5_<_*IyF{Gr>`8S>vJL1P$DWy4-Vl$iav zy_EPxy9hr+-F@T@og-nI{JTho5M%ZC0of2n$4!xubo~&*;I(6Wj?!Xq1qF0KCmY+= zyQZ^uNt%S$ra%EXWj0tjfB!0!dFoH0=xK0U&OjE&sZ_xO|0%Jmc9m6^TkEL=$ zKegYd_}t4E8q5lfg;4Q}0yH0gV`ZLVx`td@{WG~@u_r~a8&KP4%d{ib3*2H=b4+81 zUjlFHD)9^NGKmQVId>zM@kjTEPH>6(CQQPvlg#sB5I`O{w%{m&ff6U)QW`UT-oSS& z<8c?{pcuL;rg>4{(~@$U`rwdsxWw;q3K^Y29p%@a#%r!Z0uz7z$~Jq9-+6JPgQo(N zXdnu;@1k|*&w^rfT~Z3RpUBJ9C5*T2j^%jTX>O>n zIf%wsLO~}M%-$y3qZSOs+OrBik5EPGuaoBsmVz$XP?i2jm4V3O4Z=Md&AxMd52K?K znYje(1cl5PgrBvn-8-J^dz>tlQM0i%rQ^W)wB*U4XFOL7NMYK*5A56zSP3__l8Mrz zL+vH3n7Y#r>C`No&$B!sxWBJDk81cFS-C#lfu98N5S;0#Vpsk-2u|`B`I~AZishwq*yDB|&=wPLbabQWMo*ee{aFtUhYQoyDy1Z|cxKeP$%# zMYIJEdd>Uk>-)nQ3G&TxN;z?~>XwS@4gEh0WUd}p9{Om%MF8yDry02H4>MivO z7x?_8-d;+o@?$-P7AX*FCVo2a9y9wi%6C;6tQTDd8o#VvKS;m6om`dud)xfebT(1H z&E&8W1UYvOChi4^9IRE8+Xjqkr#k$&HOC@+(pL^f=tO&Xcx=_mV`b1+?{CB0=gL-% z32jn#3(7dX44-ln0SJNgM0vD6u11|ziC@4Z(Tu+v9*l*fI+ykpYsX{axYdK5Pm zA{wPa;(u(UZ87t==k(e1cur8E0IMK?iSKI|sP;JK!yPH;g@%y|gaw}pS-gTCZSo~|2};}hi#Wfw6nJHkZ9-vFQvM0t8g zvrPK)h4=|>u%O+M>WGRb1w>}~I^?;^-Gwfddq1wS_4Y}R9Uv}>!LtkVhU!Pbg+`zY!((%{k}x5TyxzY(RY<@4R1;os%y9Rw9bb3>rp}l3x!if zNDZ7C2{wtjYxiylaOz;r@D=$%%J37>APD>MV5e``8Ll{wKfzboC_^P4u)Li&kr>N# z8AK+t%pW@b!xhL?`J{l6E)UviEZf-$T2JVm?zEr$HS-C=j`hv{?)}MVF0r{dHGTBR z;(!L5t6z83pMn8DEeobXlvbsig@f+C@Qswk{D}p z+^rp$(L2r}H`xdcgY zI!fN3>Ad=_(^^sgF)hilzoDTxpk`J}@pjTDR{$3wV4=x{2f7a*Ifq&_Q8-ro6vBtj zQYpFCziNoevR><0mfCU6;2V9R9DKGzFf2d+S8(hvUr|HnXvD=9diXXy_zw**9pvIW zu)Q+GeoNfBN9=%8pUA7VPoQ|L`t5@Y3!*AgIPKV{(mMwHDd7$JWcOA7&BPdRYM3lV z1~8N>@|h0Z9GrSaIf9lk9&Y})EjZmZ-UMc<>`q;E+HGg=7%6TQCB10v)B1U~;>4Uy zl%LXfUD!I0Bh$Q`x?%LhzXzQj$!A?S^(@rI-=X5HU7ua`|7 zuA)Ck%PGn;cy@*+#c=7(H=oQl+r%^yf%76xO2;MF5cv73=4B9eHqfN;XH*x>xR9>0 zhyVS6EbSmmf=g>36+-`ndndJnf;;S~RszMy;FiDWbmAEyB-y8$T-Sft1Eb z`d+`P^uY&aDy4`Ry3xrGZJSrM44RvugE~(!g_Y)b*N3{M{)nrf<$S*R52K5GHo*{b z3)(J{xqwk> z`Vk&eAK$rxvZcN0U_EkTzT{bo7!J3tl!()cm%oCUdTWAd6{z`hU$ZY?S&j3gIEA$G zd79r=p^Q7Idr=eENf>LXW5Llum!7|>ze6y5p1=0{sYDUP$1EPAJ`}kJ^i5#wj1!yW z@WREACpz%I*xV04=02sDAlMgI;!G&c-aVEhJ*l54ly^8)P(+IG3RiehofaIwFP$mc zx>+wC7ZzU`j7`|g#=T#BvZS2-+{2xylmGPbm}0VhUTtm({?k}9)4B06BNEiKkkv@% zm{-k1kKoDgc!_K^l%F^!o;dAxytGtsuhWVX-Rql>kLARIgz+u_hVttiALqC))y2Qg zYn7hf240?Ofdf|3zMN=oMox0XQHLtrQkEQ1r{oeATa@!ptNl)|Jt{+gmIBV4Rj7uo z-ERCEjDeflZ9-p2qRMk^-g&T0+X@y45`O4ce5H94d|LDLS()nQ*6PSJ4`S#+ycv}j zEevHNH=e)6RhR^LPLrm}uKiKSSpIk8c<&iDe6-au;nvgkgkcTK(YX0Y>?Y-aQuT)Z z_3A%O*YO-Zu%ehU;qNa3JjYy#w;v_t6=n%1MTK%_PBbuS*dbW>1T40=eAB&zm#>TPHH!@Tk2h#PTgqt6Kq>pKO4rE)mtq%JGFQlm(7 z{9Z7XdxJCKJcVY=`aUrjV{AK=Sx=2#tSfI6aZ(5-`ANT)jT{o04WL?p}Oj)f_`^(4_fKNG<@$kC3q}}}yzv#XPF4(w* zU+hxp8&bs=8y#WdmAx|lh7j^lVbzaS-fV*&&OZK}2)e56^(0a^dctN=Ofolv5;*)Y z!o(KdkYLETqRwQF0o8u%c?RB9xv3dEbzQBhs)%>;lF7xyH|#2;?Z)W3mqqnj%%*Kf z(hfTV(<6*A7u{p$3+tWeYf4fdt=<}u%RF(&CmuST?pXp6sy-`^$VPgi(JlwJ9S_of zTT69oCxb3S=Xlfct}nJzr8{DhZElIcu8h)Q=kiRvA!Aw4LfYjJwh+XSixvF8S;p&V z%kQR65p~K_m+36NTtm0PLMTr>*6U`a?J$78`*F>kAJi|+aPB1Icd^Dwv3L)w;(~q^ z^nCaDl(gv$0)=PU!F%4p%gl=J$~t?Yl+}{fzu6c@+GBd9~zc zGF1V0O_V!e&;Gy3d$jojm(#F$(O-J3o$PpllkwwsyqFbdL;Lh6@72G~o15Mgya{$( zo`a-oQl=PEfs(;nuPls{z8)H*oMuoqS_I9Az5RuQFP;l`B&4ZN>DITv#vrX1H>XlD zaNn%OQ^~q|wRL1#ng9lfFW;adl&?*jmY}5D??{@~^h?v9|2^K1?mRtR+3df>i}&b1 zK9m{mHZm(J8pG;{Rh9h4uGBY9UB-CRx#1O7*DZTZy`2($i_2c0*tg#qQoxg`gQrhe z%p#O|GW9MuQ1W5Wu&LFXq7T&kdw%!s(l)+2X+_H&=!cyxr~s~E)c+jr&HWm_{jV!H zv%fPAv*>U8)BN6b_W`F-hGe+Kd#k>WemO~U>&Rd$eRhTzq@U06Vrv0?U@Rz*Cab!X z`U%IK7v5LUcJ}g1^3nM>gpJCV;Jj#EyIg!)U)!XL1u9yY25#7B^7-oSG$tV|rz<-9 zbSI|l$_+RxS{EQ%P)sS3torQoDt7*+si$f>5=uB@6*0v@TinGKd`B1c#ni?q(LN7q ze9?}qFHwDc7^qAnrOZ~ ze7i8{V+wY}k{MqzQ1_>CG1%jLT1eNB3bV;A9qoarKCN4 zH_5;LRKZiJ_*cyzCK_iJ0Z_T4N$_SZhoVg6`PNQJR#tkSED)wygVEQ~af)WGAXi4ygVm@^R5Q^!oRny@dpB| zX*hbz@V`VYE#B_w#6@he`8i|1G_^+G6I)6nZM*`Q+v6X;YQT>YB3^}$C;epY5{2j6 z-wxQ(Y*N9BCDW$$TVWF>%Jw<{s7U5f0U#yFe)O6Aw6=PEF)asAJI-XmXO3D{pc z>@Uc{R_gbVe73`DN*q561oRP~{b%CMKz_blT3lLIt2f^H&B8;(>0iVM#d-1o^IOE@ zj}k8`ZuHi_+T(ztOUu6KjXSwiCPZbOShv|KYUdfYI-pPTo!+_(pCts&unVP(v@RdS z^FStkn*T0YyNIqBW^#Kh`Z>%4 zJ;qoH%Nm*EgR#l@P{H0)HEBSz)_kLospD3(+g1*J;cBF{-ywvEj1r(j1KRYT%9%MT z#EuR0^yN!hr@ml%F1X(uC*b36CbFY^`pAm zN91>X+Q^!%QExCH|9RowKbDS?O?;ErW~vh z**CfFpRbUPFB+S(eOG+gefNIy3VMVY>n4-=p5%GSQ)S040u z>Z~`pPoVsIT7xQw867>{(!Hlv00ZxdYV#mRf-4}rSnGGuoCwVKet9~lYUx3Zyd$^! z_tOiW3pCtw=syrcq>o$rIuZWAef@_sBA5#=e(}2~y?*ECOV%53^mL5w*W7cC F`9JK@t``6R delta 11770 zcmZX)cQBk^^gpim5?diQd+u z*RTjy|9XEu-aqm56?mbzKKdch&k&!*uF;v6D!%Gys&BTj` z$BW0yi>JuTYs{;7^SSXFhb6iQQyKH(8UL>@EG)51gg}uuamItFyGbuTNf)0Rhy_+2 zrT17dKb1}0uH&;JY2fgi{rk&$@sE&Ca|HE+FT@g3!+QK9*Vj3jN6yo!4lR&RuPoZ2 z&05`(pGx;MQ#lj^#=sxCKhm4=j1G$s3q^vs*dPCop}<@CEais+4ME`{o96Cj8`@KP zkGEI-(m>kFtDpGAofesGUe8LIUZ%jJ4^7;|pe!2j>kD>er1KZ=7%244S#`)y{HS@m zbLHmRNRzac@yl|AGDf-0wXt5hO4(^43|g*zpDjTiyEDPj>bkeW{ZjQa z=Kg!so2z`V1FpG6`hJqUE6MD+J3;OC#K_g^;v2vnW8O4p6R3q6{wu;yGfUHDBO0vb zU_5SjBv!sbp#?B_Ivp}Le07;SXHG2IzI-|TLT4S9L!3;l`8Re>dT_d`xmFx@#@GPt zto`hWe1eb|ETu1FYyZ;PrLJSQirxFSxXpI%WRUV8O!t&6ecJ%f!bMJU=2f+b_+*-#vff)b6X0#3Si?@jEkag3+vY53li z+~%#``<|=dQMAZ7t;-++zR= zH>9ejne0AZlR%(+KE|&I`~0)w-LFXx9BT@4_a$y))RgeFaY~f%VkR~aIg0jI7}(f~ z)hZ=|&^qsG6b?Z{3a!)!tKRG?n3!5MzG9iUCqFQdVp0HK>dcZJ0$L5=(zuB6 z2Mht&FOqti_FnX@&+32hiZoX~eZ{(_GHH3Io?>LF?FIYW?+n6bnT(;(t*ucQwR>K~`ipPOIlo*yC4&N)^D~A* z1F4O%3FhzdBMU1PceRX_O#5$jZS#Hpk!O*d&)PNNwECjb)kg@&G(b{_u&KJw-ZaMT zI@alMsVC~HZ#ZN0Ra?P_JE}ULhK?(qBr3osObF+n0vp!;4^O_mty6tco6}r??$DH2xt>0-??XOK>jA1MAVIo_vNMtM3+X ziQDGJP+(N1Q5l?o$UZqCqq`)}5XoP{vtkF@a}Fi#!VUkzJlidI zh6r|9GRxm)g=GT_4Y6$F{O#4b-{zleWarrA*WqWsr)w<(ncPSqlW=jfs zoxiUkh-1F6lc8_WOh-MBZwljHx_Z>UZDS=03;sv<_RGQ}+!FJfKc}i=%r-xD!nq$Y z3Zh}ZkO)z&?oTQqEXx4vnv@MHE$<$J`$oudH~(aGo#)V9;d?|$6N7A((8qM|=nQqb4IH0ZEHl>Ye-+{g`r zPbCpDb3_tO#;8J4Xu(XR_dcOO17C;LFpCgO<$#0Vb|DYglx%Ihr>yzGg3w|dKTQTC{k!XD3~9PPaEMAEmeM+l$3q?c=?hI9?F@m`zb^>L8*nxh=0&a6E;*`9igt|2pL^U< z$d`rh)y81bZ&IpGsWwaXziVi2xKpQhhhg+PTB z$|l;N_$}s0<4go-m3Hz+=X{$3G_ieqQZ(?{`s(uRGkwvqXUuvDa|TKA zuKR$f`v$msb(-(T&HUBuaY; z1Chvas;mI_+m-^+;zmqV7%%Qd-CS8cZ2!5{KQ3cbg_boqs3FWq(~67>3U1`Bj<6MB zgGa^xn>J#^<;HT1K943+J}(+gPhTw}2E=x|XX|7QWyg#{=LVanyqMZak;PqUG_9&e zSZC%pO=mpP3NR<<)bGsg-M-!7spOOVUK)9ex6rxXkVvNlQe43ZXDyygkxYJ#Io4-bre(bN%Tvu^d^LbhkFJ%gi}% z5E*Rk9p8%$*vl7RC;r5VKrgaNjV-k+@EJ99TU}CRKS^A{M`h^sSn$HONDF9o4+2TL zLTQ1{<^7no$SGpTCNJCO^Y7Q1i{Fy&wT>*aqgPoO)s&dw9_ojbmpDhFt2zZu7oQ+H z2{q`01@6v}$$c*3Fb ziG*?}lO*$fPSs%Ri+?usP}^mYG-;h1RyQ=PP(Kyd8N?-BIZlfqki|LUqMGaNMpi0+ zAKr&ZJ+YSbFBl)uT~j3^@Wbw|-cHh!T61rR94Ry9F9Uo2qc}$XwUk&5TpCC$TauYt z66kf|M>jF=0psJ%EW84^T~_F46YO$dH3@|L$t`kgi@4vy)+Cpu;JYLzt7zbD^&PBh zx(^}vcSSnMN&oJ=)7U0^yfnj_v^f>5Nyi+uty|Z7OtM^p>FOoJtgqI-Mj+jP#g=-I zeR(rT5$qBzrGsBm{ouII`H!W47h1$4M(bF^1UoGah*xr&Tw@8jf|ho`Nldki18+s( z*w@Ya5Jn!Ms3Yak9*H?|o*&?3$!_Wk=+f2(p;l7>_310$qxY;&Ll=bf`I(NMbJAXM zv`{-%%E-XD%<9fr{FE8^z7Xuuz37>^Jwc$f@ki(9ceZ1qV`aCWkKR)RlT0sCe}VkG zc$Lzk2N)AtvxoC`bTh(X-sGV4dG36Yh(>I{EgE8*-;0Boj-g;1&fi%W*~7U`Bx`T~ z8=ukQMj=7X{}3m}_m{DbVQD3c6h;+&7Oljiayg&Z3tp4B5Q)hYrSput;k zId}_3l#sZPP~gUWjt;okgFU*~F{OhT#$*6tBOQ8@flB(9{@+MJSkI@_a&)K4zL_uD*4HKWL!bTKKRQ;bV_U*Jo94g5j?cLdV=?$KD?O9PQ_m=HSQ61u zX#|aI(9w|{qgs)D)Ll-$kN)HFe@7-9$VQ)pLC+Me$#JK% z@(dZe1ODs_r&sCHGv>VK0RVn5j|73KR$2vpfWM&1gMU@zD^9mGtWf7aZezJypHN?U zcepBD`>NR+DY|pgqYcoyl*JXMDZl1(qZEDolsh;6T@7w(tP@>Gi>vY1E2ml6x+D_f zd`Ucm_Q%IN($IP=3rd{A(g>)%AdcM&ADFVTnN#8em0@0wsN@`_081j4Vg#CJyN&|x zhoRXc!!6Isv^B}MoUDz<*=%C$&s>Wrh-`3&@|rZDmI(m43|G%pRAhxL*W^VWyR4U1#QOABgv3M42Z-UJ=&(El zkb4%{efyu7)a|8FCD>0IQ^FFA$wVI98hYnUFfi?`SAkZM+xn7>#)1# zYbr~zaOYK)YFP6SXGW*N$_-E&wj4n;-Gp%BeV}79@g(j|I@POrQz-LlV#vZWs?E00 z`-igc>{7&`so{Y&pJy9=VupnYT3!EhqfrR^j2P2ML)D|xWRgtvGyCe-)xZ273i?;j zH`r(i0dk+dtp~2)L*o;!rr4k0U%V{}F}bLUaw_-a=-5QD$(#@J%6i3c{x6rPmMxbU)}!f&U#kEB4T`gT2fp;%yA#Z5>&RNdHu2YSK#p{ z?fYLu3)n~1iwMOvwtq+Q1r6wl<>a)LK#Nh5+2u+*ksPJ(SGo-Le-l6k71x8eHoJ+_& zpy8dkX)u^h2w!0PiSSFCyFLAGmyAul_x|7Z>F*_l77sc0%S2{@*Zb`<8W#Its2+;# zKm`9n?mAYs-D90K2M_6ftDXqk`9{~>f2*0H^u@5!;CFI)(h92Vg~Xow-|X7GNpUxo z#j=}P%Xlz&pNz6vM+L#D-h?H{35P>qne6Z-r@pan?GMhJ5wfgie+86iMDVb# zfgk3`1fK$WA)zw<0f>ALi#!xptx`9V0?VRtFJ9(W-K`IK{v;D-?j#Z8XNI(^>k70` z4o1j4S-&gyEv;xOxaeb{ya^4Cu`tofy=sa~$a52bzeD@21)1s}o-iVf&M9y9Ja(ei zoc7*ocP7v*dY$b_qc9QAo5UvwUb|9On)FVD#vLF{dk>cf(zNZ9_m*crg1J+MYMMJF zfFEwVycYvcKc6few>aSzO-#P;Au4j`ua_8dgF|^rlPe=0-xHS5e5)EGtx+aa>U0PB z*=+>yiMu{{MGJraJM0r``I0u6*Oj{xM8$tdPZ)aA|LiVKxn|yo7XG@3@}Hgb;XIxU?sGh0y7)X;#PPBLHfKoL9189aS@IQ22Bs*iBox}Wbf{h{BTLQPt7 z>?BJ)i%r7rM`XBqb<;@U+yGU=JHAU2*BrV{+FcIUdwfEgCsJY z)*TI9w~PA}4`a|Io-En-L*7gMLXEmbXGHY{I)k?yLG=J659MwxmY9 z=;@9^o1}4_pP}8Pkmp8W!1(&FtnJt(0}uSGF+Fsr{#RZcswCEDEl=ZJk_Y~RoDu5$ z{^>(bY73;PpwG|hSV}tu>5j57E~6G7Y!AQJ&$4$iB{O9>g+bB}bQx{pjD*T$LV`M!i)6Ov z62&tq&FawW-I79D0*H8VmCE<8sK8n=kfZ`_cL>Hu&JzZ9%UnNuWGN=P!w6a_F4;D+ zx${ZI}JF-hcLD$vWWr!h{ySB1aNUnxh|7`d;89_p~{l zD07?)O5K#QveT=}oF5_@4l%Xoe6&WstUzBF_UoMD9T+Iwnq1yWg?-FavH2^@*y{Nm z?4|dDAOMTy60}x!S2@UuBItBf*84=go4xlQw0DNPf%Z_lNAVN7puv;@socvuuN?~Y z)_Xsy5-*r&%Hc$S*#@djhCK%3I5tFy*>Z9%Vo&I0G_Ul)v~pyCa#MU9hKL3Oc@>@8Ww?G07*{^FAhCNZKrRX*7w{khpUJFy?eZo)eN^y;GDO=5PG94UYh0tzM3W zP{sz+HSQ0`5kVA&N%{!gK9!JR^Alv0&mXtP*ZtamSzZ_|+F4FnwI>*c*oJ3;y1Gg{ zMhdV$OPl~VP0cCfQFVfyzjGEiEy&N@(-(DF)|4SlLq_7EK4Y^g85~)`IY8(ZEJ6#^ zXjKer+wkEcO%(FNpQnBG%-HwFT+GSzNZ&;`p)4y>ZeVRC;9+#n%*A?J)A9=LYQhoX zQ62j)5a90Eqo!RuJDuzgeRS<_hFWK__{|fM*weRvS@s+(JLl-**zo)NAWX1w!h|wA zxj;d0_b;1)3A)=6joxek*_U@e08DJS7X?KC-vrYi6((eYX_spMTQ30)3onP%SMeL` zX%EGYuaF9MT@=BeV{~Nt1Y@mi$7#%w61~wzzx~w6-Zi!vF?4>oS+#P?CdM2URh;P< z67PmY2II8s-AgTEO3dsAt2NQ47Vx>M8ak$?hllYt{){<)#;; zeqVG=?G@ada@FR+Ttp7=TgHKEv8*a*r-&UMySj6~!21II)n#zQz@~`A-2Zrj3Jh%u z_(BnsGTk`-Bxd*W$DGH6?0Zi=l&)f61~YP*(^!w0 zo!*kUp)wk~0^@YW_P|yS!SP@2=6NzRAQkzDUEMOCDs@fH_ec{UZGPH92v2lpZk|j1 z~mw*4h6!i#XT*CjQkrOyR}-ua!CWkF?^4Xuzk4{>@=Unj?R>kFDNy>0d9zxxJmC=OpiKd`)q|iyf;9*Ih zk>f)775hS8MOu|?)i=chDsVIrO4iC&K3DaIBEF^tS#EuPpGMmrNB`wxWb!SD+oPQg zL5Xb=0*@#x(YumAGSY;w55n8u(W8usibPMfv2GD}H$DOcS?|I^X{VFgl{PYk-S$P@ zB|;)A$!Of#;Gh`YIS-RR6C~?hM<}h~luvnMvb!iHUd2w8_nbSa2r(q%ok}Pas+88p zeBY>xYD|UzO_M#?lt!pD$`k8R%ujziL_H}fLUly}3!k_oX2iXuZFP-vwEkEI1XwJu zS>eHywt?VBk~kl?iD$zt8$cb*5;*cux0Rg##U5$wMVCeQ-kozOBQVv zYwyTgbpffLfVX1Dl#i2&fMK?;)F$jnQiDN`1Qpw($Rsf&hp}D7M#}(x#bgYKe;{tG z{yZ_U@Z3m~BdIvfMw=kp3_;1QED3{_z`l`!K(7@QFmd7^Ibx1#&U+=bBX9Kf4|m0u zi0@g{!l|meU#%^cx7BO2nF?!%|MGeSwOvDB&m<^=P487f!}c1Z6~#zXTG8jK1T;OV z{rfuHE4t~Q+ir0e_n{>OZk4JYIRJqJ0wuDxuU@w<1=j@-1RqTOi3q8uIwR2ER(dv% z_kmRR*~K=rsbw{Z|2#Q`?v-Ub)x}s<{=976Yiw$%eWrk#Nn0UEcZmwq`dw{Fo^&@h zPU5X=F)i+)pU|P_=wqO2%)GN+2icRhScby*pCY-SO_IkH<_=wYA7lC? zK0MqYqW%SU;-}C;bWqxuBrNM0wzKGXI@J0j7akrpL`(IFA)k_(?~yyRC~fCyW0=#l zWNJg+uI(eLRJ;oHnp>z@AD2H5P=Si441%n%$#NwD*qxG`o|P^;04hPVwZ&UH!eM_I zu1$)OK8mqwF^zG6o?tgKKRLFusk5ws)_6FoPiUA*=+ky6CZoB`ks6F{C`=@ReOCMO zHkcpoE=~-~x=by$`99ssscCV$daemi!GGPO zODBuRwGN5ONHPIjhJUdH3*;0$bd)>3tlRu??)@?h6ej26+Iw3#1ctF#C9KsWwTY}V z?LVHae;y*osF-8_)zI9rG*wKI9zJfBzbh$51;S*5cVcA-T)0ag~_%=TAwUwVMKzAR8Zp;+%`;MZJK7@Ll9N8yzFbgxcso9B#8IN%2T)f1*W@UgMr762sS10 z$L90mZa~*#ZSGHqlSkeDw2F946AgFVKeEu(e5N$$1A9s|cF7wCM(@-=#?CQT0O5MP zg&$Livb#JO#UF%wTiIb5CK{yBwT~m-9o@tcz#Dl22WBiJn0Fe2YR&Bxz8$5*_59KI z-(oLTW@!g2)JfDfn$Env7*<1^QdJ1D)2(mK3#G6_(x+X?Ab+=V77^`-xL6019mV*k z%l3E4G;B8;Nh|!qhKNJcsDDrb@lDrcY5&P19p6SCygTy6K9u6}d*-ih&#UN1E6dFH zd0(wVcOT-&;kMs4_E+<3KQx(Xhvjqh{aP6JL z?G*l$wvW9vBYjEjH)JL$xKrdc5pD3+_AC|`%emj60-<=pjCHK00&Gh8RpKhjIfBP& zKIa&dw`W*;th}Rd+qa_g+junT6W1%Nuny8HY^DA|T!Z9tcidip zEgZK&P+;#H>$&PHaS)qXaPzi$b&_UMc!EI&$UKtKkT!MkChVPiDx(ZrhxuN~#Vl-P zru`Y`gerg4qbL*r3b@59^Uhrs)<_ckt+CqseY9nVzU>r^pHy%Pr~l@NvZ>{;PGez| z3qff66*}(CtC{-7Hv^j~<%4PW6k%nD$1&j10Q0<0`CS+NYCDVloRRj(KE4*Nz(+E^ zeEeoEqF*?WL;ecAtUm_0FS6#uzT;O2W%XgmOX*;r%Y&DIeRADaI_t&*k?x_{4#;Sz z2_h+HWz*VxlIRwj_Gd=kIy>)Z8J;Q19K4I%uK28aNrY3ZM)K+)SO0ZD z>{awSjj*MA??iMTv5!|)bVC=Y_K+e8qer9$EyYBkV)%h zDk5~7ina-7n;L=k5-U*u7CUx*9v2?Xoq`Qla8X69bLYt6dY(5gJ|63hd);BB82a?0 zt$16ygy{W!nhP*@u1Cz`UdX+6<=@H;hjb9w()HzIU$sMRF55;P)Jfor8DJ^NBhfQ; zu1WH9AL9$z>ReP3@AmA2d7EUpzgId@znC7k`rqQtIepToyfoVQP1x@hBn%natmdpsYA$3HQ@ zicTQ56Tw~}mT4$AGV6alZMOivzc<8^kM$l=zAas?i50?!osY_7o3AP*&-IpaxX9Tq zYZEEGN~!=Omp~hiaeH9_SIc4Wg^+xmfY-GtyxSr*MxQsn_V?@(pGzJRZ_mO8Ma$P5 z;9t7x8LN7d{+t?FV$^xlvV(wfv*xSIP5f+A|8}lZ#5mO9tLWRmg#qY2e2c+IXVnjd zn5xu0i!@1uIN6ET{P(#FoCY3AJwj0hPLTsV5aVReP@z z1!YcUSLEv<_pviVK<`z$piGy)T_9q;hozG9&x=+>j*363n($fCq@pjOvXX?{q@1IW zi7&SEo6hlcLui@?|3Jg^N!xu#p{{SM#M#1UnIi68>6+X(C*z-wt6$j|z~)hYSl&g& zz_fJz>(kKnz=;3ip&+`?Vy-D5*x^9!x_5;_$^7O~FCEZCSp}VQOrq|Rf2>gLzi!I3 z@{UgRGl8CMSiI%e-vHx~ks8W=x5q~rgw*ojhC}6zYC@G=hmwiE3cUyUmPXKJ;B;c2 zT~K-*&dYaD*!(LveWOK^d6iKre8qJRJNh4~|M3QcM=NgU%~EN@olZaI7^$+eqgDW7 zOwEejfR{qFRO8;rfbrhho1T=>1mcNWk^U_~nFj$momp+kOvrj4BQq+PQ{$ig!iH|W zY-bCwrLW>}U(XO_QR{e9wRn6^UzVz(CrGg+XgvHU;DOz+Zn_V1oPy|Ql%fA`-Rp~U)7|7ranq;BF1Ktk>PWZ7nU0+I;I%)cYV{hXEmxiePC^`9d4IOSFm z6+*V;X$P39Pgh-J=rmv#FjPYLS8!Wr@yW+E} zM1LD|N_$N&#SL%KCqq=(XY)bg^Gl;7L$lx3cDCkGv-GZPm*#&P9!Rf)yQgu1GgopX z7tRlH>4esWnq#)|8Z=o`y5BP1nsjTiT0lJJz=xz+r0hwdv_(E!4j|Ev@s42PZjGMK7U-s zMraMC*;wosi(IRQ@E7G29lt-b^$22ySyd!+nX7n9`x+yNw7UIjhHO1pD6*Ai*6y}2 z{u$p+dW(;Cd%P5heJ;#-F{k!f4#;2^bRx2b6)^|d^HDtk97P{zs)G@cTYo$rHZof) zL%2rGNV5ZrL@v8OQRW867;F~R%zt95hwXkfzk^$HrQT1s(Ep%0H^QVvnC)N0Ok#aq zmQ@|oh42g1MXY~K&Wm(51F0j@lP=8L?U}W;0*XWkE;1v+@z6_ypTryj%}?fZW$7Vz zYpcSK6%5P(7Q3HT0x%Abx&8lIU=6$mO!I7Q>{+Wa0@+14 zAby$fkI*(n%cXjgVelj^GNMP;-p||5w^ # 1 linkEvents(changeEvent = calls, nodes = actors) # 2 @@ -34,42 +34,42 @@ mod00Choice <- estimate( summary(mod00Choice) -## ----actors---------------------------------------------------------------------------------------------------------------- +## ----actors---------------------------------------------------------------------------------------------------------- class(actors) head(actors) -## ----define-actors--------------------------------------------------------------------------------------------------------- +## ----define-actors--------------------------------------------------------------------------------------------------- actors <- defineNodes(actors) actors -## ----calls-events---------------------------------------------------------------------------------------------------------- +## ----calls-events---------------------------------------------------------------------------------------------------- head(calls) -## ----hlp1, eval=FALSE------------------------------------------------------------------------------------------------------ +## ----hlp1, eval=FALSE------------------------------------------------------------------------------------------------ ## ?defineNetwork -## ----call-net-------------------------------------------------------------------------------------------------------------- +## ----call-net-------------------------------------------------------------------------------------------------------- callNetwork <- defineNetwork(nodes = actors, directed = TRUE) -## ----strNet---------------------------------------------------------------------------------------------------------------- +## ----strNet---------------------------------------------------------------------------------------------------------- callNetwork -## ----hlp2, eval=FALSE------------------------------------------------------------------------------------------------------ +## ----hlp2, eval=FALSE------------------------------------------------------------------------------------------------ ## ?linkEvents -## ----link-call-net--------------------------------------------------------------------------------------------------------- +## ----link-call-net--------------------------------------------------------------------------------------------------- callNetwork <- linkEvents(x = callNetwork, changeEvent = calls, nodes = actors) callNetwork -## ----frdshp-net------------------------------------------------------------------------------------------------------------ +## ----frdshp-net------------------------------------------------------------------------------------------------------ head(friendship) friendshipNetwork <- defineNetwork(nodes = actors, directed = TRUE) friendshipNetwork <- linkEvents( @@ -80,11 +80,11 @@ friendshipNetwork <- linkEvents( friendshipNetwork -## ----hlp3, eval=FALSE------------------------------------------------------------------------------------------------------ +## ----hlp3, eval=FALSE------------------------------------------------------------------------------------------------ ## ?defineDependentEvents -## ----call-dep-events------------------------------------------------------------------------------------------------------- +## ----call-dep-events------------------------------------------------------------------------------------------------- callsDependent <- defineDependentEvents( events = calls, nodes = actors, defaultNetwork = callNetwork @@ -92,7 +92,7 @@ callsDependent <- defineDependentEvents( callsDependent -## ----plot-teaching1, message=FALSE, warning=FALSE-------------------------------------------------------------------------- +## ----plot-teaching1, message=FALSE, warning=FALSE-------------------------------------------------------------------- library(ggraph) library(migraph) # The network at the beginning @@ -119,15 +119,15 @@ autographr(callNetworkEnd, labels = FALSE, layout = "fr") + table(as.matrix(callNetwork, time = max(calls$time) + 1)) -## ----effects, eval=FALSE--------------------------------------------------------------------------------------------------- +## ----effects, eval=FALSE--------------------------------------------------------------------------------------------- ## vignette("goldfishEffects") -## ----simple-formula-------------------------------------------------------------------------------------------------------- +## ----simple-formula-------------------------------------------------------------------------------------------------- simpleFormulaChoice <- callsDependent ~ tie(friendshipNetwork) -## ----simple-choice--------------------------------------------------------------------------------------------------------- +## ----simple-choice--------------------------------------------------------------------------------------------------- mod01Choice <- estimate( simpleFormulaChoice, model = "DyNAM", subModel = "choice" @@ -135,7 +135,7 @@ mod01Choice <- estimate( summary(mod01Choice) -## ----complex-choice-------------------------------------------------------------------------------------------------------- +## ----complex-choice-------------------------------------------------------------------------------------------------- complexFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + tie(friendshipNetwork) + recip(friendshipNetwork) + @@ -148,7 +148,7 @@ mod02Choice <- estimate( summary(mod02Choice) -## ----simple-rate----------------------------------------------------------------------------------------------------------- +## ----simple-rate----------------------------------------------------------------------------------------------------- simpleFormulaRate <- callsDependent ~ indeg(friendshipNetwork) mod01Rate <- estimate( simpleFormulaRate, @@ -156,7 +156,7 @@ mod01Rate <- estimate( ) -## ----estimate-init--------------------------------------------------------------------------------------------------------- +## ----estimate-init--------------------------------------------------------------------------------------------------- mod01Rate <- estimate( simpleFormulaRate, model = "DyNAM", subModel = "rate", @@ -165,7 +165,7 @@ mod01Rate <- estimate( summary(mod01Rate) -## ----complex-rate---------------------------------------------------------------------------------------------------------- +## ----complex-rate---------------------------------------------------------------------------------------------------- complexFormulaRate <- callsDependent ~ indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -174,7 +174,7 @@ mod02Rate <- estimate(complexFormulaRate, model = "DyNAM", subModel = "rate") summary(mod02Rate) -## ----intcpt-rate----------------------------------------------------------------------------------------------------------- +## ----intcpt-rate----------------------------------------------------------------------------------------------------- interceptFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -183,7 +183,7 @@ mod03Rate <- estimate(interceptFormulaRate, model = "DyNAM", subModel = "rate") summary(mod03Rate) -## ----waiting-time---------------------------------------------------------------------------------------------------------- +## ----waiting-time---------------------------------------------------------------------------------------------------- mod03RateCoef <- coef(mod03Rate) 1 / exp(mod03RateCoef[["Intercept"]]) / 3600 # or days: @@ -204,7 +204,7 @@ mod03RateCoef <- coef(mod03Rate) ) / 3600 -## ----windows-rate---------------------------------------------------------------------------------------------------------- +## ----windows-rate---------------------------------------------------------------------------------------------------- windowFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(callNetwork, window = 300) + @@ -215,7 +215,7 @@ mod04Rate <- estimate(windowFormulaRate, model = "DyNAM", subModel = "rate") summary(mod04Rate) -## ----windows-choice-------------------------------------------------------------------------------------------------------- +## ----windows-choice-------------------------------------------------------------------------------------------------- windowFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + inertia(callNetwork, window = 300) + @@ -228,7 +228,7 @@ mod03Choice <- estimate(windowFormulaChoice, summary(mod03Choice) -## ----aic------------------------------------------------------------------------------------------------------------------- +## ----aic------------------------------------------------------------------------------------------------------------- # Compare different specifications of the subModel = "choice" AIC(mod02Choice, mod03Choice) @@ -236,7 +236,7 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) -## ----rem------------------------------------------------------------------------------------------------------------------- +## ----rem------------------------------------------------------------------------------------------------------------- allFormulaREM <- callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + inertia(callNetwork, window = 300) + @@ -245,14 +245,14 @@ allFormulaREM <- same(actors$gradeType) + same(actors$floor) -## ----rem-gather, eval=FALSE------------------------------------------------------------------------------------------------ +## ----rem-gather, eval=FALSE------------------------------------------------------------------------------------------ ## mod01REM <- estimate( ## allFormulaREM, model = "REM", ## estimationInit = list(initialDamping = 40, engine = "default_c") ## ) -## ----rem-c----------------------------------------------------------------------------------------------------------------- +## ----rem-c----------------------------------------------------------------------------------------------------------- mod01REM <- estimate( allFormulaREM, model = "REM", estimationInit = list(engine = "gather_compute") diff --git a/vignettes/teaching1.Rmd b/vignettes/teaching1.Rmd index acffe17..d8a1da7 100644 --- a/vignettes/teaching1.Rmd +++ b/vignettes/teaching1.Rmd @@ -32,6 +32,7 @@ a couple of ERGM papers by callings its documentation: ```r library(goldfish) +#> Warning: package 'goldfish' was built under R version 4.3.2 data("Social_Evolution") # ?Social_Evolution head(calls) @@ -638,18 +639,18 @@ summary(mod03Rate) #> #> Coefficients : #> Estimate Std. Error z-value Pr(>|z|) -#> Intercept -14.380373 0.095669 -150.3135 < 2.2e-16 *** -#> indeg 0.695555 0.063115 11.0204 < 2.2e-16 *** -#> outdeg 0.234633 0.030153 7.7814 7.105e-15 *** -#> indeg 0.054792 0.015049 3.6409 0.0002716 *** +#> Intercept -14.335641 0.094257 -152.0912 < 2.2e-16 *** +#> indeg 0.568475 0.067244 8.4540 < 2.2e-16 *** +#> outdeg 0.314266 0.030898 10.1712 < 2.2e-16 *** +#> indeg 0.047770 0.015148 3.1535 0.001613 ** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> #> Converged with max abs. score of 0 -#> Log-Likelihood: -6003.1 -#> AIC: 12014 -#> AICc: 12014 -#> BIC: 12031 +#> Log-Likelihood: -5984.3 +#> AIC: 11977 +#> AICc: 11977 +#> BIC: 11993 #> model: "DyNAM" subModel: "rate" ``` @@ -665,10 +666,10 @@ The baseline waiting time between two events in hours: ```r mod03RateCoef <- coef(mod03Rate) 1 / exp(mod03RateCoef[["Intercept"]]) / 3600 -#> [1] 488.6682 +#> [1] 467.291 # or days: 1 / exp(mod03RateCoef[["Intercept"]]) / 86400 -#> [1] 20.36118 +#> [1] 19.47046 # But what if it is not just a random call? # Expected waiting time of those who have five outgoing call ties @@ -676,7 +677,7 @@ mod03RateCoef <- coef(mod03Rate) 1 / exp( mod03RateCoef[["Intercept"]] + mod03RateCoef[["outdeg"]] * 5 ) / 3600 -#> [1] 151.1872 +#> [1] 97.08854 # Expected waiting time of those who have five outgoing and incoming call ties # (five different actors) 1 / exp( @@ -684,7 +685,7 @@ mod03RateCoef <- coef(mod03Rate) mod03RateCoef[["outdeg"]] * 5 + mod03RateCoef[["indeg"]] * 5 ) / 3600 -#> [1] 4.66806 +#> [1] 5.658994 ``` ### Windows @@ -722,21 +723,21 @@ summary(mod04Rate) #> indeg friendshipNetwork #> #> Coefficients : -#> Estimate Std. Error z-value Pr(>|z|) -#> Intercept -14.530750 0.101676 -142.9125 < 2.2e-16 *** -#> indeg 0.245045 0.070682 3.4669 0.0005266 *** -#> outdeg 0.364576 0.032556 11.1985 < 2.2e-16 *** -#> indeg 5.295709 0.139463 37.9722 < 2.2e-16 *** -#> outdeg -0.767499 0.116642 -6.5800 4.706e-11 *** -#> indeg 0.083772 0.015289 5.4794 4.268e-08 *** +#> Estimate Std. Error z-value Pr(>|z|) +#> Intercept -14.1665102 0.0880817 -160.8337 < 2.2e-16 *** +#> indeg 0.1910828 0.0781305 2.4457 0.01446 * +#> outdeg 0.5283974 0.0332725 15.8809 < 2.2e-16 *** +#> indeg 3.1942574 0.4135005 7.7249 1.11e-14 *** +#> outdeg 0.1404188 0.2860436 0.4909 0.62350 +#> indeg 0.0098856 0.0154430 0.6401 0.52209 #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> -#> Converged with max abs. score of 1e-05 -#> Log-Likelihood: -5475.9 -#> AIC: 10964 -#> AICc: 10964 -#> BIC: 10992 +#> Converged with max abs. score of 0.00081 +#> Log-Likelihood: -5854.6 +#> AIC: 11721 +#> AICc: 11721 +#> BIC: 11750 #> model: "DyNAM" subModel: "rate" ``` @@ -813,8 +814,8 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) #> Warning in AIC.default(mod03Rate, mod04Rate): models are not all fitted to the same number of observations #> df AIC -#> mod03Rate 4 12014.20 -#> mod04Rate 6 10963.75 +#> mod03Rate 4 11976.58 +#> mod04Rate 6 11721.24 ``` ### REM with `goldfish` diff --git a/vignettes/teaching2.R b/vignettes/teaching2.R index 7099fb6..5e14d0b 100644 --- a/vignettes/teaching2.R +++ b/vignettes/teaching2.R @@ -1,76 +1,76 @@ -## ----setup, message=FALSE-------------------------------------------------------------------------------------------------- +## ----setup, message=FALSE-------------------------------------------------------------------------------------------- library(goldfish) -## ----load-data------------------------------------------------------------------------------------------------------------- +## ----load-data------------------------------------------------------------------------------------------------------- data("Fisheries_Treaties_6070") # ?Fisheries_Treaties_6070 -## ----examine-states-------------------------------------------------------------------------------------------------------- +## ----examine-states-------------------------------------------------------------------------------------------------- tail(states) class(states) -## ----defineNodes----------------------------------------------------------------------------------------------------------- +## ----defineNodes----------------------------------------------------------------------------------------------------- states <- defineNodes(states) head(states) class(states) -## ----examine-node-changes-------------------------------------------------------------------------------------------------- +## ----examine-node-changes-------------------------------------------------------------------------------------------- head(sovchanges) head(regchanges) head(gdpchanges) -## ----present--------------------------------------------------------------------------------------------------------------- +## ----present--------------------------------------------------------------------------------------------------------- head(states$present) # or states[,2] -## ----link-present---------------------------------------------------------------------------------------------------------- +## ----link-present---------------------------------------------------------------------------------------------------- states <- linkEvents(states, sovchanges, attribute = "present") # If you call the object now, what happens? states -## ----states---------------------------------------------------------------------------------------------------------------- +## ----states---------------------------------------------------------------------------------------------------------- str(states) -## ----link-states-vars------------------------------------------------------------------------------------------------------ +## ----link-states-vars------------------------------------------------------------------------------------------------ states <- linkEvents(states, regchanges, attribute = "regime") |> linkEvents(gdpchanges, attribute = "gdp") str(states) -## ----examine-bilat-mat----------------------------------------------------------------------------------------------------- +## ----examine-bilat-mat----------------------------------------------------------------------------------------------- bilatnet[1:12, 1:12] # head(bilatnet, n = c(12, 12)) -## ----define-bilat-net------------------------------------------------------------------------------------------------------ +## ----define-bilat-net------------------------------------------------------------------------------------------------ bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) -## ----examine-bilat-net----------------------------------------------------------------------------------------------------- +## ----examine-bilat-net----------------------------------------------------------------------------------------------- class(bilatnet) str(bilatnet) bilatnet -## ----link-bilat-net-------------------------------------------------------------------------------------------------------- +## ----link-bilat-net-------------------------------------------------------------------------------------------------- bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) bilatnet -## ----contig-net------------------------------------------------------------------------------------------------------------ +## ----contig-net------------------------------------------------------------------------------------------------------ contignet <- defineNetwork(contignet, nodes = states, directed = FALSE) |> linkEvents(contigchanges, nodes = states) class(contignet) contignet -## ----define-dep-events----------------------------------------------------------------------------------------------------- +## ----define-dep-events----------------------------------------------------------------------------------------------- createBilat <- defineDependentEvents( events = bilatchanges[bilatchanges$increment == 1,], nodes = states, @@ -78,17 +78,17 @@ createBilat <- defineDependentEvents( ) -## ----examine-dep-events---------------------------------------------------------------------------------------------------- +## ----examine-dep-events---------------------------------------------------------------------------------------------- class(createBilat) createBilat -## ----hlp, eval = FALSE----------------------------------------------------------------------------------------------------- +## ----hlp, eval = FALSE----------------------------------------------------------------------------------------------- ## ?as.data.frame.nodes.goldfish ## ?as.matrix.network.goldfish -## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'------------------------------------------------------ +## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'------------------------------------------------ library(igraph) library(manynet) @@ -123,11 +123,11 @@ endNet <- delete_nodes(endNet, !isStateActive) autographs(list(startNet, endNet), layout = "fr") -## ----hlp-effects, eval=FALSE----------------------------------------------------------------------------------------------- +## ----hlp-effects, eval=FALSE----------------------------------------------------------------------------------------- ## vignette("goldfishEffects") -## ----estimate-init--------------------------------------------------------------------------------------------------------- +## ----estimate-init--------------------------------------------------------------------------------------------------- formula1 <- createBilat ~ inertia(bilatnet) + indeg(bilatnet, ignoreRep = TRUE) + trans(bilatnet, ignoreRep = TRUE) + @@ -150,7 +150,7 @@ system.time( ) -## ----estimate-rerun-------------------------------------------------------------------------------------------------------- +## ----estimate-rerun-------------------------------------------------------------------------------------------------- estPrefs <- list( returnIntervalLogL = TRUE, initialDamping = 40, @@ -166,7 +166,7 @@ partnerModel <- estimate( summary(partnerModel) -## ----estimate-c------------------------------------------------------------------------------------------------------------ +## ----estimate-c------------------------------------------------------------------------------------------------------ formula2 <- createBilat ~ inertia(bilatnet, weighted = TRUE) + indeg(bilatnet) + trans(bilatnet) + @@ -189,7 +189,7 @@ system.time( ) -## ----broom, message=FALSE-------------------------------------------------------------------------------------------------- +## ----broom, message=FALSE-------------------------------------------------------------------------------------------- library(broom) library(pixiedust) dust(tidy(tieModel, conf.int = TRUE)) |> @@ -197,11 +197,11 @@ dust(tidy(tieModel, conf.int = TRUE)) |> sprinkle(col = 5, fn = quote(pvalString(value))) -## ----glance---------------------------------------------------------------------------------------------------------------- +## ----glance---------------------------------------------------------------------------------------------------------- glance(tieModel) -## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3-------------------------------------------------- +## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3-------------------------------------------- examineOutliers(tieModel) examineChangepoints(tieModel) diff --git a/vignettes/teaching2.Rmd b/vignettes/teaching2.Rmd index 1b927f8..e831a36 100644 --- a/vignettes/teaching2.Rmd +++ b/vignettes/teaching2.Rmd @@ -410,7 +410,10 @@ endNet <- delete_nodes(endNet, !isStateActive) autographs(list(startNet, endNet), layout = "fr") ``` -plot of chunk plot-teaching2 +
+plot of chunk plot-teaching2 +

plot of chunk plot-teaching2

+
What can we observe? @@ -460,8 +463,8 @@ system.time( estimationInit = estPrefs ) ) -#> Error: Error in DyNAM choice_coordination estimation: Error in multinomialProbabilities * t(multinomialProbabilities): non-conformable arrays -#> Timing stopped at: 106.2 1.63 110.7 +#> user system elapsed +#> 172.01 12.90 200.93 ``` Did the model converge? If not, you can restart the estimation process using @@ -475,16 +478,52 @@ estPrefs <- list( maxIterations = 30, initialParameters = coef(partnerModel) ) -#> Error in coef(partnerModel): object 'partnerModel' not found partnerModel <- estimate( formula1, model = "DyNAM", subModel = "choice_coordination", estimationInit = estPrefs ) -#> Error: Error in DyNAM choice_coordination estimation: Error in multinomialProbabilities * t(multinomialProbabilities): non-conformable arrays summary(partnerModel) -#> Error in summary(partnerModel): object 'partnerModel' not found +#> +#> Call: +#> estimate(x = createBilat ~ inertia(bilatnet) + indeg(bilatnet, +#> ignoreRep = TRUE) + trans(bilatnet, ignoreRep = TRUE) + tie(contignet) + +#> alter(states$regime) + diff(states$regime) + alter(states$gdp) + +#> diff(states$gdp), model = "DyNAM", subModel = "choice_coordination", +#> estimationInit = estPrefs) +#> +#> +#> Effects details : +#> Object ignoreRep +#> inertia bilatnet +#> indeg bilatnet B +#> trans bilatnet B +#> tie contignet +#> alter states$regime +#> diff states$regime +#> alter states$gdp +#> diff states$gdp +#> +#> Coefficients : +#> Estimate Std. Error z-value Pr(>|z|) +#> inertia 2.8318525 0.2698244 10.4952 < 2.2e-16 *** +#> indeg 0.4975580 0.0662465 7.5107 5.884e-14 *** +#> trans 0.3083405 0.2138535 1.4418 0.149350 +#> tie 1.0821380 0.2195159 4.9297 8.237e-07 *** +#> alter 0.0047377 0.0143109 0.3311 0.740602 +#> diff 0.0010369 0.0116815 0.0888 0.929268 +#> alter 5.0326922 1.5429641 3.2617 0.001107 ** +#> diff -3.0780228 1.5940179 -1.9310 0.053485 . +#> --- +#> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +#> +#> Converged with max abs. score of 0.00029 +#> Log-Likelihood: -386.36 +#> AIC: 788.72 +#> AICc: 791.12 +#> BIC: 806.6 +#> model: "DyNAM" subModel: "choice_coordination" ``` Let's interpret... @@ -517,7 +556,7 @@ system.time( ) ) #> user system elapsed -#> 112.96 1.67 115.58 +#> 21.08 1.33 24.31 ``` # Extensions... @@ -535,8 +574,8 @@ Here is an example on the current results object: ```r library(broom) -#> Warning: package 'broom' was built under R version 4.2.3 library(pixiedust) +#> Warning: package 'pixiedust' was built under R version 4.3.3 dust(tidy(tieModel, conf.int = TRUE)) |> sprinkle(col = c(2:4, 6, 7), round = 3) |> sprinkle(col = 5, fn = quote(pvalString(value))) @@ -571,7 +610,10 @@ examineOutliers(tieModel) examineChangepoints(tieModel) ``` -plot of chunk examine +
+plot of chunk examine +

plot of chunk examine

+
For more, please see Hollway (2020) Network Embeddedness and the Rate of Water Cooperation and Conflict. From 037abd538f0a5200bff5b0f26ce20b98c5c69a00 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 6 Mar 2024 16:04:42 +0100 Subject: [PATCH 24/36] Remove work simulation files WIP --- R/functions_simulation.R | 218 ----------------- R/functions_simulation_engine.R | 403 -------------------------------- 2 files changed, 621 deletions(-) delete mode 100644 R/functions_simulation.R delete mode 100644 R/functions_simulation_engine.R diff --git a/R/functions_simulation.R b/R/functions_simulation.R deleted file mode 100644 index 807dd7a..0000000 --- a/R/functions_simulation.R +++ /dev/null @@ -1,218 +0,0 @@ -#' Simulate a sequence of events -#' -#' @description -#' `r lifecycle::badge("experimental")` -#' -#' Experimental version of the simulate functionality. -#' Current version **only** simulate endogenous events for a DyNAM model -#' with rate and choice submodel specifications. -#' It's restricted to simulate a fix length sequence, -#' oppose to the general case of simulate events until end time is reached. -#' -#' @inheritParams estimate -#' @param formulaRate a formula as define in \code{\link{estimate}} with the -#' effects for the rate sub-model \code{subModel = "rate"}. -#' @param parametersRate a numeric vector with the numerical values that -#' effects parameters on \code{formulaRate} should take during simulation. -#' @param formulaChoice a formula as define in \code{\link{estimate}} with the -#' effects for the choice sub-model \code{subModel = "choice"}. -#' When \code{model = "REM"} this formula is not required. -#' @param parametersChoice a numeric vector with the numerical values that -#' effects parameters on \code{formulaChoice} should take during simulation. -#' @param nEvents integer with the number of events to simulate from -#' the given formulas and parameter vectors. Default to \code{100}. -#' -#' @export -#' @importFrom lifecycle badge -#' -#' @examples -#' 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 -#' ) -#' -#' simulateEvents <- simulate( -#' formulaRate = callsDependent ~ 1 + indeg + outdeg, -#' parametersRate = c(-14, 0.76, 0.25), -#' formulaChoice = callsDependent ~ inertia + trans + recip + indeg, -#' parametersChoice = c(5.3, -0.05, 1.4, -0.16), -#' model = "DyNAM", subModel = "choice", -#' nEvents = 100 -#' ) -#' -simulate <- function(formulaRate, - parametersRate, - formulaChoice = NULL, - parametersChoice = NULL, - model = c("DyNAM", "REM"), - subModel = c("choice", "choice_coordination"), - progress = getOption("progress"), - nEvents = 100) { - UseMethod("simulate", formulaRate) -} - - -# First estimation from a formula: can return either -# a preprocessed object or a result object -#' @export -simulate.formula <- function(formulaRate, - parametersRate, - formulaChoice = NULL, - parametersChoice = NULL, - model = c("DyNAM", "REM"), - subModel = c("choice", "rate"), - progress = getOption("progress"), - nEvents = 100) { - # CHECK INPUT - model <- match.arg(model) - subModel <- match.arg(subModel) - - ### check model and subModel - checkModelPar(model, subModel, - modelList = c("DyNAM", "REM", "DyNAMi", "TriNAM"), - subModelList = list( - DyNAM = c("choice", "rate", "choice_coordination"), - REM = "choice", - DyNAMi = c("choice", "rate"), - TriNAM = c("choice", "rate") - ) - ) - - if (subModel == "choice_coordination") { - stop( - "It doesn't support simulating a DyNAM choice coordination model.\n", - "Since the generating process for the waiting time is not specified", - call. = FALSE - ) - } - - stopifnot( - inherits(formulaRate, "formula"), - is.null(formulaChoice) || inherits(formulaChoice, "formula"), - inherits(parametersRate, "numeric"), - is.null(parametersChoice) || inherits(parametersChoice, "numeric"), - is.null(progress) || inherits(progress, "logical"), - inherits(nEvents, "numeric") && nEvents > 0 - ) - - if (is.null(progress)) progress <- FALSE - - ## 1.1 Preparing - parsedformulaRate <- parseFormula(formulaRate) - - # The number of the independent variables should be the length - # of the input parameter vector - if (length(parsedformulaRate$rhsNames) + - parsedformulaRate$hasIntercept != - length(parametersRate)) { - stop( - "The number of independent effects should be the same", - " as the length of the input parameter vector:", - format(formulaRate), " with parameter ", - paste(parametersRate, collapse = ",", sep = ""), - call. = FALSE - ) - } - - if (!is.null(formulaChoice)) { - if (!(model == "DyNAM" && subModel == "choice")) { - stop( - "The model you specified doesn't require a formula", - "for the choice subModel", - call. = FALSE - ) - } - - ## 1.1 PARSE for all cases: preprocessingInit or not - parsedformulaChoice <- parseFormula(formulaChoice) - if (parsedformulaChoice$hasIntercept) { - # In the DyNAM choice model, - # the intercept will be cancelled and hence useless. - stop("Intercept in the choice subModel model will be ignored.", - " Please remove the intercep and run again.", - call. = FALSE - ) - } - - if (length(parsedformulaChoice$rhsNames) != - length(parametersChoice)) { - stop( - "The number of the independent effects should be the same", - " as the length of the input parameter:", - format(formulaChoice), " with parameter ", - paste(parametersChoice, collapse = ","), - call. = FALSE - ) - } - - if (parsedformulaRate$depName != parsedformulaChoice$depName) { - stop("formula for rate and choice submodels", - " must be defined over the same dependent event object", - call. = FALSE - ) - } - } else { - parsedformulaChoice <- NULL - } - - # CHECK THE INPUT FORMULA - # There must exist the intercept in the formula for the waiting-time - # generating process (For example, DyNAM rate, or REM), - if (!parsedformulaRate$hasIntercept) { - stop("You didn't specify an intercept in the rate formula.", - "\n\tCurrent implementation requires intercept and", - " a positive parameter value for it.", - call. = FALSE - ) - } - - # get node sets of dependent variable - nodes <- attr(get(parsedformulaRate$depName), "nodes") - isTwoMode <- FALSE - - # two-mode networks(2 kinds of nodes) - if (length(nodes) == 2) { - nodes2 <- nodes[2] - nodes <- nodes[1] - isTwoMode <- TRUE - } else { - nodes2 <- nodes - } - # Simulating! - if (progress) cat("Starting simulation\n") - events <- simulate_engine( - model = model, - subModel = subModel, - parametersRate = parametersRate, - parsedformulaRate = parsedformulaRate, - parametersChoice = parametersChoice, - parsedformulaChoice = parsedformulaChoice, - nEvents = nEvents, - nodes = nodes, - nodes2 = nodes2, - isTwoMode = isTwoMode, - startTime = 0, - endTime = NULL, - rightCensored = FALSE, # ToDo: check - progress = progress - ) - - nodes <- get(nodes, envir = environment()) - nodes2 <- get(nodes2, envir = environment()) - # Styling the result - events <- data.frame( - time = events[, 1], - sender = as.character(nodes$label[events[, 2]]), - receiver = as.character(nodes$label[events[, 3]]), - increment = events[, 4], - stringsAsFactors = FALSE - ) - - return(events) -} diff --git a/R/functions_simulation_engine.R b/R/functions_simulation_engine.R deleted file mode 100644 index b8bb8ca..0000000 --- a/R/functions_simulation_engine.R +++ /dev/null @@ -1,403 +0,0 @@ -#' internal function to perform simulation based on preprocessing -#' -#' Create a preprocess.goldfish class objectRate with the necessary information -#' for simulation. -#' -#' @inheritParams estimate -#' @inheritParams simulate -#' @inheritParams preprocess -#' -#' @return an array with simulated events -#' -#' @noRd -simulate_engine <- function( - model, - subModel, - parametersRate, - parsedformulaRate, - parametersChoice, - parsedformulaChoice, - nEvents, - # multipleParameter, - nodes, - nodes2 = nodes, - isTwoMode, - # add more parameters - startTime = 0, - endTime = NULL, - rightCensored = FALSE, - progress = FALSE) { - ## 2.1 INITIALIZE OBJECTS for all cases: preprocessingInit or not - - # enviroment from which get the objects - envir <- environment() - - # effect and objectsEffectsLink for sender-deciding process - effectsRate <- createEffectsFunctions(parsedformulaRate$rhsNames, - model, subModel, - envir = envir - ) - objectsEffectsLinkRate <- getObjectsEffectsLink( - parsedformulaRate$rhsNames - ) - - # effect and objectsEffectsLink for receiver-deciding process - effectsChoice <- NULL - objectsEffectsLinkChoice <- NULL - if (!is.null(parametersChoice)) { - effectsChoice <- createEffectsFunctions(parsedformulaChoice$rhsNames, - model, subModel, - envir = envir - ) - objectsEffectsLinkChoice <- getObjectsEffectsLink( - parsedformulaChoice$rhsNames - ) - } - - # - n1 <- nrow(get(nodes)) - n2 <- nrow(get(nodes2)) - nEffectsRate <- length(effectsRate) - nEffectsChoice <- length(effectsChoice) - - if (progress) cat("Initializing cache objects and statistical matrices.\n") - # ToDo: Impute misssing data - # startTime and endTime handling - - # Initialize stat matrix for rate model - statCacheRate <- initializeCacheStat( - objectsEffectsLink = objectsEffectsLinkRate, - effects = effectsRate, - groupsNetwork = NULL, - windowParameters = parsedformulaRate$windowParameters, - n1 = n1, n2 = n2, - model = model, subModel = "rate", - envir = envir - ) - - # Initialize stat matrix for the choice model - if (!is.null(parametersChoice)) { - statCacheChoice <- initializeCacheStat( - objectsEffectsLink = objectsEffectsLinkChoice, - effects = effectsChoice, - groupsNetwork = NULL, - windowParameters = parsedformulaChoice$windowParameters, - n1 = n1, n2 = n2, - model, "choice", - envir = envir - ) - # the variable subModel is for the sender-deciding process. ToDo: check - subModel <- "rate" - } - - # We put the initial stats to the previous format of 3 dimensional array - initialStatsRate <- array( - unlist(lapply(statCacheRate, "[[", "stat")), - dim = c(n1, n2, nEffectsRate) - ) - statMatRate <- initialStatsRate - statCacheRate <- lapply(statCacheRate, "[[", "cache") - # for receiver-deciding process if it's necessary - if (!is.null(parametersChoice)) { - initialStatsChoice <- array( - unlist(lapply(statCacheChoice, "[[", "stat")), - dim = c(n1, n2, nEffectsChoice) - ) - statMatChoice <- initialStatsChoice - statCacheChoice <- lapply(statCacheChoice, "[[", "cache") - } - - # ToDo: change to startTime - currentTime <- 0 - events <- matrix(0, nEvents, 4) - - # initialize progressbar output - showProgressBar <- FALSE - # progressEndReached <- FALSE - - if (progress) { - cat("Simulating events.\n") - showProgressBar <- TRUE - # # how often print, max 50 prints - pb <- utils::txtProgressBar(max = nEvents, char = "*", style = 3) - dotEvents <- ifelse(nEvents > 50, ceiling(nEvents / 50), 1) - } - - # Simulation each event - for (i in 1:nEvents) { - # # progress bar - if (showProgressBar && i %% dotEvents == 0) { - utils::setTxtProgressBar(pb, i) - } else if (showProgressBar && i == nEvents) { - utils::setTxtProgressBar(pb, i) - close(pb) - } - - # nextEvent <- 1 - effIdsRate <- seq.int(length(objectsEffectsLinkRate)) - effIdsChoice <- seq.int(length(objectsEffectsLinkChoice)) - objTableRate <- getDataObjects( - list(rownames(objectsEffectsLinkRate)), - removeFirst = FALSE - ) - objectNameRate <- objTableRate$name - objectRate <- getElementFromDataObjectTable( - objTableRate, - envir = envir - )[[1]] - - #### GENERATING EVENT - # We consider only two types of model, REM and DyNAM, - # and don't consider DyNAM-MM - if (model == "REM") { - simulatedEvent <- generationREM( - statMatRate, parametersRate, n1, n2, isTwoMode - ) - waitingTime <- simulatedEvent$waitingTime - simulatedSender <- simulatedEvent$simulatedSender - simulatedReceiver <- simulatedEvent$simulatedReceiver - } else if (model == "DyNAM" && subModel == "rate") { - simulatedSenderEvent <- generationDyNAMRate( - statMatRate, parametersRate, n1, n2, isTwoMode - ) - waitingTime <- simulatedSenderEvent$waitingTime - simulatedSender <- simulatedSenderEvent$simulatedSender - simulatedReceiverEvent <- generationDyNAMChoice( - statMatChoice, parametersChoice, simulatedSender, n1, n2, isTwoMode - ) - simulatedReceiver <- simulatedReceiverEvent$simulatedReceiver - } - - # event <- c(simulatedSender, simulatedReceiver, - # objectRate[simulatedSender, simulatedReceiver]) - event <- data.frame( - sender = as.integer(simulatedSender), - receiver = as.integer(simulatedReceiver), - replace = objectRate[simulatedSender, simulatedReceiver] + 1 - ) - # RECORD EVENT - events[i, ] <- c( - currentTime + waitingTime, - simulatedSender, - simulatedReceiver, - 1 - ) - - ### CALCULATE UPDATES - isUndirectedNet <- FALSE - updatesList <- getUpdates( - event, effectsRate, effIdsRate, - objectsEffectsLinkRate, isUndirectedNet, n1, n2, - isTwoMode, envir, "statCacheRate" - ) - ### APPLYING UPDATES TO statMatRate - # For sender - for (id in effIdsRate) { - if (id <= length(updatesList) && !is.null(updatesList[[id]])) { - updates <- updatesList[[id]] - # ToDo: check - statMatRate[cbind(updates[, "node1"], updates[, "node2"], id)] <- - updates[, "replace"] - } - } - # For receiver - if (!is.null(parametersChoice)) { - updatesList <- getUpdates( - event, effectsChoice, effIdsChoice, - objectsEffectsLinkChoice, isUndirectedNet, n1, n2, - isTwoMode, envir, "statCacheChoice" - ) - ### APPLYING UPDATES TO statMatRate - # For receiver - for (id in effIdsChoice) { - if (id <= length(updatesList) && !is.null(updatesList[[id]])) { - updates <- updatesList[[id]] - statMatChoice[cbind(updates[, "node1"], updates[, "node2"], id)] <- - updates[, "replace"] - } - } - } - - ### update other information - currentTime <- currentTime + waitingTime - objectRate[simulatedSender, simulatedReceiver] <- - objectRate[simulatedSender, simulatedReceiver] + 1 - eval(parse(text = paste(objectNameRate, "<- objectRate")), - envir = envir - ) - } - - return(events) -} - -#' @importFrom stats rexp -generationREM <- function(statMatRate, parametersRate, n1, n2, isTwoMode) { - n_parameters <- dim(statMatRate)[3] - # +1 for intercept - stat_mat <- matrix(0, n1 * n2, n_parameters + 1) - stat_mat[, 1] <- 1 - for (i in 1:n_parameters) { - stat_mat[, i + 1] <- t(statMatRate[, , i]) - } - expValue <- exp(stat_mat %*% parametersRate) - if (!isTwoMode) { - for (i in 1:n1) expValue[i + (i - 1) * n2] <- 0 - } - - # expected time - tauSum <- sum(expValue) - expectedWaitingtime <- 1 / tauSum - waitingTime <- rexp(1, tauSum) - - # Conditional on the waiting time, - # the process to choose a sender-receiver pair is a multinomial process - simulatedSenderReceiver <- sample(seq_along(expValue), 1, prob = expValue) - simulatedSender <- ceiling(simulatedSenderReceiver / n2) - simulatedReceiver <- simulatedSenderReceiver - (simulatedSender - 1) * n2 - - - return(list( - simulatedSenderReceiver = simulatedSenderReceiver, - simulatedSender = simulatedSender, - simulatedReceiver = simulatedReceiver, - expectedWaitingtime = expectedWaitingtime, - waitingTime = waitingTime - )) -} - -generationDyNAMRate <- function( - statMatRate, parametersRate, n1, n2, isTwoMode -) { - # Copy from functions_estimation_engine.R for matrix reduction - # In the end, we will get a n1 x nEffectsRate matrix stat_mat. - if (isTwoMode == FALSE) { - dims <- dim(statMatRate) # statsArrayComp: - stat_mat <- apply(statMatRate, 3, function(stat) { - diag(stat) <- 0 - m <- stat - stat <- rowMeans(m, na.rm = TRUE) * (dim(m)[1]) / (dim(m)[1] - 1) - stat - }) - } else { - dims <- dim(statMatRate) - # statsArrayComp: n_nodes1*n_nodes2*num_statistics matrix - stat_mat <- apply(statMatRate, 3, function(stat) { - m <- stat - stat <- rowMeans(m, na.rm = TRUE) - stat - }) - } - expValue <- exp(stat_mat %*% parametersRate[-1] + parametersRate[1]) - - # expected time - tauSum <- sum(expValue) - expectedWaitingtime <- 1 / tauSum - waitingTime <- rexp(1, tauSum) - - # Conditional on the waiting time, the process to choose a sender is - # a multinomial process - simulatedSender <- sample(seq_along(expValue), 1, prob = expValue) - - - return(list( - simulatedSender = simulatedSender, - expectedWaitingtime = expectedWaitingtime, - waitingTime = waitingTime - )) -} - -generationDyNAMChoice <- function( - statMatRate, parametersChoice, simulatedSender, n1, n2, isTwoMode -) { - stat_mat <- statMatRate[simulatedSender, , ] - expValue <- exp(stat_mat %*% parametersChoice) - if (!isTwoMode) expValue[simulatedSender] <- 0 - # In DyNAM, we use multinomial process for receiver selection - simulatedReceiver <- sample(seq_along(expValue), 1, prob = expValue) - return(list(simulatedReceiver = simulatedReceiver)) -} - -getUpdates <- function( - event, effects, effIds, - objectsEffectsLink, isUndirectedNet, n1, n2, - isTwoMode, envir, cacheName) { - # get the statCache from the envir - # We does it in this way because we have to update the statCache in - # the parent enviroment later. - statCache <- get(cacheName, envir = envir) - # define the return variable - updatesList <- list() - - for (id in effIds) { - # create the ordered list for the objects - objectsToPass <- objectsEffectsLink[, id][!is.na(objectsEffectsLink[, id])] - names <- rownames(objectsEffectsLink)[!is.na(objectsEffectsLink[, id])] - orderedNames <- names[order(objectsToPass)] - orderedObjectTable <- getDataObjects(list(list("", orderedNames))) - .objects <- getElementFromDataObjectTable( - orderedObjectTable, - envir = envir - ) - # identify class to feed effects functions - objClass <- vapply(.objects, - FUN = inherits, FUN.VALUE = integer(2), - what = c("numeric", "matrix"), which = TRUE - ) > 0 - attIDs <- which(objClass[1, ]) - netIDs <- which(objClass[2, ]) - - # call effects function with required arguments - .argsFUN <- list( - network = if (length(.objects[netIDs]) == 1) { - .objects[netIDs][[1]] - } else { - .objects[netIDs] - }, - attribute = if (length(.objects[attIDs]) == 1) { - .objects[attIDs][[1]] - } else { - .objects[attIDs] - }, - cache = statCache[[id]], - n1 = n1, - n2 = n2 - ) - - effectUpdate <- callFUN( - effects, id, "effect", c(.argsFUN, event), " cannot update \n", - colnames(objectsEffectsLink)[id] - ) - - updates <- effectUpdate$changes - # if cache and changes are not null update cache - if (!is.null(effectUpdate$cache) && !is.null(effectUpdate$changes)) { - statCache[[id]] <- effectUpdate$cache - } - - if (isUndirectedNet) { - event2 <- event - event2$sender <- event$receiver - event2$receiver <- event$sender - if (!is.null(effectUpdate$cache) && !is.null(effectUpdate$changes)) { - .argsFUN$cache <- statCache[[id]] - } - effectUpdate2 <- callFUN( - effects, id, "effect", c(.argsFUN, event2), " cannot update \n", - colnames(objectsEffectsLink)[id] - ) - - if (!is.null(effectUpdate2$cache) && !is.null(effectUpdate2$changes)) { - statCache[[id]] <- effectUpdate2$cache - } - updates2 <- effectUpdate2$changes - updates <- rbind(updates, updates2) - } - - updatesList[[id]] <- updates - } - - # update the statCache - assign(cacheName, statCache, envir = envir) - # return updatesList - return(updatesList) -} From a7525369c85a3912902ecb1a2a0a6b2f4ef87f15 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 7 Mar 2024 17:10:29 +0100 Subject: [PATCH 25/36] Improve documentation and debug `GatherPreprocessing()` --- NAMESPACE | 4 -- R/functions_gather.R | 95 +++++++++++++++++++++++++------ man/GatherPreprocessing.Rd | 112 ++++++++++++++++++++++++++++++++----- man/simulate.Rd | 94 ------------------------------- 4 files changed, 178 insertions(+), 127 deletions(-) delete mode 100644 man/simulate.Rd diff --git a/NAMESPACE b/NAMESPACE index f02fbec..43f6a2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -15,7 +15,6 @@ S3method(print,nodes.goldfish) S3method(print,preprocessed.goldfish) S3method(print,result.goldfish) S3method(print,summary.result.goldfish) -S3method(simulate,formula) S3method(summary,result.goldfish) S3method(tidy,result.goldfish) S3method(vcov,result.goldfish) @@ -30,12 +29,10 @@ export(examineChangepoints) export(examineOutliers) export(glance) export(linkEvents) -export(simulate) export(tidy) importFrom(Rcpp,sourceCpp) importFrom(generics,glance) importFrom(generics,tidy) -importFrom(lifecycle,badge) importFrom(rlang,.data) importFrom(stats,IQR) importFrom(stats,as.formula) @@ -44,7 +41,6 @@ importFrom(stats,formula) importFrom(stats,median) importFrom(stats,na.exclude) importFrom(stats,na.omit) -importFrom(stats,rexp) importFrom(stats,sd) importFrom(utils,head) importFrom(utils,packageDescription) diff --git a/R/functions_gather.R b/R/functions_gather.R index 0cf727e..3ee50ca 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -7,21 +7,82 @@ #' Gather preprocess data from a formula #' -#' Preprocess is made with goldfish. +#' Gather the preprocess data from a formula and a model, +#' where the output corresponds to the data structure used by the engine +#' `gather_compute`; see [estimate()]. +#' +#' It differs from the `estimate()` output when the argument `preprocessingOnly` +#' is set to `TRUE` regarding the memory space requirement. +#' The `gatherPreprocessing()` produces a list where the first element +#' is a matrix that could have up to the number of events times +#' the number of actors rows and the number of effects columns. +#' For medium to large datasets with thousands of events and +#' thousands of actors, the memory RAM requirements are large and, +#' therefore, errors are produced due to a lack of space. +#' The advantage of the data structure is that it can be adapted +#' to estimate the models (or extensions of them) using standard packages +#' for generalized linear models (or any other model) +#' that use tabular data as input. +#' +#' @inheritParams estimate #' -#' @param formula See [estimate()]. Left side a dependent events object defined -#' with [defineDependentEvents()] and right side effect parameters as described -#' in `vignette("goldfishEffects")`. -#' @param model See [estimate()]. Current version of gather works for -#' `c('DyNAM')` -#' @param subModel Current version supports `c('choice_coordination', 'choice')` -#' @param preprocessArgs Additional preprocess arguments like `startTime`, -#' `endTime` and `opportunitiesList`. See [estimate()]. -#' @param progress Default `FALSE`. -#' @param envir an `environment` where `formula` objects and their linked -#' objectsare available. +#' @param preprocessArgs a list containing additional parameters +#' for preprocessing. It may contain: +#' \describe{ +#' \item{startTime}{a numerical value or a date-time character with the same +#' time-zone formatting as the times in event that indicates the starting time +#' to be considered during estimation. +#' \emph{Note:} it is only use during preprocessing} +#' \item{endTime}{a numerical value or a date-time character with the same +#' time-zone formatting as the times in event that indicates the end time +#' to be considered during estimation. +#' \emph{Note:} it is only use during preprocessing} +#' \item{opportunitiesList}{a list containing for each dependent event +#' the list of available nodes for the choice model, this list should be +#' the same length as the dependent events list (ONLY for choice models).} +#' } #' -#' @return a list with the data and relevant information. +#' @return a list object including: +#' \describe{ +#' \item{stat_all_events}{a matrix. The number of rows can be up to the number +#' of events times the number of actors +#' (square number of actors for the REM). +#' Rigth-censored events are included when the model has an intercept. +#' The number of columns is the number of effects in the model. +#' Every row is the effect statistics at the time of the event for each actor +#' in the choice set or the sender set.} +#' \item{n_candidates}{ +#' a numeric vector with the number of rows related with an event. +#' The length correspond to the number of events +#' plus right censored events if any.} +#' \item{selected}{a numeric vector with the position of the +#' selected actor (choice model), sender actor (rate model), or +#' active dyad (choice-coordination model, REM model). +#' Indexing start at 1 for each event.} +#' \item{sender, receiver}{ +#' a character vector with the label of the sender/receiver actor. +#' For right-censored events the receiver values is not meaningful.} +#' \item{hasIntercept}{ +#' a logical value indicating if the model has an intercept.} +#' \item{namesEffects}{a character vector with a short name of the effect. +#' It includes the name of the object used to calculate the effects and +#' modifiers of the effect, e.g., the type of effect, weighted effect.} +#' \item{effectDescription}{ +#' a character matrix with the description of the effects. +#' It includes the name of the object used to calculate the effects and +#' additional information of the effect, e.g., the type of effect, +#' weighted effect, transformation function, window length.} +#' } +#' If the model has an intercept and the subModel is `rate` or model is `REM`, +#' additional elements are included: +#' \describe{ +#' \item{timespan}{ +#' a numeric vector with the time span between events, +#' including right-censored events.} +#' \item{isDependent}{ +#' a logical vector indicating if the event is dependent or right-censored.} +#' } +#' #' @export #' #' @examples @@ -321,11 +382,13 @@ GatherPreprocessing <- function( ## CONVERT TYPES OF EVENTS AND TIMESPANS INTO THE FORMAT ACCEPTED ## BY C FUNCTIONS - if (modelTypeCall %in% c("DyNAM-M-Rate", "REM")) { + if (modelTypeCall %in% c("DyNAM-M-Rate", "REM", "DyNAM-MM")) { is_dependent <- preprocessingStat$orderEvents == 1 timespan <- numeric(length(is_dependent)) - timespan[is_dependent] <- preprocessingStat$intervals - timespan[(!is_dependent)] <- preprocessingStat$rightCensoredIntervals + if (modelTypeCall != "DyNAM-MM") { + timespan[is_dependent] <- preprocessingStat$intervals + timespan[(!is_dependent)] <- preprocessingStat$rightCensoredIntervals + } } else { timespan <- NA } diff --git a/man/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd index 5d77d19..53021ea 100644 --- a/man/GatherPreprocessing.Rd +++ b/man/GatherPreprocessing.Rd @@ -14,28 +14,114 @@ GatherPreprocessing( ) } \arguments{ -\item{formula}{See \code{\link[=estimate]{estimate()}}. Left side a dependent events object defined -with \code{\link[=defineDependentEvents]{defineDependentEvents()}} and right side effect parameters as described -in \code{vignette("goldfishEffects")}.} +\item{model}{a character string defining the model type. +Current options include \code{"DyNAM"}, \code{"DyNAMi"} or \code{"REM"} +\describe{ +\item{DyNAM}{Dynamic Network Actor Models +(Stadtfeld, Hollway and Block, 2017 and Stadtfeld and Block, 2017)} +\item{DyNAMi}{Dynamic Network Actor Models for interactions +(Hoffman et al., 2020)} +\item{REM}{Relational Event Model (Butts, 2008)} +}} -\item{model}{See \code{\link[=estimate]{estimate()}}. Current version of gather works for -\code{c('DyNAM')}} +\item{subModel}{a character string defining the submodel type. +Current options include \code{"choice"}, \code{"rate"} or +\code{"choice_coordination"} +\describe{ +\item{choice}{a multinomial receiver choice model \code{model = "DyNAM"} +(Stadtfeld and Block, 2017), or the general Relational event model +\code{model = "REM"} (Butts, 2008). +A multinomial group choice model \code{model = "DyNAMi"} (Hoffman et al., 2020)} +\item{choice_coordination}{a multinomial-multinomial model for coordination +ties \code{model = "DyNAM"} (Stadtfeld, Hollway and Block, 2017)} +\item{rate}{A individual activity rates model \code{model = "DyNAM"} +(Stadtfeld and Block, 2017). +Two rate models, one for individuals joining groups and one for individuals +leaving groups, jointly estimated \code{model = "DyNAMi"}(Hoffman et al., 2020)} +}} -\item{subModel}{Current version supports \code{c('choice_coordination', 'choice')}} +\item{preprocessArgs}{a list containing additional parameters +for preprocessing. It may contain: +\describe{ +\item{startTime}{a numerical value or a date-time character with the same +time-zone formatting as the times in event that indicates the starting time +to be considered during estimation. +\emph{Note:} it is only use during preprocessing} +\item{endTime}{a numerical value or a date-time character with the same +time-zone formatting as the times in event that indicates the end time +to be considered during estimation. +\emph{Note:} it is only use during preprocessing} +\item{opportunitiesList}{a list containing for each dependent event +the list of available nodes for the choice model, this list should be +the same length as the dependent events list (ONLY for choice models).} +}} -\item{preprocessArgs}{Additional preprocess arguments like \code{startTime}, -\code{endTime} and \code{opportunitiesList}. See \code{\link[=estimate]{estimate()}}.} - -\item{progress}{Default \code{FALSE}.} +\item{progress}{logical indicating whether should print a minimal output +to the console of the progress of the preprocessing and estimation processes.} \item{envir}{an \code{environment} where \code{formula} objects and their linked -objectsare available.} +objects are available.} } \value{ -a list with the data and relevant information. +a list object including: +\describe{ +\item{stat_all_events}{a matrix. The number of rows can be up to the number +of events times the number of actors +(square number of actors for the REM). +Rigth-censored events are included when the model has an intercept. +The number of columns is the number of effects in the model. +Every row is the effect statistics at the time of the event for each actor +in the choice set or the sender set.} +\item{n_candidates}{ +a numeric vector with the number of rows related with an event. +The length correspond to the number of events +plus right censored events if any.} +\item{selected}{a numeric vector with the position of the +selected actor (choice model), sender actor (rate model), or +active dyad (choice-coordination model, REM model). +Indexing start at 1 for each event.} +\item{sender, receiver}{ +a character vector with the label of the sender/receiver actor. +For right-censored events the receiver values is not meaningful.} +\item{hasIntercept}{ +a logical value indicating if the model has an intercept.} +\item{namesEffects}{a character vector with a short name of the effect. +It includes the name of the object used to calculate the effects and +modifiers of the effect, e.g., the type of effect, weighted effect.} +\item{effectDescription}{ +a character matrix with the description of the effects. +It includes the name of the object used to calculate the effects and +additional information of the effect, e.g., the type of effect, +weighted effect, transformation function, window length.} +} +If the model has an intercept and the subModel is \code{rate} or model is \code{REM}, +additional elements are included: +\describe{ +\item{timespan}{ +a numeric vector with the time span between events, +including right-censored events.} +\item{isDependent}{ +a logical vector indicating if the event is dependent or right-censored.} +} } \description{ -Preprocess is made with goldfish. +Gather the preprocess data from a formula and a model, +where the output corresponds to the data structure used by the engine +\code{gather_compute}; see \code{\link[=estimate]{estimate()}}. +} +\details{ +It differs from the \code{estimate()} output when the argument \code{preprocessingOnly} +is set to \code{TRUE} regarding the memory space requirement. +The \code{gatherPreprocessing()} produces a list where the first element +is a matrix that could have up to the number of events times +the number of actors rows and the number of effects columns. +For medium to large datasets with thousands of events and +thousands of actors, the memory RAM requirements are large and, +therefore, errors are produced due to a lack of space. +The advantage of the data structure is that it can be adapted +to estimate the models (or extensions of them) using standard packages +for generalized linear models (or any other model) +that use tabular data as input. } \examples{ data("Fisheries_Treaties_6070") diff --git a/man/simulate.Rd b/man/simulate.Rd deleted file mode 100644 index 75620e4..0000000 --- a/man/simulate.Rd +++ /dev/null @@ -1,94 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/functions_simulation.R -\name{simulate} -\alias{simulate} -\title{Simulate a sequence of events} -\usage{ -simulate( - formulaRate, - parametersRate, - formulaChoice = NULL, - parametersChoice = NULL, - model = c("DyNAM", "REM"), - subModel = c("choice", "choice_coordination"), - progress = getOption("progress"), - nEvents = 100 -) -} -\arguments{ -\item{formulaRate}{a formula as define in \code{\link{estimate}} with the -effects for the rate sub-model \code{subModel = "rate"}.} - -\item{parametersRate}{a numeric vector with the numerical values that -effects parameters on \code{formulaRate} should take during simulation.} - -\item{formulaChoice}{a formula as define in \code{\link{estimate}} with the -effects for the choice sub-model \code{subModel = "choice"}. -When \code{model = "REM"} this formula is not required.} - -\item{parametersChoice}{a numeric vector with the numerical values that -effects parameters on \code{formulaChoice} should take during simulation.} - -\item{model}{a character string defining the model type. -Current options include \code{"DyNAM"}, \code{"DyNAMi"} or \code{"REM"} -\describe{ -\item{DyNAM}{Dynamic Network Actor Models -(Stadtfeld, Hollway and Block, 2017 and Stadtfeld and Block, 2017)} -\item{DyNAMi}{Dynamic Network Actor Models for interactions -(Hoffman et al., 2020)} -\item{REM}{Relational Event Model (Butts, 2008)} -}} - -\item{subModel}{a character string defining the submodel type. -Current options include \code{"choice"}, \code{"rate"} or -\code{"choice_coordination"} -\describe{ -\item{choice}{a multinomial receiver choice model \code{model = "DyNAM"} -(Stadtfeld and Block, 2017), or the general Relational event model -\code{model = "REM"} (Butts, 2008). -A multinomial group choice model \code{model = "DyNAMi"} (Hoffman et al., 2020)} -\item{choice_coordination}{a multinomial-multinomial model for coordination -ties \code{model = "DyNAM"} (Stadtfeld, Hollway and Block, 2017)} -\item{rate}{A individual activity rates model \code{model = "DyNAM"} -(Stadtfeld and Block, 2017). -Two rate models, one for individuals joining groups and one for individuals -leaving groups, jointly estimated \code{model = "DyNAMi"}(Hoffman et al., 2020)} -}} - -\item{progress}{logical indicating whether should print a minimal output -to the console of the progress of the preprocessing and estimation processes.} - -\item{nEvents}{integer with the number of events to simulate from -the given formulas and parameter vectors. Default to \code{100}.} -} -\description{ -\ifelse{html}{\href{https://lifecycle.r-lib.org/articles/stages.html#experimental}{\figure{lifecycle-experimental.svg}{options: alt='[Experimental]'}}}{\strong{[Experimental]}} - -Experimental version of the simulate functionality. -Current version \strong{only} simulate endogenous events for a DyNAM model -with rate and choice submodel specifications. -It's restricted to simulate a fix length sequence, -oppose to the general case of simulate events until end time is reached. -} -\examples{ -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 -) - -simulateEvents <- simulate( - formulaRate = callsDependent ~ 1 + indeg + outdeg, - parametersRate = c(-14, 0.76, 0.25), - formulaChoice = callsDependent ~ inertia + trans + recip + indeg, - parametersChoice = c(5.3, -0.05, 1.4, -0.16), - model = "DyNAM", subModel = "choice", - nEvents = 100 -) - -} From a245b1944a9abc43b13f69cf422877d140c5c5f8 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 7 Mar 2024 17:12:25 +0100 Subject: [PATCH 26/36] Update vignettes and fix error with `migraph` in teaching1 vignette --- vignettes/dynami-example.Rmd | 95 +++------------ vignettes/teaching/plot-teaching1-1.png | Bin 1738 -> 1745 bytes vignettes/teaching/plot-teaching1-2.png | Bin 4460 -> 4392 bytes vignettes/teaching/plot-teaching1-3.png | Bin 5517 -> 5733 bytes vignettes/teaching/plot-teaching2-1.png | Bin 13085 -> 13231 bytes vignettes/teaching1.R | 21 ++-- vignettes/teaching1.Rmd | 150 ++++++++++++++---------- vignettes/teaching1.Rmd.orig | 27 +++-- vignettes/teaching2.Rmd | 4 +- 9 files changed, 139 insertions(+), 158 deletions(-) diff --git a/vignettes/dynami-example.Rmd b/vignettes/dynami-example.Rmd index 3da8884..6b781c7 100644 --- a/vignettes/dynami-example.Rmd +++ b/vignettes/dynami-example.Rmd @@ -400,43 +400,18 @@ est.choice.M1 <- estimate( model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities) ) +``` + +``` +## Error: Error in DyNAMi choice estimation: Error: Active node 1 not available in event 14 +``` + +```r summary(est.choice.M1) ``` ``` -## -## Call: -## estimate(x = dependent.events ~ diff(actors$age, subType = "averaged_sum") + -## diff(actors$level, subType = "averaged_sum") + same(actors$gender, -## subType = "proportion") + same(actors$group, subType = "proportion") + -## tie(known.before, subType = "proportion"), model = "DyNAMi", -## subModel = "choice", estimationInit = list(opportunitiesList = opportunities)) -## -## -## Effects details : -## Object subType -## diff "actors$age" ""averaged_sum"" -## diff "actors$level" ""averaged_sum"" -## same "actors$gender" ""proportion"" -## same "actors$group" ""proportion"" -## tie "known.before" ""proportion"" -## -## Coefficients : -## Estimate Std. Error z-value Pr(>|z|) -## diff -0.107578 0.067179 -1.6014 0.1092943 -## diff 0.262945 0.225568 1.1657 0.2437353 -## same 0.292121 0.298317 0.9792 0.3274665 -## same 0.024975 0.384103 0.0650 0.9481565 -## tie 1.316141 0.378545 3.4768 0.0005074 *** -## --- -## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -## -## Converged with max abs. score of 0.00026 -## Log-Likelihood: -195.16 -## AIC: 400.32 -## AICc: 400.84 -## BIC: 414.39 -## model: "DyNAMi" subModel: "choice" +## Error in eval(expr, envir, enclos): object 'est.choice.M1' not found ``` ### Step 5: Estimate a model with structural and time effects @@ -565,56 +540,18 @@ est.choice.M2 <- estimate( model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities) ) +``` + +``` +## Error: Error in DyNAMi choice estimation: Error: Active node 1 not available in event 14 +``` + +```r summary(est.choice.M2) ``` ``` -## -## Call: -## estimate(x = dependent.events ~ diff(actors$age, subType = "averaged_sum") + -## diff(actors$level, subType = "averaged_sum") + same(actors$gender, -## subType = "proportion") + same(actors$group, subType = "proportion") + -## alter(actors$age, subType = "mean") + tie(known.before, subType = "proportion") + -## size(network.interactions, subType = "identity") + alterpop(network.past, -## subType = "mean_normalized") + inertia(network.past, window = 60, -## subType = "mean") + inertia(network.past, window = 300, subType = "mean"), -## model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities)) -## -## -## Effects details : -## Object window subType -## diff "actors$age" "" ""averaged_sum"" -## diff "actors$level" "" ""averaged_sum"" -## same "actors$gender" "" ""proportion"" -## same "actors$group" "" ""proportion"" -## alter "actors$age" "" ""mean"" -## tie "known.before" "" ""proportion"" -## size "network.interactions" "" ""identity"" -## alterpop "network.past" "" ""mean_normalized"" -## inertia "network.past" "60" ""mean"" -## inertia "network.past" "300" ""mean"" -## -## Coefficients : -## Estimate Std. Error z-value Pr(>|z|) -## diff -0.133077 0.073387 -1.8134 0.069776 . -## diff 0.095857 0.231054 0.4149 0.678238 -## same 0.141033 0.321444 0.4387 0.660843 -## same -0.284446 0.418710 -0.6793 0.496924 -## alter 0.033538 0.017678 1.8971 0.057809 . -## tie 1.274992 0.393714 3.2384 0.001202 ** -## size 0.097754 0.093141 1.0495 0.293934 -## alterpop 0.288526 0.170532 1.6919 0.090662 . -## inertia 0.211654 0.458129 0.4620 0.644084 -## inertia -0.096613 0.235330 -0.4105 0.681410 -## --- -## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 -## -## Converged with max abs. score of 2e-05 -## Log-Likelihood: -189.76 -## AIC: 399.53 -## AICc: 401.49 -## BIC: 427.65 -## model: "DyNAMi" subModel: "choice" +## Error in eval(expr, envir, enclos): object 'est.choice.M2' not found ``` Of course these models ask a bit much from our data, diff --git a/vignettes/teaching/plot-teaching1-1.png b/vignettes/teaching/plot-teaching1-1.png index 133b7d22055565d1d5da4c8eab1079387901811e..a8d66363f80ff64b59f69c2b5062cadfa4bfb0af 100644 GIT binary patch literal 1745 zcmeAS@N?(olHy`uVBq!ia0y~yVEh5X9LzwGiQo8rffQSSPlzj!{{R2~(wp<|0$H2| z9+AZi4BSE>%y{W;-5;Q;LQfaRkcv5P@1D++wiICqJpcdy7ly|=Y8_7_g6#DopX+Sq zI1xQ5dP&cd$MTcx-o-I|7qIjCq498WOTQ37#y9@|8~=;NZ~Pz9@_*7w7fyNAKgrSd zDrNU>?`}!AKjaP+sG0I15X9IT^keP$tKrd^(-t4@kGmr-7X2>f&}J6m?0NJs{CDfh z$0_FjJS&ob4*RE8ZlBV!zw^VLNAo_E@4q9s&#Q68-b24VKP6ZDdi{_$UWwHMZtd}J z*veKu?TdRIG&v?`r}o;Z%t%gzx%L0trSBfi+x-4qpMuS9L0}-f^sBnVVL$hSjOULP z!iVx}*lu-v2vl-K(|TRH@SnxBkl0j36w>9%anX%sTo(?;&5oZJzrp)c-Js z@tkMuvByyLFE=~RRd?r$$d+_PPyl}Q`(Y}d_s9K*#@lJ%Z~gZF@s#ttFeH*z`q>$C z{-5or9`bO#iN>FkM$%8qQ34<4GemTl8rM9}{&@S$oDb{%|9ZIK=-J4Vj%;VY`8SK1 zr>n+*9plGu|6=2@{~YqF-q1Mw+Wf(8-dm3!8iDAkWAC3Imt24BHjJ=hA2+_n)l(+%5f1QMaN&heO%??b(KF;%XanN$k2W+Jnt!5Y=RRlG~7}TzyIQUTYJ-O z@p*>pY7DvTJ3h>LxAw!==TAY%+x?g4{)V>qBy4qDx9y&> z%3I>NS&_afapd_V{Pn-C_^-Z+bLq{+9oI@rpLP zaThcDd;ez|z1s0%{U6^$`3@CzZ;pOwydQF7&WAuIH(-fUS<%15-AumcL%)u(1ZV%& zGZwA((+Ytyh!6q?)&A7G*-KN!?V3O6xPeNxcij8mJuc)vqfB0S9<+>l_2a`E=$woci`TNt^pT`~L6`y#2h=|GRV zq#nLr|14#@zKtiU1A$(9E?pUJQs}!|aGoV1fgy_RDAhkFvd>RlYvlisKW!dTg5IC@ zGx*r6*ZaFatjRq6;q-o4{S8k$TK-!rcfsP~|I%-b2HWl)Z&7z7wl09UU`0KnNz8q@ U;#8--z#56c)78&qol`;+0IbJQ%y{W;-5;Q;EKe85kcv5P??e~fb`xO;O#eUIZ|R&O)lDg$3UbBE&;Q(R zQY_8FIN?+Oeve-tzc5v_eF!|{&MB{2GlekYkA2;jV;63JtZrGJbo|4?>+iq6wNQSz z|3J^8mVO~SuOAu@7q{4F{n&f>%~gBP3N@GzT&{nXaNUo|o35Ujx$MJoqq898P`Uh# z_jFGdao?K!LB|PfOn;TdpDJ-%(L?T%$S#w=@wYDd^V`2ADvLfy->`io=q7~Q<@+aC z+xrOBDIO}egxMtQ`>X5vf~D*HE2gPK%stC%|I#bVQQY@^o7SQIDR~ufN&(=Y&=tNH zdT{SF$?YG$8@)qvD%{OrhL-rh1MQC9wRI)elEQ9X)@}L!{rQ~F$ury_z7YDys2!uL zx1mMuVPy~Y0G8$5f9P>qoI=f%I@Fjb4X^nAw_DII>!w`alx$t=xQFXg_XJkA)_*WD ze9L2+vva<{zte5H(>HU-tNyvPu9{h}F7r^a5zMP7PQHJlTL)?e& zzwE@^Pt(v{^ha2%!t2W)uCA8nnupwLrRo|t3yBNZd0ks!eAwEON2z8?7^)jpYpzWB zAjda1=afyW{me=?PI*y|_py&`8y9l?mvinEvU|1i!@2$UOFtcHnV&TI!*0oP1^?*x zt6I|8Fq~QY_v6AzAASqXyN@L`{%q#(&=JcKe~#D*yS-YVRM%InFb; z^jF#L;XXLAr9Vg)k_eGfoWwol#lk*w7Jg7SIIQu|z3T50^*O-24u|%q@0b0X_Fq;`(PlSh z1_6n5`c*8^`Qvh^7(GXBjs9`qy2|;Dx97C{S1RrTsjb%eF1F=XRhge^OF(ecepX{kjh;+d=;PtGFlo!(5{;lTG0!5(x*5|j6 zPn&Hu{lor$XQxf>5Ui8@-WPf}mE(VR@afWNa%(?aH@tqbShpjdK^R|pt zj)z75`Ls!*LA!V`@T12Lq z$cI8CWQoCu$ujgIV}$V=p6mKvzdxSe_j-PRoX@%M`#R@*uKPak>s;q`Zadf`Lgcmym{{Z=H})HEw^>5fa~OJHCv>afACFSy`C5U>-0F zl4B~g_MOU)Jz8wH$f?3UoObN zfZ6rbiZ1U;U}H0_jAt=?@bwCG24@k(nABIA)9_6d5SL~Em!Rz-W zh-GHkH){QDmhC~rm6UKxC4K-g(e^41rU7>*wTBYEhB)G6vb={EAoA}gYBuUv+>{~y zw{OxDtiCv|tdN2V=?U9K+t**KW7lsy%MQD2B#7>y7PB|%2xRB=xM6d0r0f?n&}cd) zs9bYCiZE&g%0=jF#EJI#lh`IMPYUR-%NBG-&B0lh@&dYB-AG6TZ4#?NYkg{NBo^jC z7Twwo$Fd=ARquMQPlvZ{sDIp94-oB-qIYiZ)Hyj(LC@uXU2n#@6CY}oAjCwZd#pA@ zndZ@wXa?2{wAU-lsS@c+zB)Q!=;7N{7QB-47JV>&=dfyA0p4$=Q(L2tm*p z_)XfBPouk&k094Utyc$L(r@mP^A_~?l|yG_Ow|VGw@4}!J{mi}DuYg;JJz6DGfx(6 zX)B8Ws1NEt@tBb$UdXAADP~JEmd^fhcy}>douQw-8Uyfu1-DdFa(%LZp5}ZhE0ADn zT^!2P9ZtnXl0&)ojJfk`Fx z@oa0dI+Z{1Y0N*#UDJwN!1x8-pHh#F_GZ_*K2)r-n0>{0>v4f;K+@z{YYhQb6Wu~r27(={1doJzfw z)3=J?b^E!}21x(eY!`E?7vVtG`4kGK(%au#_I8fSi$zU4khR9UM)j4@GLR}Omlt!h z%1UV^7}vf1KQmx4gnr8|BcQ$JeA9R+*o|-^L$Ia${jRB0uTKF;1cAytO=I1XNUOqP(^`Rd_-aq2JdVx0ea2YAR zgmR5#b8|a0_N>ZmfMl4p?Rub}mtJ+YjMl1(OY3MuPw}eyi1=yzrGbu8bMIOLxN6&7 znfE#u!M`@+PdT529{-rU9BZL^_eF9^!qKC6Jb#^gM{=KV01+#xVe!roZirYOQB&UN ze_Z)<%3ggz+MTfIU@rpK$|rHD-`mZDm1c;_>Y| zuImBCqsMMK8dK~}t*aUTtE`5zx8M zCVKI*fW5(ktDo?e$v%3c3zfUaH?FcWO?Y!?1NMj$4+34@V4Uo0AC#l9;&J3)seo1B z;aF*&C+X=nuK(AmL1k-Mb zj_pxaj^iwz(nm+_#nl=a3^*GL_jNR5u?EMw6e8pnc7xvd-tRRR;}%1jFY&DOk5`Fw z79@Tcz4}{4BskyEbwTb4)O&qN5MMa%Fy_5^1QzQnho}Dh(f>BA-b-q;X`Nglk$7j8ms3fbSPQl8>}DaCAFiw-&W}3>v0{(U^p?# zM>P(F>KtT@Z%l!V;0Fu}Cmi-0e_jn$Mju`ALc=~)M67iL_FH*(jiJ{6`WUKZ6_VdExv$n0BPg)sFOvI9efs*MQTmNLCCxRlzk!D`LlT~UFS&0+t68xjr)%k7kD zj#~cIvdTh7c)s4ZEY)TPDh9bTuWG$m>6W|DZUN@snnpQ zr)V+NJT{Ph2tSVd@L{o~r)!QW2k7OWH~R-kVw9SsxKNa-3s_V66zrCt)zxUKo1 zi)_{7@QJ0`DU)PO*UDO&R_b8UT(w8bm%cxsv}nA$X@`Sa;?nZ3nUimH7Zr49mIT;6 zn?|y_YD(Pmh{HC?n}&nw&aboVihq$t3^K2Wv^9{~ee(UH$L=}C|8k8n@*nwTD0dEg z5xSzxpVR!}!|2l(X(?0rFp;C^KVI+r;U~kQ6HOV&rhq%kx|c7 zE`LL*YUw4D^0G(ll4M>_w_kdJD;%U>eO(@VqJr1E+h+deb6PZ7Hf8Cv1a-}F6Oo0h zT2PmXta$&j)2uAj=gh&FNog#59HB{dqYX>5*%uyX6DD4Ldiz}O!I|;{Of(J02mk`#yS#K5}FG>Q!VZF8$Cs?31^AhN^=Z)qH`jLZ7kk;Y{W8a z_EJl;;Y74rhP+)J@^DSVe{f-qiiy?TlSfVXtT2n=>HqmSemjMyt=s z!SQ)mf@$aSQ2yo=w(JR1hmaaWFil0SujP*$p-GPkYjbkPm!n4^n|jnQo=mU#)`B^D z;DzqB3pI0}J*l*uf+&I%kgPl1HjQ^5DJ@Cv8Y%NB(9GFO$e}m1PEqPT&3y)|x>D@; z0UO=f>Rf6qFObt2G&n|S`KCb0WiF-X4FR*32Rz*2Q>>0ROd)dMf$>jnTGCbfeS#W2 zKH~!WZ?zzE9|}OA&39kCyUlv# zRpE*TikET0pock3ivB{vh*A8`J-$H~QI=^>pdVJQ4>p{|yuVMhum|-ncNNlZYyp_S zT#&_hBAxHZ%jG-L1nFyAF_$?k3FGn)WF{aXdSKuQ{Ce}QTQAG^{wo@Y1pEZ2k_l(Q z`oG>h{F}`#0f;_OavrOc=naY;9G>12P`d-5Hs<+QfM^YhS1N5<^N_g80wnEknoCOZ zp@n6-pFBzS%k=(B;D7y9HMC*GDHZ}qH#4(4jR9%it(*3f>eSZvsnCB7Q?ilV&LH**&UBGu9i@q#bwSehk8Bnlz1(54A;+1empH zj%B!Z7y)*BT}6!m697t-;Mh;;?4{Mp0$zo=BvYb4TzMNe|3Yvfta86NGK`y?!tGmv z5zqP3F_mMdJpaanbj(-qe0p=H*!F0rXYBULhXpt8epH38HeYW~oJvc#!u>9@pwkmt z?{F_Uw$>I!7}3U(W|FhxRI()0yVV&dOAv~cR!4=4SU9x>_t{9ewTcFM3VlX`WzkQN za#g2x5~PdlgCZ(z3F$!#Nj;ZQ2&SPtAlm27)e>Cx5(CeR`05*5+Zxjo4 VIll0S`-s6~Wod8m?4*KLmQA-g5fowkDxz8U0*&tYN^3oE^wI3?p60ytoP~d(@%Q&QU59BY3l9H0Ty1Kr; zzOAioSXkK6inZ&tkkZo94+W6nvqC}gskNgo*VfkJ?ngl-a}~~b9!`KjHmR+*4gI4; z5d;DS4(xLY#8=GUoXwiKr{<1kY#pKZ2s`F?gBnGK(A?Url~0uE#!;^jZ-lQpDfmc% z)3g+18-is5jaMhzD$=!Ofy+{$dnUfhndV{`db>{L7}rK1tCl*{I}^tHWh zBx3y#NG+~zDAmwyB8@xPX+JpxVkmf09ntBj1IIp{Y5ld`2DF{G-A5ZrGQgs9W9a$w zX^%J;?1qZVgw1-O=(xail6QEnZPNx&wSqBUnk|q=V4!36j`Z?sM=liZ;>JsgM-Xp5 z)%yZ>7HL)DqrWBET_dvG5ky&(!*QJ5^ez>!=W0W*Gr`E$QpuU1`%Yyl37;*9C?gbT zX9|plmXyJRzs>0alY{fg{rgSi>5Rr<>r;BbWX3v#L1jOb!QcOh=JU=?b5^H!oz8_s zf>J56p_d8`AwR)(fyb*~n)%;gzaG$SholDt9QdkC50GAmxGr!^7pRv+$j?-7)BTC} zCVIDFO8*R%R%cZ{rJtXklOJTNN1Ya0ebdM6T@ULs#TC4>!oNr49-XP0EQNvQG#I`+ zv`s3l3+qhPkveR^k_dCMCTDzBR2SA^$YdHomhSC#&K zImBwJn9rpostPg%f3>;rpepNL*M%&udoLjT5Vj|(_Gb!a2PVWkG0mL^CABA~tmyz| zoo-a`3SJ7_w+ct@NTrz3yb!C#m{$4e3ZI%@RED5Dby~_W!7idaTcFtP=AaXu$z4)>xm!KEZtchnxJ%1W}1-$t<#6p$mBh>Xv*N{Vd}T z?=RHh)fhcb)?1X9!+>10rjylkY@g_j!_+lZ6z*CO86Kj^2r7_Evc>nMi?+uC7bs`( zzGp6r{GOiUFGugyW^D-uQQB>&Oz2A!rFA`=%>IV65H6o2l0odId><*2_a%_7f{ne9x@Ij5(2*t~$FZq@k|r78BnttzBqRaaZ@s$ly1$P>fSa{2tVRq?N5;Q^6kBk<2;0kve3Ge6>~cl57QziyDB zcW6Y$Gm=h|`yT0I&Q^s%_JYTiR`FczPFwctU_;uwzG>ZDu%cC4n^1DYcQ9}cI$6>`LVLl4ut`rinSC% zt)o7hw4||+$WIgPe@X6lz?Ig=dATU!@%Dv*Eoff?A)Ii!?OuO-t5r`9>O24Du6Yh7 zJlx{;!$(=b6V^<&2O+6>Zyv3!@P?qUR({g=42P!bJ+E2}`ejW9Ro6q_424c01$?qo2WSEDNN!w^;h5b|Cp<8{>UM z7k7uug!p=j!$u(V{5bjBhxjIAM4MxVf$C}LqGG{I#LndH|AGD1{hx#mI-~+H%n}5(sw;G@zNVH09qD?@lc7<8O)2NbOMVNb0gwO9kKJ;wKc_gAIs09g?AJ zD3#kaQMR8u$t(SF5cYQ}f>{0Ht`cdhdo^*;zJ9sT8A+ymi9Tm|5rf2^=ZqVXvDux% zCA}4I<}bplI42HQ@6&e#23EOi_|0ON_1dwm%cESgsqq1q@zv6MeWdh?i+)Ht!{rtx zA;z7IMKB%d%!9>g4NQA_!;|oKv*w4M5W2^s#=(5>Y0TTrYf`}Y=P#?f-VV;}-MtDU z=NtRAr#lgJMVi! zaSw4Lxb1A?QyyEFWefUtKF4L}r)Wpi6jr!&Zl9Bdx;0j9zl2f7o5io=?{A*76@thk%86C+(@) z`s>+vFFnBNF~tGr?X|r@ECpPbcWm=cx%jjLo1#~tU-@ul6FGluY_6#Md%zC{x~9Pq zhiclfig!>;FL34b>!D|h-8gOB`Lhh1t;8HRC^|Sa^LXTuJolxxQPf4DzcWFmv3`l> zl8n@pqBGsA`NCqsY=RCHFL$)m$_0+13V>t3w*M%wwFUtX053nF1}0^qrPItVPL}StyErXf-sNSJHDSWfArj|aN4ePMW24qkN_QMp6qZ1Inlc%If@KSKYCI0_MYm@sjnEICew-ngpW_QJ*w_o} z(x${gceB{L9`3P_nPstW&9fmnYC8={)gSh6Z&n(2)jrY3 zVn`2o_T(()%}n}8n=*ht(Jn_}hoN=ImL9$DHm4KLd7`>4`>XK}U%vU>_t6Xzl?Rkw z*&Zebq-07GLYiT2-!l`;LAVMSuTJR>k|L8Hjmgkjo`2twA&{E}qHtLsGci0UR$cO8 z!bb%(@^z|h7-~Dlo9PTzUQdMT?+iH5H7^DbybNGuOQkA7^~e2C?AEURDdb>Ty7mP= z1}?^sEw8-&L;O3K&c0q;b+k;4&EEyzMAzOQ^~juFQey;8jl)iQIgsUmdV{jL$cueI z^Ub2#t(u22O?o52As>%Vm*S2+*#%`}1cw|(ccxty7l#^tK=(mF9g_zS=79rw@9pNv z!FW@IEIG=BsR~F#8JSOCjyFIV(m(gO@G7`oo;-Qv!OrjxI4I-AFB`YxW3H)7w5o@M znv)yj+wl7}Z&$otc1u0YFYn~1tML4&=giyhM6_PIVZU#*bF9XxHs|$c!_{O-HWos= zQ`dZhZNS>gbRifz`7L?%#zUPd3I~(E>veOTJ+qfjfUKL0$@~ESx^oFDzcpQUzpxw# zvM3B3Zy-17<{p(#1si!efEZ0EUD)-)lz2DE z3!X18B3Z(-x`gA?b0skchC~}d<}ozQw)zRP_pG@>If_(a=9ep1pMza(evlH>7BQ^W zk&0H=HNCIK4ur$s>*~oo`+ZuCtv2g(b5>bNRw1BW(BX8m1Zusy6AJbW^88?b#-$NbFjO{;f@=@9$zv9 z+`sEOzX$4VaA;7+?&gdCGQJ^;w&++~Jhr6KM7L%sI3*Jy^j-voB5$Fuk?4%!QDCRq3@p z&B~_+mh&sQA@B0+qYe1=%bf_M;CdwT1W@|H(3zmex;{Fc5>Vw#P_Ewn9g5xDWM)R~ zUUC&hzIsNzmERz>deYP%LDcR|Lr-T4yw%?mTf!6xGfL2o3;wKak_C6r0=dfIpNP^J zu+t~>yukJ9p@%Dz%AcfeAc@YCb6Q|}CEi8{%Zd^LMb*+xTT zoTTp~NfqgQ+tqNb$$v zZa0F)(v=x~WL~O-N-*vm0}*onKkoal(E&>H(pdt9;^Yh$k<7Xo-FXE^4wjBJMoap5 zPRvoTm-JPN&gDKatQ3YWANc%!6KH_^&y)X5#qDNI$8A-&5V<%= zUY+13L6<_cLE5*kyS_+R*|A_Mpp&SxRU=;eUm*S`<%a(ny+8sQ`W7GGo+L?1Admz5 LefB+cJ(Begs{q$S diff --git a/vignettes/teaching/plot-teaching1-3.png b/vignettes/teaching/plot-teaching1-3.png index a614a261d999bffbf0d05274802f8ca01493472a..520c8c372deb1379ce4cf8e4b5b43772a832f012 100644 GIT binary patch literal 5733 zcma)Ac{J4j*H%O z$;gU}YY*$sI>^1td9n^N+uhDsn%Z3Cs-5Jj)8=X+h=_>D$jE4EX*oJN-pbl}R>GB$ zkPaHwEzEPvxc^|LgpOgxyU3^f;tHJqm>?ii4KMx`44S-k)5?Q+fC8o zLVdv5Sw%|VukpTrSn*$2bUMAS=0g5OU|?l?EP11wG9!tNX4!wz8x#Pl9)~==s7sZ} z`Pkl$WSJ=D`2qJjSScw2U1()E-(QcHW2rJI#s3J|<|JonsciKO{?#eK&rgNG|2L-m zQ-J)WnpG<1G3Y;H{O^OqkYAH8<6*`>Uh(2#2mZwAnk&+QiImUppmLERuigjYVTM>b zm>^{vjmGyROSJPf%m|KKn*KAz4u+h7+ljm-5D16uc<+dL^-@z=1j2#N6qh;Ow-<1l z^L6#f9jp$DT~NsRf%($lw{p@=aL)EtI_EgpS#pQ-OO?Pmen%Rf$*POM;L{T>{7okF z^;#7hOh+=l>Pl1p#(gFK-oK^ULAs?t8$8aXP~8&6IuP-viZ+&Q(bsp2IWI~;GtpOV z&cOTD>CJooX5Fd^^BkBfa?rbE{EOy&!)8<}H9_hoTyU4h_Mv-~suGCDQKl*T5_UE> zt@oW^qOU4qs-Y)k1Imybr!x_QH7eokE9OG%fOHPPYLn^0HM5* z-XavP_i@7~%r$i{h?FKT4-NKNk$U3AS+d;mLJZ;eugL!8pWE@nltV9q>`t}$uF>iX zEo~Ntzpyw@q@mgonBrCEw&?f>)+1ieHwL)+eSsGGxca~SsVG0W=jeZyFGt_vU8Ho5 zx!oWZprEPiBalCpkHHT;c=l5!CsuE_VKnwqqIv(_AxlmtDPSJ}T9x>5m?jm$8ji$> zf_IDvRNY~bLsh}h!1x_T>{5jWkngT-r@-lvYT9TcL!A4$0M`f%1Wd?Lq~s-9SY*@A zdzj%o|CbwAC!YQga|#T5b~i}j5k_=-@rnR&`mby%s==_qCO$qqBt!{|g$2h&SzED3 z9HOT~c<=H8ron%x-nZ{2Pm$t1hHFBDB2~fs*p+gtOMs+4p_~{jo)gXD?bhMP(+}>Z z$0bsL%sfzGAwa8-9@OFn#`H&GxoBI_rb`D)p~I1Gl`*piKz1mLv-4?J?GXAVn4AogdH z?7l#Vr>e~!B{FJ0xHjAYK+{-S)oTAxN6#b{j4(ZE4Pr^z%0}evOW_R$2gD?`joB)P4dS=2zzUfg-BRU`_n7x&oBY0PZnjf$xhZ5q zVJz$iGqZ*D;0LGrBJO_my8jM$x~IJ$RKFHEJ7nkQhpuw|eBH&z5w%M0^ax+4bjE`E zOjD$p*InSA^UZx)U3Y@cEosZFoEBs$_MRjGKXFl&`6dZ13{ zr*JrxSWFneEzzvc7P9X3swK*6F6qY%Xi~F76vvHUT2Y9u4YuW?%A{NdCe;epRu({s zCrwSmZmQRwCo{X|V9n-wIH8@bnTb*mt@QT#j<<~kqCWcpamWNa)Mwc?gs&7fCsvtn z>$)7R5SGqKekqrQvfFD$H|O4cvRkGC%zm3Q11RGJ#{~tMoaD-+T1uBmqYG9x-SO4^ zUB=50`rxgXjlm1&jd0aspTQRH^F>4NRH_&FswH*27~vL`W!EDxI$rk1>em?y_0jg1 zw;^RpJJUix2CWSAvK2}w9s!Jj6wj79w6j}<$@h~6P2F6yIeCr436mPPU?)~P*wC~) z0UG;vea)phIG4}!=w9EEh$@`9fD1jwnDEtV+JJqWI)*2LVxLtVf?ZqW!V{BA_dNeF zVIbY4xg2XM)8w#w<3P`3p>1=YFW>_8%%9>_4}*X;U{>}Kc2}?C@Zw=e95=aNMmv%P zeT4_D9{|?$?+N)pX$#R!A5_;a9_Ioc;1iSr9A%H;3k@Gc0W9i2@u2%WyJCStnhVN5 z>yM4nF77XoGYk^C-Bg6R5en!Z6p_AI%`G{Ilo*w)^B z6X?ErXvnF}8_<-!GwHvx2eqf$(}iT{&yF#5Wxww&+A!nWU=obkeoHdABviG1C~Gf` zh8cycY3nQ<_m+RewW2Z8CLdmOassh*QahNOV8oZ3UL{GKyo3u6pJ{M2DgjF=VQ#Mr zWYOtvU3SuNRHrGv(7GuxMNFycF{|RCKM`3uy3%zq7ygbNx~9{jRmhkd8eJP0@lOxB{Yy(D% zbk;>=n?pB)aLGr?`mi2RB33v(RIz=~Gu)#MR(f+`RDs_pJ!@7 zf=BJAgeRX7-o07-NEm3qv||0=>C4vIi1>%)|xBGa`bO87}bXD z+m4cFr|7P;Umjs}vL=ksJxV~rxi*#Ef0MiR*P1WeOG{^ZdXJF%ZzU2@pF(V25+TAg zaTT)KI3bdy_=;H{Y+BfB_zgU+sTDltm-2EvF}y{n?zw$ zSK}s_)~}uD#h#Vj?>|-Y0b_6clDV(4N#Q#$XsOgE!>5(s=;M$|BY78ucN#ElV{r(@ z>>q}>hnB+Z{&{gGrYxgqKTu{MNIV8xMCEJXk>cS|st##y9nG`DvzbL@2721L$ItwB zUWN9Bq)mu(lLKz@cT%%wwCCYHl^r$j57N%b_w^n8cs6#mv9mmyby-|tTEXR9{oc@Q zTV5d5K-i+UP}6t4Yaa+t6uG>Vd<|N3u714iO*G33d(F_1<2%@$Qs3(;K9pprC;SxC z5m%7BF`<<{?grXuFw}!w-q^l} zdBj(WRNBSqL|zdy_U>T%#@g2WEk>=_s%9$TB+G*~K2CW75+<&uoeXO1eC5DJD?KGk zB(&-bmj~Ovxyu7UV`MjOt(E89TAIESGbRdp4&e5Z>4grnp}Jx-NxWWbI4EPYFi?F# z`i+DpMUOm`Oknl@TzF2^`YO6|0P_$7Y9JHxsB?W`W5koCXgqU5!M6_bB@3>Jn2{x% z%T*(9HA6^8abr@hNXANVEC%+S=2TYQ71Cd+g!hZ!xl(A6J*K{p2@Mh5f8qjrXvl6g zppxvINWOrxZ)y^HF%ySw8h(=>!4i2b7>)o3Ful@$E;ajv(XGhH6dqGZxW;OUW-G8& zK5}{$Mok0SO+b;4DbD*VsNIwS5&g~YSg`1VW;THumYOD9@ya}6aU1&K|ZG-j=W7ekL zUb>0VzX#+qpE1+J8CChqcaJ|$&O@E~HD7^1vF{Zj1~27c0OG)T#yuf&=0oA2+e_zs zm5|gh^xz98L9m~SxcovbJbv6abK%l(ccb~;z0Sxb+-c>eJK`kwslkl$lxzo|QjA^N za#L2nAN$N~M*{IczNz+&7479DmZ#9KZ#*Ht#$++*PLcLDSKd>e7udWj{?usJQX(D2hSBn{Njo} z;h&?R*jIo~W_b;dP_#!7gC8|7ey}AGPnwQcno`<_n|4A&>+sv+YgCKJ6uZ9GYgvt< zRak2#w@=;Af$>%!#iKt>#TfxrVWZn?+Q#0yvnce<3Ic&x%TizjXF*8wH{C*(G`Yv! zCR;}%U7qeJ=$hy-MQNcK$HL5g48RLEej#4%trhDt3svgBQ5s%b+Eo2 zNuKVd`D&7|AqpS6wo2Dr!M!4jdBtp}MJ4+Lmfa>F@`^{2JzI6L?xv|g^zz=y`E&$- z=%Nb2W%DWt^P=XviJuN}XtK6dh1oqX6fWSRRYIDS(S4g5iDfUl=26cn=YC4MkrZ#0Bx z{-gP!mma8o*owM7nHa1xW8h1BB2kUml{zana=Kq3eB}Po*jnH6M=nw0X$;}|B6O@F zb3B3b{fAREtqXSOcv@nZDhXGDK9D2#L(*%jJs;2t*fv)Sx{W}GIXC(<77WBjfPydg zs~)r_MOWQP(JfEPA~os`4A`#wT@3vVjaJX4^q8$sk|fa?T^1QNl8*_bw^Q`k_E2Hf z7dcj($$9_s;}eh%qN$1dh}@SoK}7QNMv;&^&x%s$O=%VA_Qi}zGGA3kAeN+cWq9?s zATdttp7I#dR`-KxBFi z+U%!xEj>#&a-cq8Wdx^L3thvN>Z9AU=fnDmJ7-+f=70a-n9B0Sg*S$Ug|T5H(gi1$ zOE4P6j%JLq!RoD+#otW&_|Rrko)V$|n(|4`4Dto`*-MKt`j_^C-#gwzma|V-tumzi zo$%KCi$CqlTRaOP3X}P9LjeoQ`QBmKjU>`YUl_FDJXCESkvJD>Hz-&fXTF!F@Iv7l zh)3a_aC-NVw2qPDg*Nkge-8gIpOblsg*OYXpRe#~36gl8nSpXLeIMM2GdQ*xovJSK zg62GwcRJl#$$5DcAr7{PqJ`ElsZ}4b8_#v1X*G6-X}pi;ho^jRYgrS~86nhiL45cl z+P2tWjN8>N@81l1e}*kCb4@>rsj#nYLUO*gYGbc1V_Ia~?aVK1WI#?*;N&Nb%f4D>f=JlzXgCU z!Ry&_QkG(PgiyOKx&2|C#bd;iU2`^{w)SlZDG=nK)=!Noy4Q-0WE#ZV&sm$;i;$d3 zg;Ec8G1uO{buck^pv|bFVnve5;RR^CMT}FHM1R=xXf9y=e%!DVa@BrdY_2{K%sa`sX$G@}B|k@0TT~e+*g|1KL6D z*k}ItAu4vVWJs&Ftxk(>hkrJ6#7BSWURL4)@S)Zt@WJUYs;V)PDrxMFIcqJb-9Spv zBIU%Rml8sAOJBJF9WhF8h1&b67oLrmPQa@Y`WGktBUo1QE`DL0JgeB#+pa6YGs?>& z;IAk??-a&p1*>II@cnh&Gq;>a7}2FN2s;k@X?YaO>bu0)0IfPO{YiT9uli)Z7aKBG zxIX^3#oBeV$%Hbglx0B<7Z3;mJjsP)0_mUNCQ|TWcGCuScC5abU1iZjt3d=wEpE

%QJhF*U z6w6P$GVy6H+oAb&yr6R}^Dd?5Xn1+~n1aJ%c}8Qr6v*M7v)k-B7xIu1krwOe-Vm5q z<6WPMetR;{0qA!lOggsIn+zBT<7#MyOXJ3prg~o$>j&qqHK;DUfjW4@J2Y5Pf_stT^e<4(t(`jn^+P!k%lxSqI zNJ_cR-d)^rd7ansfgH-I^D$3IurQ)dv@J@lF^-_=p&WY1%+eC~viQTLW%Z6Y3$+cX zM)2|MxLCAeV_Zt;$GdZ-iO49qe%mrAb#C=!(<;BZkp*ocTOUb#@-<)_xo>wK?NIj3je%t8O}+d?L@iKaSO>)eCjP$D-j&2|H|d3f70Q?R?P14$pYiEJ;sb8;_ex>*rwUh5)+%)U zR@zzt{XKtkOWY&M!g<*WQR=e-N?tmZ5JWlAd==akkG%9w40p&RX(g*(? gPWu1jt}BSmk}q9S@J|`L@GqCiMRTKagPT$R1%?xZO8@`> literal 5517 zcma)=c{tQx+rVY1B)g(yvgGGyYs#8!Y(;hwvQ8z0Bui#AgBHt-ean(9TS%ESB#aRa zl9(bCnaLL;>-gGcFnHAOdjELd>$#ry{o~x{I`=vExzBQ+>zwn!+FG0P9y)%Ajg5`h z?Be-LY;60OztcgEJx$s=ztvuL#@6!k1-8Zswx)AzZAFI<9~Kc2k&=?q)YNoybGw$m zoAI12H#c`6oozIDiy0QMd+q)1?(VHBAAvnv?mHKqL)h4Ognp-e{bP|VHnt-iX6Fqr zBl8yuuwfH_3tVVc6(ofU?e0>Ok6H||V@OmybcbKq8QLAQXVO@1m6ST{w7A>MS_#4 z5()8W_^HLNtRBgKhN?sIf51$>IJ3RArL*Wg``(mb3M1+)ZRHWetpRt`wZObE0UMs- z2cp^O5P-XQf7ir|K!qyXt^uRQq*_H7fXWloO-nusUrA=K3s-nkcZ(=mlT5NPK@ z!YBSbkGpz|-1cQ-c73ZKO<`VJpmFma!|Pgk^u+<-6kWZ5b!V0Jgm0zDRXc&&_N zb_(nUu}*?SOvO1pJU^(=!PaBV>M48D0mp+Yjp}kAI<@BwS$?uAqg4#D-D=%0qugrR zLY~1_RJ}HA+*=<@z*Y5*?R%6u=XoXl@@T1JHRbHbG7IzO{NrsUNRR6>>-GCvMn;qT zQbMYlI{U*<`mgw28*FrjJigWZ6_sp*ub_^i*ufE=^RlC-*GSbOTk49vfrbWXt;?*p zh$g8}uf^wBi?^SBvChgk*n05@d$(F7rMR6*4y)zR&!)a<; z#tVAT$X(v+l&TFA5-LYu;+Q66G1M7D##V1sGY+oY7L8%P_=O6CV7j z#iG7BS)@7G&-d+Iy~oA@RSAoj-(~8+rE=A_m34yK`ZpQBcf1E{C~tLx-+- zD)-Zv$ZCfU`pvXKDN#fE=r1F*#tE3qUG0yk;F{sn>eCjQhc>h+a02cEz1KWBdy&Tl zNTEfjqAgdCV92o(=;1q{U69yFz!;a2HTsG`B9qNupoqHx+qb1epVk}FCHb^RJj0J{ zFCIJ#wzjr@$L#}?MMQSDT;HK(0QdK7WMFVkBxO~Y(@xo^FdNzB^AeH85J)=}>DOrG zcLj@BaLwgI#bkw9>s(m<`nelsc;@-UV^8R2|LCF&%;DG9bim>>hFRfX;}$zfE?D<2 zn{%2?zC2TBqzXu+*cSpt(hk-!Or>+9g1BHxeHnkVguA%_{ITprW4w(sv^3c!g`Bgz zywU8{N_3Mg=LYxTFS?QBAa;sissrCWV0UMGD>UQD50nk98@sDBeyOVhVi?Cf%=BV9 zvlbp!e_hid4R<)BmlY9HEfQd#O?QYyRDOJj?6zeUu@G<-qOWvQ?hg4Z@qxKZ-!>zz zm`*17mNN>kLO0&rG$EK)Y)UTJpADX5P*l*yz?lAzYslO|p1$#x=EKxfSMuQ2o#1qN)Rwy=`fT#8ouC_!JcXk!2D@}g}-!p@ojJ~WKiyGzGPp_qItx?LDji9%i ze)SRDTzi734GHx*(o#7-itoK-G@iM_sjH=OSj9s(?IG;efj6Bb=v`KsHSZ-Ij|z>M zysUv=$wJqU0aN2G!eCFAa@m#6Ym*&2D85+j{N?K~sqSDc1&X-fE}h!?mNQE_lI{wb zr;`Fb@qUO&Rfj>#4wU#^R%=umZR!;o@T}3h(b&6lduVW(%+mYvm^bJ%2r=;ox`ZO_ zQS!G;>#x@}(}LEtO}cH;?%fv2eF)1u0i@(bZ=U_I?NcKjcrtJPdX9QZQp3#sTIFnX zyd{GYG6YTsTz9uMk~rDd=L3D*JOUYhR%vD)Zu#XdA*HTc{o(`17P6=T->guk$BJGK zN9xJKfq^HpRMeL)tzOZeE=lmYu=@4MUMKXyk6}$Z^g&Fi6oQA+|!J-Gk7_dX@MUcc3ytcX>wq%y~CWV_cw^+Z++J=j;q~K-!jScl?>WmOiBxZ&A8z|c@`PKVRJfk{@@&LRmnsGd`9KWV zVSQ1&ZOI~5Mh(u#+TlUp9hE$aMqPu)!|e6$W(wLKNEut`d4&~)YaWa9?YdTEsmU1$^J*>;WFyk?go927Fr+Lk>=#Yf6i? zBV9#`W4(R^Y)Kz}X4*7eryZGHpQ7Bh;VUq*RyXh*o_$e|s@!zOLU`lcvR0We(m%ppM>=-Fswk9p=VI*A!J9w)E5$jwHg6jQ$G#O4h$=5(<|Y0L z^dIIDDR5+57LIb-iG8c0DWW64ARJciBow76{W-JNqLl}fKR|wtLHx4d753uJA9)l$ z3rGZqT#a=aA2Sqrs!TC6czSBf;Fc)OUe>`4ZB1|1Q@r$SL^h^FC#ym57$q!?&wT5K z$PxNxo2eJlpZ!ehC0oJ@0rN94T)$NaaEiw=a`=RA`REVy-+;`De#AJzP9hJ{Zvta> z=Lyv0JHDjSx(0hA0`*zZ_;qWalDY;v146jxP2RJrp3uFbW`+ZcFjECz)pBR@n5xO` zY0~Y{?=-p;q`e8&6}}@HUp4=NdE?l&(+}Ucrx$=t`7SdA4KYUdk+xOQ(fnk-dyC}} z3p0Z=XBgzty5Y~M%n!UIB}m#du1*FP++(mM5^;IeXHzgRN|a`EMo|9=RRga}I38&T z?A5zN-i8409@R$I$UvbZ#>iPJVS%zn76amiL4u zF%ZZ6V5)+tFux_+qB|$s_}I7vYrjewk=YNbW+3F-r?+M@Uiece2lznOL!L4EYxJ^o z8wVDdY?C$GZTQe*c=+Qz^~1G#;VYf;p5F~Gv&j5XE8HqG>7+7B$QW5&c4I_3&0B(O z&#In3=!m0TOy~_g_-JM`i(8jk=kHc2 zwbc#ny$eL7F6v4NsV%H`thg5EAQX!%0z<&D%2jSmtJU}!3D4}A3PZQ@&VCy|xm#*V z5$r&q{W*Hr@{Sd^Rs-TRO*|X+rGc5_vBmC9Kq)! z3oj|f)XXujD>a#Uh3g2=KWK|X6+Q(U8xRz$!&TBm=Ha#&g!hi5uq6Q+6H&rWLOm@s z;yx?DU3PW%p%H<Egk%14@(?m+M4 zKTRfcK2AQtA#l<%{Q_$6KJzN(Wwq8maQts0;ic0CXpzufWAup|d*amPJ)x%7tAl~! zy&s%8)k{r);?1#YB75pX2OU=hilQMMrOAi~ZiS}RFu|{%nlTl+NA38o)7(kI&MKG1 zU1$X)nI0X(kAz3a^3G^ZB?2n+zhJu&q3jYX)+r%3b^>ROJ9SAFCeH0Q zG&o5WokC&_vU@Z7O(mv3{&KHx9g$_c}i|BgHUfg=b^k1d46h#UB+M`9fK%}N>{YD2{S9hR6s0&1^Ub1q=J zj`vFc)9V7(R01BozvGe6|9Ht10$h_fJF?gTdy{SUs{4O%i*1+Yhv8wTb^oUhR0tf- z^~o5G`fUI^)b6SGatQ2x?@wbZZ4P56Rq$8labOxaK+73N-6?G%=hzVV&bsyGy{rEL z-&9!L(L6%R_>16q95CB6d4R0hi-5KXa0xa&F(LE5pzHw9s|(qo>BBHNaY)raYkp`J z`B~yWF`-IKML*PNzckRj8lArH4=j?Bj#R<5~D2 za?srJM60u=yyw$CrG#|%CVW%k2YDKcCNlC&lWmN5`0|HF#+P9BPp41Uh94e~Ek2(e z&<{X3>U{t1cPi@Ni>2aEl2%450!6V#r6HvomlwZ>lkoxYs%y@&UwR=X&yutglDbOs z^aKE)JdqwS#T^9NUxUWGS1aBe28Ao9#7ma)n^P-QBoBCX#F5h2o&VXSkHg?iK;1Bg z>&O`@ySiilJ2b~-XQRRL4LY4Z((u!`pgu(6bRu)-nHRCY#O#ZEmmaBEa%=8w98&Ib zy!zPy!yZ)28fd=i_-&x%`c+O0&TJ4P_N(=!sTKIE5qIzpfP1K2D4*G0@c2<%ybEUd z-8J4l8urJ#(i*vr2A@Sr0irijrJnBjEPC+1xBn+@v@)4q7y#tN(f z8ghNw&?|+y4-ChM7B$~>8r=hGGj}!_xv-8dGCKPIVtl{PUiaQ@v*7xh+c7t0D7x}s zNBbuOw0$Oz5*KJ?cc$bDgCbR^m`SqdksVemBWYT$Ipc{2XrWnh27?R8VEYqpwkv-| z{lAc6Od4}1&L!ffOkvyPp_Bh0NEl$(b@J*d$o#*bssA^Z+~v5wfXk%)Vt>8INZHIT LSf8&ky87^65ojaT diff --git a/vignettes/teaching/plot-teaching2-1.png b/vignettes/teaching/plot-teaching2-1.png index fc8127ac0d952c899361706aabf0f781b410a1cb..a2698b9d8291f220c0af5418bfe5f9a01170a92a 100644 GIT binary patch delta 12967 zcmaKTc|25a^#54LKFJnh$d0u?)gs@bme8U$5Wqzu$em?tMM4bKd7U&wcK_&pGEg=N5R?dZ$Wi@><-oG64N| zNPs}vAdnYG!UiOD4W#V_(oO~G`h&ch`1n*$c@iKA2?-ksT^k9TI8_89%~SfkuC9L$ z!qL%20%Y^QEZtLHoK0MgBSJOp!(}dA3ICj&I2(!oq4}rHc`+iV3wbik=)`ZcyH7QR z^az#}R5u1RkDKt>nvPa4htzvby;omb)vomPOl`ZF+-%s&-+8ikZd2@ej~0%OC7m?a z@Jhkt%onI0{TE^D_6h0gTpdu`pt}w=IpeP~G=r)P`Tv~&S5&FZ87ije!!7UN3I&Gw z?o{K3-#sy>Z0L0^w(?OAFb9+;L#G_;E0`rlAh_G*g4&j`2y7fd;SneONe7E>JA9`P53`qi!7eXW_Hi?v zXJ?u;WUz+YAHsJ6b6-DHcTau);buigglhB3{`krQv^m?2$E+!O^#Ma&*pFL&U(3;2 zxy@sO4za7@c!4u?!FO5fyqR3CGY;G{=$*zR0u6f6JSc8%rS?qmi0(U)g4{|U`2dNC zj$&Ja+8ZfbYF}DAjFMEdk}VO@T?OCoW{L~E4j8uwNs&hSHBA?tRYHweawvX-htS0p=4AAssC@@oAFeI9NuT_Ob|ptajN25oy&uM#9Oq=&%8bB zU-P)IAp_;ZMhyy2VW5tE1fO|l4FF>4$sL^eQl5fu1sf z)nkaj+a*OPO7ZaUx_XA|UWSVZ67KtVwoOKcn`B*8pb#`2FMAk~;-ip9_z+PUQnR`c zr-$y)Ia*3$p(y{#;yOkiL`dZ|zIy@*x82>s2di}g{9tsa96K1;qwE3It2Nq*8DXA^ z=dpdA&e%wiygzw5m5HWI!=At|!g^)!#Z$4*c=iA@j`MnB;~E`a1%B0{DQRIIoquWl z{2xrJFttM=lpSK+8(x=DQ>K}IuY%PVOaz^}Z1&?jp+n4r&y=al+^^)j_c5(EK;C<`v^ zT?%1pzUmMW7W;|oy6Akp2cWm6<|Tvj+XJSNFKB>Q*L8&c3qC%3UlB8`I_O_WI}gnCbH2&=6erQ9Kw=Q z5-CY24YK4y0{iPpfzHkUml2zo0kdgQ*Je1HC#)6R78kBxs_83leIWromjJDN z(wEh?o?b0}xjYDO_9${%I$b<_61-P9-9|Fgbf~CkkBI56#t96kLh&$k(*;g0QYX zFa@Au{Jl9J)2GmTLY=t3Fr~g7sVe*4UCDhMsVZh+{u(#0Al`c7=a}KOEFkU2$Z%mw zW^(yDE~8hc(C9J?2aL?hM-)c}vr&(yhU*!4LWAu{bVNqVIA8NkP^)C3obD6qidj(7 zrv|4_RWnf+ySQ%g#353vg^+8JWgaXQ^Zt}KZ9#Zn(@=vO*WTr7t5F0)@8zCBrTf{4 zV@ycC^D!B*wqws4&4qQ@fS&_1DIEi?3_P7VhY=@tUMBa#N8Z~ONIOI)T2-DoOVB5& zjb(qVlPF09#*2viy|=&duXhCJ1%suTj*q1_WObH%j6LX6Dx~|p_)2nFoUO@cDAlX| zcgNC5v#ADfb{~SV29xubfC;^*%s>eZtfW!K;CM7>=gJy(RHbML7>%{9>wKA2kV@>L zD-Az0v(C5Mz<=f2?&}5fP4pvW6LoeBmvngfTnE$4y309v9mKycYQhU^uN(1tgv}$R z)o7<87W|8arld3bXQ+3_a!ON)g@Y$KrlmZGZzXYYckEHZ!KJB*Wee}d}jcxwWx!5eDj}0jn;STr5mzk zvbtqqnmxSw&mz5?iINnXuO-SJ^~kY~D37F?Od)U{{a%kgDXLc&U7`L6KwLgO9d0T=PhgOEESkm+DkYLZM` zVGhcfVL{}qwQqqOhoYDa%gml0LJjV|g0GqcOD;`QxH`a~Hz=W#dK&tRgtM zbG=ykg7`*s!P^^UQ0yClazn1(c>chnLT<$Qb9{NR1lyt&{d6B5*s=W6i8+FKH@#xS z>((KujW9-5fWbX0x4gK-KMu@@D2CV<&tJ9(;Ss*JMZwt~8Pm4kGv8#w z!~3}4HH2R+87cPH6jeyJS_x`*nejTD-k{4^y31Tx#icU4CUc=f!(mT^);my_HMn;I zBW~pnL~TrqP>;3B65pePn8gogUf~1DxA@Js64;fJnF*HoQQ5hCHDTX>TKj);dxg13 zH*NFQH%sodnBcUVEhwfJpp3O`6g3xW?+6~^!=jH}Dt?|6V4VHg39$w1P4(-hCxvW%NV-UoXqfzdbOtDG z+kj(jc*1k_22={c!%Y3n@W|(*Q(05A{adSN%|RQ|Hi-1S7{rSX80o7;{6Y2WIs zQI$A|ELBnsg79}r5B$8?w>WbCT;)~X0J9CTC{UdQzASZ^;n+}qw04Vn^+nGmG&kIvGGD)682SQ=QV9kTWsrR|SvocbpeR$Kb+gKw>M2JjxzHQ_VV+#I^) zOZq0eJUy+y4w}v8QDMsUq4C$1$Hj zZWq5c8z{3nXAG{NJfv%4V8oO4$`}+MVVkZ?s1JH|2%;_`8&&_Ex*be$-uA-r@(yN> zj1wboLd0h4qeLDm9CnW2_d3fMA>e0>9gsi)hB6l?3tVF7PoD?vOEOxchT4px&S|*j zuR)wBi8h85gY^A-zqt*75Pr%>sf)bWamvEfa+^0J<*9P6qwCs!ctNoLTXjNdH_nES z8TlEn;uLxgTP!pra1qmkQ4A*w%<=+1^98`xEI z3#)9lj*gN67gl>7CWK2;0j56x10QG{8%*^dSFz_=a$3|6a6=;iS&Wgd z&~{o`^oH%OsM{akFw~YBB# zE_MEgjVEW&icqmB{l?xr$Gq6_<;tI2D_torP{Au_%n%z09yqedH1pvXX-}bc9=GnckC`dlXGWzo0iq0 zy3s)B?dN=iF=AQGN;%}6e-gtCB*-U1Y>^&e7gQs)K{p(&^N(4Z?wAaKtQ7fS3^m9q z!vgGx=S8zy4|X3aKES2d$^llZ~TT(Vdoy!%4W^<*L~*Y9^p!H}RAA?nL`=2S@j0`${6Moa^uHzW+1j*4y{BO4MxxDe(P0yE&-#FyHe=Xz;joX_)_Es0~cZ?+Rv+D!N;p< zqK)_|W->Tdk6ZXZ(Pm~?Vc#sQc;fmP7c$0jmepoTExysF5foUy&U~Yi?$H~+XC-d! z9F!7qr-29^^l{lsx+Q@1opm=j2Q-6OB%O>`s%uZsX9m4SMd(gi@d|In?Cl-1P*A4e zD;sOn%{|fSKL}%|x0R}u>r^+RJ8HG>`dQ@~8`ZBH3HZ-{#f3o+q@o43r(Yp}S+AxUnUh*Tapd;iL9qWGBO4!AIgnApGJ@;JoOK~3K? z0#Dw@_mX6R45eqb#p)ALs;+kPK}5!}msi|*ljn-7`n&3KwoCQCfAW46Mu>dHvKlLiih5{^Q}P@Y(r!p)cDkn>{5DzXdtD6V-_Vt2|9Z(ShUu_EzrRjK zrVnsT4A}31a}Yj!QNW0UR(mV!G2zJcw(?T2MoE%8aMbovZrt9&6KJldtVjPgv7L{;BWVa^IJi6B2HBfJ7;VMNqZv9fmn$Fx#}H#?)LU*#{}4} zReaqdU}qWmW^ zb9eGgXvnuCx~Lf0T)}2@`css|68TGP;waT}6lSC%XrR73duMdMu(i65LCT(4$&n+Jg{3%xi8+tuU{~n?9^U#rK`r7k( zuH^~J>}%)AP?evLV#_$0JSbR{J19nq zqrSCed~vG%N+RWKGa#icI!B;s)*&4?3~5E)vT2L={d?UFrzh2CM8-`M+JJFg@)KsQ zWnAUbCuhmjVZPf>7mh!uY%a3?Yap#X%D?nYMPpf+lszZBc>Q1$0cYs7)Q6F{zI`jv z9`k&eNk2{aF`*tIvs@>1z)EG-{*LdeUs$3?oS6$2I$XmX6igtjw-3&f1sMuGyrL6T zsJmfbWE@aB_C!F@dwK=41b|$upRNf}=B}Pgttq&R`EldB%zOTzQv9=R> z4Kv^JlZL{!b8l{5-^qh?uHu?8-XQ3uJFgg>XFfS4XO&cY=l7@*LuZ`=zv#m!B5x0B zjU5C!S(4&?c6a}5{fn=7qC-k9n1D|I7*!c^zlbzI+nI=9#%EbOngD_7*DfLNTKB^r zRH9`o_XHt1YNSisWBU$WrR72mF+X+O%nyju=7Wb2b| zi!}yCE4>cSgq8i9J1ydC=e*8Q-(=5?BpLP|Djt(txg`zNOYtfiRRaAMRz%q8G*rve z7y_ljFV2iu1OAwr%fQkE&YpOyJPOZ2>}OI`shX=lpau@wlGhAaupPk>+kqWBFXKpq z(xPh$PCM@^gcydcRVs27lgBF2j3|#JaaL4D%qHRMpayx7wqCU#ykv%>RgHggiayyT zQpti{b#%G|ePledfLHnPk2_8d@XM6UngfB>6&U;rY=Wr<$3~$>8fAB#x>n*MgOOCwTf+HW(8R-P7q(|e__5)26Jy^CxNcB+*J%5IDhRtU->u#+^S}y+c8GoUXtRr zw#vf!OQmG0@6u+4tRwMO{_IiHte{9@P)UK#dkugK>d)_C3Cdbqb# ze(QL+fgDG?bmy^6V9(W+jP1K_Rxx(E`l`K@4bxk+Eo_WYx*29naV?dE15KC9bV@X>YcsFi-+U<6arK{>z=Q1=#PEs}kz+)x_1^D1o{#BAQxZ{Z z^oX3Z?p{J2A#dqtp=e^92DMq9f4p`GNCFk!x40)L?XcV49&V*#x|8%ofl|}<)I7Jh zHHRJu-hF?WTM>eK?U(sS3u)SjHhIdvQ+>I`-7xIxcK3(P(oS$Ei5GHCbnYx|DohHg zAL1g%VmlWRhURrqM;>co5B>#kQRdX3Ot?{$@3ln~X&lozvGixNs+OOdz+(jwipwssCLa8?u;yiRJt6GXA!;j>PrS>o2c*2B5m&Z!R zX0LVn>lACGdC^hO!&Nx}tbmDg;Qm{waEIM@mm^B*Lf-G_l$fcjPV3TkJv-~mV0zy! zPWe6Rm=WhUMT7T^kK5*d{`O7j!kc(}JAMyjxAH zX0ZafDLM5|w2>3<#tzIWRs9$K;DqZ=L*BCRSKE$!413}1VRTlJHjp)oKS-tXSW8=V zPnD~?R#zAIzl2@+X1(-zs+U(HcFFh62}=jBK6;F^84t3n6BLVBBlSF}dly#=Vfpjy zl88!P0EdVE(|#FL-ZQoxpfOw=*lTL{%UUDP-VivhT>y*znL|9rQbn^syW6=f*kE`6$v2e zigY%#i!)@Rvn%0$^FYtqe~xm&Z-&B8o?50N|<^? zgc9;2C9m^81yog-0v+6;?1q3Z7PS=zR+v3v2uMjLdH&L8ZQCg^v1_R@Gquy6cGeGvn zU9l^FOrlVfH`RhD#|(M9MEcrm^cv43(~Qa-(|X;n{lXcA*``+CTMsHwy-ljl>@Svt zaMZpLr9HDzrk*P$gK#<^5k2m$`|%)lE{o8I{$QwU8foz5dGjrWaBbwB^s-o}XS%~a z=|SBb4m!YdH$Cjq{o@~<>#^zc&jFH3avO#5t#K*gRVsdRT&O;2=}1k5bp&sjPUD*P zmWU2Z^0=SgY%;E;<1EY~6RtWCVWar6!Oe)7BDqx`4gJ~&MzFfSei7$T?RHhGy0gl5 zP7uk;W|~Ulg5Sqq?Jftspd3pEs*>IWaMetRpbYz2MX#SX-qH+bf#uMu0FnS+_uN1^ zBjikg3p3lk2<`16#M{GjC}j9Lsd1tDv5^>37oa%yK%3$=_j53`Ia@1gBQqW_?f^-$mK+R=F_cWmH1BYsqB+3 z@a^1s%BCtWHZl-~R9&zLKwl|Cw3Ni#$oOF)uk+G&)r-);t0y7f0yg2pk3LFMp6k$! z_Q))SL~hSEPJ+n^h@2L-ffFJw&O0)UTyu}|6N_%sZV~>CgFMDb)MbO=K}cgB2B==; z#tFr}k@az8h)uuC+esl43Uw;sa*L8^+Wfl}99rQ_xY=&l*XK5&Y}C0C_KuO5-#4nY zpF8YCnp1!>02_Hiww0&u6`t%98?k>rs$<`*Fh$$e?I-*SQPg3jW$=hH(TbiYSK!OM zcgld)mP5kjw53gs4fBCF#c_ewDo$$t$-Imx5d-*ZV%%DA`>MwKRY}U}{+lsnqp;9u zeOt+Wb{%;zxbNZ|Cfm`mKgtvG)w`%#;=m~L3n}?!aZ8w)f-A?xAkbMglN;Bp-eAN7osu7roB$r2 z?E&9g*9*+F&1G^n#*L>w+Y-%~0_3w()4%<_luT@2DRjWZM7Id(7F39Cna9?4k;Jzc ziTXkhA0aeV(7$hJ4;RJ7F9+RNf*!M@Yx#PZ4gj@#6EkdE*4Ws`im zvaKmi;PEVr1`}+ve9lsv1kbVmIzwTQYhPO^kVNyqbd@-$e4&+k7o}=z0XgDh3Z;LP ziJ8Uq+k|VD4R?m!k@Z(oYe9SuV}h1mtim9;c<(_3qmB!=Wn*tBiH3eJamGP|B9-QNa;pXSJ|?v8IcrDso@Ji4D=dyANZ z>+*lf7?|1rvXFlYuE@#)y`INGnL^x_+I zy$H7H%)ZoZ*TM@b$@9aT(Zbpk920Yat!>V7m4?PBOYlZ-p83&aeO%a(((3g9_E^M4 zKgNJ%l_#VZ5LB{M_~@YsiaHkaGfe~qsGY^i5Ok)&`cr*P?QY%By{6R8pzij$yn|k6 zX5s=xtY1NZ7uf!K=gwN}UstAz)2x>`L4x$%!rlaKC2+pt;U3LT zfil+c_?=QI}-;12Tt72ZXGe-<|RQ7yOiN zPaEnC81Ixh6Twp|!xD}Z(Xnm?%_!p7#7gzt=6K+xdS;^k8P*VAj#;kBwR}+SiorTL zP2}d*MP%WsAl`eWpcK|yb*)0gjm(N;=rFKWdMjgCbDnPc^2B`(G(Yx1m)oRord{f~ z_6OfEO8++tr48{#IBB4lyy^IrZX?rdm8l#UW$YN<{$s-QGW^xUJ-VAaEJ<1%3}!yBB{nc$Bn zJs%$8O}O_}^O%5^EJV9BM&twtz^d=?Er@)tWu!E1oQ7Z*2oa-QyiIPDE6-mqI(Sjg z*eGMxc#$S9cq|`51LNXBxt|UNY-F^QhA-?@R|~@)ELmXUCF&!qb_Bxi(=or;lAVU*}an|%pC?^!R6RAt$GA^7CXLlJi8 z+X!&r-Yxp<4|6a1^D4ata_eKg(Gs|bL4d81p*lFn%OE->KB2{2vNj7Hg>vXOi1Ga> zn1Ma(9V&Tn`y590XTB#8=)vx)eCn*l;*8Lc{r7I9ivmmmZu2~!xvZj-*{6MMmcVt` zL~lFzj8EO_qq>8SxMs41bHU7+-O`|e&M2p#_%>#&c;0a9;nj?Sd}5+U3Jbhdx&&wnwlHU3|9OvN9ISP zDUK}4>6|?k-FcwOhthewnbU=)2F7Ow%@BNZSV(f_@{{_ zA;+;!D0HXG_+-L=T4Db6MhsEQQ@@q{S$tTbj}UdFP`l0&KN8r-(Qz$IB9|qlkY?$j zV>iuw-je}m=}U&6)@n>vOeb^=eE$9i=TdN@P*=b~c$&zWX9|Y4*0-%&n)%en<77gA z+?WJZ&z^cdfZ&X|`f3t~y)yF2MrHBA!4C^F@;f?Dl~xGyH!8(!^W08lQf!_|);II4 znQn%ePn3%H@D9XQ)e$6V3&fQ>+)Y>b+gx4MJxrbtwg6w~F3UZjI)@JD?IeCwhf?1w zbpM$ktY9r&TBKrSrWT{ata+dt4LkCDG~lSx_jt88v`$-(8r0n9OI~gFiR!a3+a~zW zdp4qHjf6}Zht2-|mR$?WJMT5Pk})kYBc1mCCJJRJQFrRKX+iu?oKT9TRFKL%|QES*Y4%{5K;FxIZ?M~nZ&oh3H%9q zi$&r|r7y!FVU)_o0aDIR9`@iSwwe_-N!1Dv%qRx;3f2XBP#$0!le9|xMNc!n%#}@c zv$hhtJYevbVlU*?_Oq8rwy(iOgBc@b(R=qxE6`BX52>?M>IPlEj%m()6OtuX<>j(o zBEf5jTfA106Q$ny*QQZ;=cfR?y=aXG}8A*K8kNHNf=&FSIB7gE_m zw5{+?gG%>Lj$|?9U3Im$_NAs#l-U%fnp`gDsf%H4r0M6gW1An|EM?usS0+Ch7j*YY zFl2#U(5YMCkD6NRjz~8;y21*3pUc(JetR`Es7EJ@+$=jM!i3a9*uIkhPHG;ivPZ$% zj_m)RC?`x#M}!6}?!4OCj!u!5Yq*L6cZS`Y1tS#m$nsn{ox?DB>I5K6ZyJm4t zOcSwmeb>*4|yK!eZ~4pf*^=Bq~@JCl{*O9~6; znUfy8Q(syBpYcXf%2!n>S*xygx?pJf+HEs{v3BOJi|%|dd4$bF9*IuEJoX4k$@2I! z7qmxlI%J#D^lf{pzCx!sRa)nM9n(5Yl+Rri_&3RLbFAuY6xAal*Dn$wTuNsYZM*&0 zT3fl<$h7We=G_U~UZ%ny0a>PMzGUUBRe?LZVwC2A%fi-XOofYdB}M6{;5z^{011RB zh&t>L|_|Dq%7Bq!{vPCSIBlkNGbnkr@Mi7N1rZa>k3g}2Y`r#DFNCOnrL z792I-to$gn>&=e9r&~MB+Ok&OuZSpaLbS`L>eqp-Ud5xj49JRB3(79~IWTuOh}2d0 zJZ-kku3|{II_J-K!87pm%x)1~mV7Dgk@|xR_%?>m8m_!!TDYEYgL*mAlq)_@DSeeM zE{ypokO6i()R1B)5vqy2_l$H;PvD-%*xTPlQx3ey4=O=NhS>$&sG&C^^yn}#G5G=C zCgU+OLy8UN)I8gSno|Tzflx5i*FCyt@-?eypqZUcIF-gr+BR6bDDO&UP8s8h0wXld z9;vux%Cf;ilzLln5G%8196wD2Ny~?*T2`3N>#l@vI_e;7ZAw)6cf8TScY8kMRy;Ab z%wDt(K%<$RH+oZ;w;sYi+iIRKI6Z)plQloUM$McA_9H$?u zFp~D<4PwKYa$jL1HcI5*SH}cb&j{H!xE4 z;d4x}ihf_ypUZh#k6c@57N0i~x0)0($hiB%@iQPo+wy-x(eD*VCqklb-$ai5seb~L zcil~tJ1InYn+xX~@D}tGff$OpVxc9iFaMtI8%-HuXMn(!CIPF=iC>p?Ez$Vm&2WSDPv$1ER*@H(M?-qAImz zs9)qC)lYG64ZnyTsZ~&C>98)~!)ky&s?#Ikb0k+N(+2t)Y2%WbaB1EX1!;^09$H9A z&eX%M!*FHF=C0*F!l&EWU>K&AgYpY#JFTK=WJhmg$*MPRl%acKPN;Sn*~e7-Jy1@c zW_&S5o)T2&M0vBKjECyc;gZ7dH^O&dT(o6q;LJ&G(&%DMm!)8tl2s!o{ALrosHM|c z+eJ@#11p>A4=#>@kT*h1NWlKmYVnU< z-b<71!1R|G^&Qw*n#K|keuUX8nsSbmrkvKy$xj;eGUFsLNgzZ^QPfQSvgNP@{$yvg z_L#O}zb&>y9CkaFc8FK9Q3r|Mb^;-PobSSP_&WbrOTP9qI8(p-G#6Cqy;oba^NH*h zvGWOc=-Et~^I#xx6QzJ?8Th{h?>kff3+!xv5O5N#5!OEC+&-WXqwv*;@So<>g5vub z{y*Lc4)(6l36FcU@ly07geep3YrD2235K=k;fmIQXZCsTLOv*996~jELn*?IA~ZvJ z*4dWrQ@d{Y`?SozDQ>2GjnwQTdnSx>`NJvKAKZBxn7{}A{2w$bmT!EH-;?!>QI=EG zTmFerA@@yE&uKeB}-(%ZA;NO*J+X9!AMH?Xc43{Qd>JqSqOzDHc+hwUgV^ z>#mosWw#N??wTze~J&p|cu z5P*o@)p-zOct^KlmC(5SDnI>==GkjrlAbIx4Wa4-kra{_STKF;L9z`Q&j!p3v(o}bI4zytu71ZQHHK(_MXgTTA}II-zVa5r;cLWY(lw$%-?Zf^ z#gfJqMJ5s5s?$t~3Phz-vgo$3OF?r|W4F9@n^l*UfNWbYbAG(g_&E=UlGTsnE8m@S s)h5!d1O&^cx|{!dHW@fNA^sC^p~-Lb*i4)3ze|XWOofb0 zjf~8VOvr*v#f?lQiA>Fh%&p<7@SRJU5Sf~gkcE(%kB~)-u%@lFqT-#aWOuG!O|}&g zzC;PBk*TQ(S*ZDBX$q5R+S(f0+FA&aS^N)TaVdz&N=Ay)W@W`#2*t!$Bu}_e`mx6h zr)rW5n8fGJDg@!Vd#cr@%6vzw*WZ7B+)yc!bH6BX)pw?rr_cXSt#?97?%VoSBl^5u3dmhceJ2P0|85508X5kn z#f-BylX+Xx`f)+Lc-2;8w1rLJ8MZ6j2=BM_y}*ZiYM&yQ#!#a^frbNJ-4W(LitkWb zf!GJm>f-Tgo8R0iBE;Qkd;(o3z_#S)=UqnvWCkbaJ1(?Ic-t?8Mt_A!)XmlifTNKIh|bykRN3Ci}-J5Ej|b1pndGdYm>8$6H8CA<;~Gb>Qjpm zm-2Sx`f8Lo?l2QFm#}~BsIDDPZ#`j|VW;}MwMv0N&~L~g2OL^k3lqmI?3AA)vVBGy zV(?|=Oh*d_-;KTQ1?g*C4^v2d!h_Zei8Ar^5TfL0RB++k0Z9y+{k})$B5$qPMmJT0 zl|E^DkWi7Gen5*0B69oCbi@Qh{378p#Na&JgtqVDKv?hcoazB{BiWb^)A{yWHcAZp zpGno@7 z0%yvs?`!&8@8K$mjahf#wgj1)1`#>6F*O$zfRRoU;V`5XQ3=&u6cvHmf zF=qb6h^9T_!t*At!!GyhOwp{?}e;AO8`VW>V~G=T=!VgLJl%q#id+pNXeqvwS_&S{TY z00wATs0{&tUL5+B26uFv)*pZn$vWnK45tv_^1(z=HkZs9q z2DV2e+}yQC9-Jvvv^Cs%u|4*`PKHB{GXzLQy4pm{kVS9|YL92f(!XdLzX);E;$0J z?j$N8#}kX|ZJg3gWq^8TnOTB`vd8j5*j)MucE;+6D$3LT-sQf<_zDAx4#&cGmVO*S z@R{MuEB*VG@a6t;10LE|m!Nk+j?(%_;x})?K)F2_rbFkatih7^0SuQJtJGZ;>i(Q2 zYZ+7VC86thq($P#xJlCjHMM50N#0g@@lC++^RQ-SNu@nI?5>ngjUM?fR8bW6uwlXn zRYi{xZgLVHKKr-$7+Ii!8UAF&PnzCv`MzD5uUQekA z(l@ghGX$D-M*;RSO7F@04XJ{7ek@>;a@l?j(73)jdNMaAJh2Xs)Xjz5iEe z_1s2nDQPRYGXa(J)ci2cax}qVQuwpc7h4Ok!qhE%ZK5d!ls~5ctyjq`oh1x}xiCj{ z_MG{>o@Q-#b9H31`Ual|CpF537##!)poi~Q8j0*&ZE>wF>}bM4M?o-@fZgAl zB;y0rJ(oPD^4=Gbob0D4L%e-H(uxX}UoZ%z?~hRbNX|%suM;90mTNVQcqp+F^*Rz` z>pi8MMx)*>jdFFIQDL-Ceh+YNs<`!?=PA2dCT{;3gdF_)3YBv>Ul}vXZ$DYzxBRy> z_FacBV=xp#vO35+3-2CFsEk~0K^eY|WT{m6i3N{-?V{%&9vN8U{*_!273ac^HAG*; zr`b7E8hp~3dl#D(XEGG0c%OLYdZ-STY6tZSeKGo#FhvlUiXhglcL3b3mRtduouHXj zcOu-0B)~|b=XYpm%9gn;Ye0plALU19iJdqr^bOr@e?W+p*DoW4=)!Eti`9rDBTwGL zAI2om&!x1P5T7b6y>E=0IG-PDeztm45S8vrRu>n2%u=wd>elb(osnzM-iDR)>E}6F z^R*{mY*h#rcKT~64G649Yq1U`g_8~Y>P+=5R#NdbFR>2t*iiZHx`9m}f z)(NrojP~LqnG|_fs8vaVpOOx>O;kv8*8(zGXjMtF3gBjOI(307LB!YuO%Juj6@KDT z;VE-_TCFg)ho;jL*Jy~O<-2+h1mR^=B{_9V5Nk3=u|2OTsNgwOe@bwrm3)ev3fErf zdvU;v&IDos+_I5mUnUiVn?)7&&A-eoG?sb$#Vt}((qwAr_m;#jV9daW@mHBt@P?cC z8>ZP;rDxBeV^K1%qu)2KnisR*B$Xvi;#B#Pt}SKlXykuQyxxQBq3mL|m+`966Fib> z;iQ4Eax99i;G{Sk*9nrz<&{GT*t$sf@DL(0kn9>zdrH{QxzTUYw=g$IrVhOwM6A;! z1l&I=u(srYKY#X_3m&wSwEm^Uv?piyBa#V}7Y|jp^ZAgWHZ zmxmpqwTl;RqIJxdK^MLsGG?Vnr@})+CWFrKM`?LHUb#b*k-=rmyEmC5M%v|xEuQLm z!m$7bgnXH`R>KMB3W1hGKDjnBv_CdMRdNLUU}rlym6g1k2X~?Lc)*tyzMYktTVgGB zkHyfQ3Sywn1t$xEcE@{6oz?Fbi8xD2zCoPK|4Ag$S zRd@?TD0V~cWgG85E(ulPeuRE7@^2^&Y(FlPTQEU+_*PGO?wvPU15+S^%oN?CDA9N4 z2s_~Agj0N`7pWt`jY+}L1Xg!NLZnorh+tIr-(N4D8eJ5+=k}uTtt^Up_Z#$p;uK50 zpnO#+V$o{m*=&(jy;fw|Mwly#_O!Fow4E%Y`AQ8Z)Peb+GmlyEFjI7!Ak_Nm!+9xK za2RJ;K|?I^)PNz@uSRhqFU}xlLhs6)7x%aDsi@Bur6o2TpEplqwi^aG0hNXluoz^VY zabk2XmExU-;!Rz*w_*fuk>b+6+ClOrI|-5_$gjMXXPA!jXBN4DM3^=qtUYmSsBQOcT`dwE-;h|g{G znSaZT`Mj{(eXn`f`=g~tzwu1k%r{Gtw$W0FsXDgiJ2adj&?@O0VQK`g9O-_V=-_iu zqU@gFHz+4cq#OnKzPbtKHK+D%77U3XA}a^@-+50;xrW%^=iX~lATlz~S$%Izd>s=! zFb5(%wn8ZO$N1F#dh`)Rr*R!)6U0jNc`wNqzb^HFV&;n2W5^T#AP=pIu1%D5BZ9zHV5G6*CIR*3{-kMiaQa*L_&?Cf7E} zwgfw3{HA_=Q)ee_b5X$!cAByAXZfxOmRhxtScL~6KZ?6MD$u~VRW6O&oxmUaNq$#O zXWdbyV(u84=Y-D&Rt7OI;0;F9^(5cq=x}1dQi4bOZ->fjYFvN z4h!7n;`?Hf2nGm{bNke@?rRJjAU=T(TG&^4qQ{pF ze<}iR#NPdofS03tm2%7@*iJ3w9O@4A1~M@IUq^PRAQX*rgVCrwtICbV;uAgge(?*V zQ6E^#%jc|DOXi2^(yEFH2F1@W;>G)CDl*9dMTwnH3J<#?hrfo4?Zov^4j}tlv2vsY zfC8EyDnMN5mkx;eC4!CXw~+O#gIu+Y`IZyY&yC%ab(FW56e`Vt@Ct>8K9uk>@5s|^9G*EI^Pb7X zKj_bo7(`OlpU7+v+rF?ELRf9@4DgFt)Lrz_v#qu6a*ED~Kq!zS=e4#bTbS+*Gbq%1 z``&a+szg(t#fPsH78`FCccmBT7?m(&B*G^BXo+&5&zEyrs~Pm@1SCNEr>F@_v;@3CtOtneb6d zNinOp+)byqm-x9?%|UuTWxAgBYw$5IjmE_~J^&XOzI-2(G%@gr3J|j+Oo6p}5*ijz$2gF;#Yl0J7M@?BY zW>k=r5(qe?(39N0-@@8AY)$Zxe7DAezKl}+S;$8rkRcSuNHk(G!p-yyyUgMOO<(=M z#(kUuWJ$>y*1W;jpWF9dAH=XC9cHwZpin!R~e*?HkUsx{qj4TWA>Ss z@cv!x+xLR5lX^sbqK9W9U$t-96EAlQI(t>s4l)_^0#@VbuTwms=Wy1y*4@qfFu;IX zLj!Yz6oPG~eG_c>f*9Dh{E{&YUlrH;6;l}q)L$n>;EK=t250BUHrqa7y*x zAkvGip!2m<4lF0{-?;WI8N%q#P+n-2*p$za&E_!`&V7cL?*&x|zTkz@_c_IB_9b=z zD|F73oI7cOuO{I9!Fss~WIvT10yYf7OSfIQ5BC=GpT(&?Fx3(ckuxnt& z7M*t)+_2|yWJq3aU#25=ip#7qBEuUZ-z#Ip`*kum9f{>=1n4q?7;W!>X1V_xCma5t z+P_SbcjM$HHhv}4pXtwBc125M9~9stc(>7a`_wp(`?0`N)=f0OFow|C&t5IFNXR=E z>p3pFX-ItuYr=xPWWP|(aW4f#A(F$d5Yq3Uh797ml@hk|kB!MLkxrUlXpelK_&$_e zBGxyqM$z=DVpIFpd|!rBPkGS*;u!*5Yx14hjEeQx)*`q8aRoiWtiBGw#GKik%W9dQ z4X*sq!Wy%mM(a1oG%y|&w%u_t4Rv|3V-y(~wMf%pCaRw%Ip#eREq3P5U5Md?Gtc0b zYeGI1%N$Q}E+JS?GkV1dVISe%A{{Zqj@oEIK3lc$vXw`Uk!W+}_fKz>n4idh7g) zyqO2VggY23>2qw|j)#o6WGqYgF1Wj-;c=Yx&xjmG-o~oWU(1PA8B&3NTPP@3>+=mX z6nt!5Tk@W?d2#OYTT|QGi6Dlqi#GJp81k)7`53+dKu>ZyC|rmUV?t8T#qK;3 zfl%{_yY5wRd?^wwe8s?|>U$Lv{?0Iu%N@8R9kE#j2&i{E{Ls7dnl|6L%u(t z9A=ll1xo^;B~KuX_Njx7I;m*AD9+CFZ$cZQV>JffW@ipjBA2`y)5$j>LYMdC8n{O? znjkK}K)`=MZybiN=Lw}4Qlk1IihB=Y5MuMpsf;MYqu>)=`OmFa8S(ay3DU!;;jj_s zStXu~Eva8|QHKLa6*r%kR9G)GL<~(w5PH;f3m~oNntQ#RC1gd|PCI2sL`HXytr@znWu*4Ij}!OmSR(OUUN+mR*_dcsz0L$qOoL-cyO0 z>Smdxj=-<#9OkGL^-c3BKeMST#Cc&`s?*bA7vd!HWidb3Ps{-8=~=w*8&Fb8S^hW< z5JzjaKW~J7*s4UBJ3*N+f;k>&F+!(alN@Ycw|vp`!B6JcR;_Gd93sH*P2sB);I9zk8<99{=?tEL6~a`r`l*Uz^+e$>I;f&Y_%hglfV2f_J4}9 zl#>13jRR*{+tP8;VbN=?5y?{2Dl#d@dS6_9#G z>VxQ>M@=~JE7#Z$j8W3Qg4j_=3K?H2(>x=!v`bucaEk;}`Pj%G-JMaf@%MmU`0t>F zTd6xRgEglL$am5m1CTLaI|aGMz&SyL8KX7ICh65jC`vu%XE+qO4wTkmUpR|FPy2Lr z+Xm);aCn&L3*z7VRF&Z3!bU07#riAJ?!>1RcG2UY^Yh)xKLo9_mB%Z|eBAzNmacvr zr?#k-p?E0|j=#oWSa90J5P-X6A_OXOJu_C+^llhxWP57zT|NjTB`!wMhaTQd|9S!h zU)_?W=oQi`iBhDr;9bxd;aHVMO)K-byv%zLO|umcJpQ$hatg@bAm|H)rGxl9GvjVX zpWWG=;36W$Gp`AxPQx1s5BUl$#cr?P91bPE*Tm{g8Jl_}g5b>nlvg&}!Go~SS7#N( z2*by!!mu}yfth{Fat1`Hd>xQ_7F@({B!OVX28)D_Za$AOe7M>+A<2>d_8*57?=eJ& z0&f-G@VJA@kHK+uY>g`K!xL$HaiZGD=%$E%*|;GOVRmtfBzXmMf#!w(W@pFEEF!ML zZQ~AIu1=HxJ^=zpvEYjO-S|jR+c8^7v5PigKKk1Gs2kcxLezP8QS`xvYVZBCpbYjK z!oz8L!Nh@U$F}SxMUZk3tY13|*V?nHy?aTTgw-U&gs3b(K(R)snc=u)+k$Z7(83x8 z0y;&B_`Oc;2M>r2{&fs*4>*?03Hj7^AN0A0HzbG!fW<&5`9uKfkH2x!ZrIL2rxw2q z&KTTDA^Zl+`q>iAu;o0LXyq*9DDoHoo7xJ({JV^U`26g<5le)l`-3O=1U(~0A?FFE zxlpJaaBRk22nQ#Ozojr_{Jc)+QX=3l$idOHm5g&DKBvWH)OA6@X$bM(V<2hm0d1w% z9)`fGvmpQYU*FP=Zo_w;T$rFqe?@Aje9gNkow>8XXdR~&Qcm%;>UWiI&suN;VvuJn z_Z_{-peZr~_#0ync@o%`0wP7@%(K4E#*aEvAcV)-Oqv49H@UwuBX-0oq&cFM&BYaF zo4F~Uj#CEfjK~#w`lU^9DkB5p$cTG2)}H|KQdJP~7WIOX2QQsOzw_I(gfJ$8?rttf zw*h32bL9I}E(KQSFU#O z)~KTH5(PA`QqRrK8Z@#%6v*bPvez{~MgKD7vfO(gg|OK)?~o-8mNVP$BHJ7DNdPfy zq|&+%SN|Q#2se5d8`*;@N$JU6pP@#bk0^3pXHK@eU4)50Rl%C(TB*U*Qo&Rj?Ft6O z=>goH#!y@=m6*<_|t}H9}H+7@c2-$v5|BS<~?aKx++&O0l&A_gR}JqD*H*Qi zOFC4!FG9ILqG+9Xk6NSmoY2i+??7fM&N2>?9)m9?V1|+E+cKn01|s_2mM>Qq?;DiSkWVa!eo$gkoZPG_bJb>ymk~0t~9Y z_-3};;(pqh>bOXOin|Nr1EhlZja}+kh!x(i`z!+XxEql`Zzm!K3ohSw?Fr7*jo&79 znOW8(hU}d)4l43;fdmM(a~~3!?d$5c`3As`-yS?x{X^{s`PdEY;54@!N|v@s_M&}K zjuY{Eb7JDD+n5?3T$Em9VpfU% zr4rPE#Zyza6)&^A!uUH5I!7O6G+*XTL+wB+WmeWDJG41bYaIc~s}HV@ z?5jF@MP6DLIqb@8Qt&rraE~q{g7_lJj2pA+<@WmiP1`6-5mX}%kk7%XX{kS#DEOgRa z20>~^xx2e>*2v+cF<0+z!ChxdR}6`*nyE}*)lAj3ps~o?4y=JpH`de_U7@=i%1k(` zoTX=f$@2`5gh(--w_n^H_r(dyR~)Pil>pPxDS!AeCrqctv5zntWQ~7!>(nSq=s%XoK&f%dVM;^#ozHD z{RxlQ|H?~_IhOz4k=6e?QiI@3j-bHBY(%;{>*a;#9jq&t3kv(+2RQEBq0RS-J_T~P zRX-MWtFty;Ng!T_?nYbIra}v-Tt0crkK85tCr!_aa>A8Lxqh4rKA#}{{$ba&qIwSy zp*>gCI?x9$CLsHs^t8gat(#wEH<#n1vTUfsq zffJ#DVVy|ErRE`d;Gm;w8W%%C6?K)Irkxn+LBB8kX>jMqA}y!GgBdMa0KT(PX`1Y1 zdipim`fpuKY04$fi54c!eXx1PjflGevpbNZvp310JD-mm=Yj~>9H|T|dw`(QOV^>#mG91Xx`ap2 zW#AXk?AXy>X9CkDf8h#5bKc7OnaM6{b7V~iP5bwLOnLL|({39;Oax0{6XFTci$n+x z!{&!F&XxpnAZE0`1d(+ia0~CzhV);Cb>nN%JyIJrtI8Jn`>)AGczA7BPFIxIgXs3e zb7Y%p|A^dk{FB&wpoSUa+S;lbx$X%2Ye)uRTPT-Qpxg;6%Ci9uxDh+fLsA6QcL5Po z{S$83uzQ1yVeV=uHW(;`0cv5-#eZ11)BU&TyRZ}p^RZrC-`)?58Gk3!VEuH$Cw^v0H)uvaFl1}6+z@exrsUTXDwN!34kM$J{Q^oskE#DS@on1VGQ zxc5`Y`1~0EjuHSA z!$yDEaqKCf(n<*?{($-IoRRowhSLBliFxkO{vSSHwi578hM=4tv{9S4u@N<&(mC8| zJNawk9f%w4o%!AKlfhJcV_|aY=#kkzH7-Z5_Nvh{j{aUw=VeCXwf(nyr_5x87|whf zCYa^uYbDfT(6otnJ&wKq?D0tfbAf-uzdhzLFG_Ggk8fo3U59s)r5ZjE>c$ar_rJ6# zBZ#=4))m0gSv5yb$u6!;or7p0V57f55U)`U;G*a-k%}`&0Mb4DcLttB=f&^0Nv!B^ zg?(OsfIW$3Tdt|xm)vsxpSpmwIirVCL?JRy| zE?~)RH})@>bDL{1-&OUB>TSl`Xc}88BK-TiJvYb z27WUQP6E(%_{cHDtPx~i{!@?;GDE58T=%LzGShOkeMxfLIh}Xpg;LPjHc`Lq{9itB z>?c=VO>1w!$r^I_HZAB6H82(EkJjixS%&}W^pF{6}M{|z|dZO~}gA+5dGD0Zz z*t^0j8uBUr4d!I$Ro~5oXh=$^3@CjtNBA=>rYR`pjA9rgZ8+5QaZ6yTbF2}p%{e)N`KSJdY*QxHMfqYW&}W4)>(9PP|$s`r_|k zQD)Nmi;rEMD8pD!)&+3X-oMvN#&%aRAEaaz29vceIaoxRf9`>+d z`qtD6VYu6G1-%x%JgV(7Z?I1CKU{uxQ122i(HD&aZ`>(l2|E%U1_P?A;St($l)} z0y(==c?Fa(k5IWMC2*R5{JvzmaPwxJSZruqMG!82BMbk2;pw7M)^m5)1MNJwC!;Fm z$3OJU<=37i+kG6pSjhBry%@*h)j|{#Bjc%tFXQlmRU1+B`1Ue(#}~ws zu(2vrbI6~D>gkU4kLeNM#`(+!TKn88ZaO4)Ui(W_i@x0W`N4_9PWwx9dDmLaSdmMs z@UhqjnX9xePh7R?#Um zrZD@TX4{<}z!sgZHv>X2WfrL7YPK4_24NA#HXE=P66mrVt9S0qQ`Q3c0>mGBeA7?`8Ndre)$&Tf1auy_dOpzu_uljd_0cwuxYAoTr(zsIQa!R<$hxdoX*iIE{( z8RPYg>NZGbUVgJpPFb%_m92*w3{D)ilRTYm=&jpE_*v8-q?l2cm| z(3ZT({#E<-0(@Q3A;g*uJw+@b0C>|)bjp85Z2IoFr$tNvrt>sAnYI? zMDmq-EfX;)JmXKj_Tq7fC|FJi#H(U*Thp}RXvlp_Yk--r*PRTR|%2mgmz5ov3lE1yPBdbPC|`!!RRjSbe-c!?GHqDHdGwt@{~dNBO2k(ByU1%F05X ziAyRM8&|(0pSlyR<60WoV>XkzE=0h7GV?tWZ# z2*t>b0 zP(f94Xoayhtg^8c&Lb8vW{!(mYOhm9c^G(Hp4dFX%%n`U>$ zP-=W1&epnXVAsdMmz)dYGp&;NOs2x`s)2R|Y}x*=c8?~n|I!Mp7kwqiT1oa7cxhig z`->SdR*ZLF(r(@BTwr!;L*ORFerXn(ra_UcPYF(fY`!uxO#FIih<2DpTWJzC!gu%P z_rG||-w~IhI;CCPgcyP~U)-Eb!6JMz7fvN=>r~fJsj2+fxUzLhV%h4HaWPt|?T&7 z-Pa2}n^$%YrTS-gZ}!*F?SGv?8GRkG*abi9pQiV&yY@Sb&?h0x-dps3^vzC`T|)&~ z=&{j9qkO%A6IG@mdk|J;HE=8$AMwqx!W1qyJ4j9_VDfefVVNk9!F+)$w1wo!bjtd^Jt)*+j|n#H>|Ia zsNM8MqDA@SkV(3i<+uw9%*AbCJBfaEr}7?(MZc>5Fj6}*^MlLmje<66*cGHB&NsLF zG5~B&g(Bm5pCaddqQ1y}GC^mIp}(3B_WSjH1i~ZYaBg-Dw6wm+o{ResRDgg#AbwPxANoa8GRAv;l7 zv_tnTl8-rdH6*N?5&ykqiQDIANyXCv=3##iG&Om;rVNwj!@m4%T!mgY$$KlTy4e0Rzklz+v;Q=_=*iEQN{UKK zYjnptzL~iTJNyeD2AwDM159s`PdlU z?T_7m3$KtN{*x6k*I1JoQ|?>aIuXLS%Ke&>ZOnY8HSy7938}RY&_*^=l4Q|2|B7`( ztluu*54pc@F!!bX&ALd7tMlhjcg!e52|ROnmKV+{?M(@PPuZvr%Utz|M5T;b&}>=Q z^@gdER(}T*!_$k~)nSeQNgSCXgKb#BZZBWbIP?Y)UA<}Yo~e>dEWXC6k`9`;2=S8& zxaEyKo02LrI6$tkNeCwPHN;4}sgghq)WjpT<`@U6Ltc1LWd|+&pe(p%xFS?ov&^cV z)v_QXoYKNzS+=DNUlR%TXGnrmoAYFz&*yqX<*| z;#HwQGgsd8fLALRARbC zZhibj?VZP816txH1pQPgzeys<;||-!>)$vfD4UfwSw9Kvt_h&kr+~b0(+v1h^@-%C z&7{O!nlg7TD|0KS*+sP3#^OMhF!LtI_45@H@HK#0-e0LJMDf zFG{Z8`T3INhIOOCn4bI;A8Lb1X~-aZK|XFZ!?kg}ah5*y2RVcTAe(zNPu|V`?EQcL Phv;e>+^@dp82$eMQl5Ji diff --git a/vignettes/teaching1.R b/vignettes/teaching1.R index 9423ae1..74f4c69 100644 --- a/vignettes/teaching1.R +++ b/vignettes/teaching1.R @@ -93,6 +93,7 @@ callsDependent ## ----plot-teaching1, message=FALSE, warning=FALSE-------------------------------------------------------------------- +library(igraph) library(ggraph) library(migraph) # The network at the beginning @@ -100,8 +101,11 @@ callNetworkBgn <- as.matrix(callNetwork) autographr(callNetworkBgn, labels = FALSE, layout = "fr") # The network at half time -callNetworkHlf <- as.matrix(callNetwork, - time = calls$time[floor(nrow(calls) / 2)]) |> +callNetworkHlf <- as.matrix( + callNetwork, + time = calls$time[floor(nrow(calls) / 2)] +) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkHlf, labels = FALSE, layout = "fr") + @@ -109,6 +113,7 @@ autographr(callNetworkHlf, labels = FALSE, layout = "fr") + # The network at the end callNetworkEnd <- as.matrix(callNetwork, time = max(calls$time) + 1) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkEnd, labels = FALSE, layout = "fr") + @@ -238,11 +243,13 @@ AIC(mod03Rate, mod04Rate) ## ----rem------------------------------------------------------------------------------------------------------------- allFormulaREM <- - callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + - inertia(callNetwork, window = 300) + - recip(callNetwork, window = 300) + - tie(friendshipNetwork) + recip(friendshipNetwork) + - same(actors$gradeType) + same(actors$floor) + callsDependent ~ + 1 + indeg(callNetwork, type = "ego") + outdeg(callNetwork, type = "ego") + + indeg(friendshipNetwork, type = "ego") + + inertia(callNetwork) + recip(callNetwork) + + inertia(callNetwork, window = 300) + recip(callNetwork, window = 300) + + tie(friendshipNetwork) + recip(friendshipNetwork) + + same(actors$gradeType) + same(actors$floor) ## ----rem-gather, eval=FALSE------------------------------------------------------------------------------------------ diff --git a/vignettes/teaching1.Rmd b/vignettes/teaching1.Rmd index d8a1da7..d95e3d0 100644 --- a/vignettes/teaching1.Rmd +++ b/vignettes/teaching1.Rmd @@ -32,7 +32,6 @@ a couple of ERGM papers by callings its documentation: ```r library(goldfish) -#> Warning: package 'goldfish' was built under R version 4.3.2 data("Social_Evolution") # ?Social_Evolution head(calls) @@ -57,7 +56,7 @@ head(actors) # Preamble: Run a quick DyNAM in five lines -We use `R` version 4.2.0 to compile the vignettes. +We use an `R` version higher than 4.2.0 to compile the vignettes. The native pipe operator is available in `R` from version 4.1.0. @@ -360,6 +359,7 @@ for additional information about network visualization. ```r +library(igraph) library(ggraph) library(migraph) # The network at the beginning @@ -372,21 +372,33 @@ autographr(callNetworkBgn, labels = FALSE, layout = "fr") ```r # The network at half time -callNetworkHlf <- as.matrix(callNetwork, - time = calls$time[floor(nrow(calls) / 2)]) |> +callNetworkHlf <- as.matrix( + callNetwork, + time = calls$time[floor(nrow(calls) / 2)] +) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkHlf, labels = FALSE, layout = "fr") + geom_node_point(aes(color = as.factor(floor)), size = 2, show.legend = FALSE) -#> Error in UseMethod("as_tidygraph"): no applicable method for 'as_tidygraph' applied to an object of class "NULL" +``` + +![plot of chunk plot-teaching1](teaching/plot-teaching1-2.png) + +```r # The network at the end callNetworkEnd <- as.matrix(callNetwork, time = max(calls$time) + 1) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkEnd, labels = FALSE, layout = "fr") + geom_node_point(aes(color = as.factor(floor)), size = 2, show.legend = FALSE) -#> Error in UseMethod("as_tidygraph"): no applicable method for 'as_tidygraph' applied to an object of class "NULL" +``` + +![plot of chunk plot-teaching1](teaching/plot-teaching1-3.png) + +```r # The tie strength at the end @@ -639,18 +651,18 @@ summary(mod03Rate) #> #> Coefficients : #> Estimate Std. Error z-value Pr(>|z|) -#> Intercept -14.335641 0.094257 -152.0912 < 2.2e-16 *** -#> indeg 0.568475 0.067244 8.4540 < 2.2e-16 *** -#> outdeg 0.314266 0.030898 10.1712 < 2.2e-16 *** -#> indeg 0.047770 0.015148 3.1535 0.001613 ** +#> Intercept -14.380373 0.095669 -150.3135 < 2.2e-16 *** +#> indeg 0.695555 0.063115 11.0204 < 2.2e-16 *** +#> outdeg 0.234633 0.030153 7.7814 7.105e-15 *** +#> indeg 0.054792 0.015049 3.6409 0.0002716 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> #> Converged with max abs. score of 0 -#> Log-Likelihood: -5984.3 -#> AIC: 11977 -#> AICc: 11977 -#> BIC: 11993 +#> Log-Likelihood: -6003.1 +#> AIC: 12014 +#> AICc: 12014 +#> BIC: 12031 #> model: "DyNAM" subModel: "rate" ``` @@ -666,10 +678,10 @@ The baseline waiting time between two events in hours: ```r mod03RateCoef <- coef(mod03Rate) 1 / exp(mod03RateCoef[["Intercept"]]) / 3600 -#> [1] 467.291 +#> [1] 488.6682 # or days: 1 / exp(mod03RateCoef[["Intercept"]]) / 86400 -#> [1] 19.47046 +#> [1] 20.36118 # But what if it is not just a random call? # Expected waiting time of those who have five outgoing call ties @@ -677,7 +689,7 @@ mod03RateCoef <- coef(mod03Rate) 1 / exp( mod03RateCoef[["Intercept"]] + mod03RateCoef[["outdeg"]] * 5 ) / 3600 -#> [1] 97.08854 +#> [1] 151.1872 # Expected waiting time of those who have five outgoing and incoming call ties # (five different actors) 1 / exp( @@ -685,7 +697,7 @@ mod03RateCoef <- coef(mod03Rate) mod03RateCoef[["outdeg"]] * 5 + mod03RateCoef[["indeg"]] * 5 ) / 3600 -#> [1] 5.658994 +#> [1] 4.66806 ``` ### Windows @@ -723,21 +735,21 @@ summary(mod04Rate) #> indeg friendshipNetwork #> #> Coefficients : -#> Estimate Std. Error z-value Pr(>|z|) -#> Intercept -14.1665102 0.0880817 -160.8337 < 2.2e-16 *** -#> indeg 0.1910828 0.0781305 2.4457 0.01446 * -#> outdeg 0.5283974 0.0332725 15.8809 < 2.2e-16 *** -#> indeg 3.1942574 0.4135005 7.7249 1.11e-14 *** -#> outdeg 0.1404188 0.2860436 0.4909 0.62350 -#> indeg 0.0098856 0.0154430 0.6401 0.52209 +#> Estimate Std. Error z-value Pr(>|z|) +#> Intercept -14.530750 0.101676 -142.9125 < 2.2e-16 *** +#> indeg 0.245045 0.070682 3.4669 0.0005266 *** +#> outdeg 0.364576 0.032556 11.1985 < 2.2e-16 *** +#> indeg 5.295709 0.139463 37.9722 < 2.2e-16 *** +#> outdeg -0.767499 0.116642 -6.5800 4.706e-11 *** +#> indeg 0.083772 0.015289 5.4794 4.268e-08 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> -#> Converged with max abs. score of 0.00081 -#> Log-Likelihood: -5854.6 -#> AIC: 11721 -#> AICc: 11721 -#> BIC: 11750 +#> Converged with max abs. score of 1e-05 +#> Log-Likelihood: -5475.9 +#> AIC: 10964 +#> AICc: 10964 +#> BIC: 10992 #> model: "DyNAM" subModel: "rate" ``` @@ -814,23 +826,28 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) #> Warning in AIC.default(mod03Rate, mod04Rate): models are not all fitted to the same number of observations #> df AIC -#> mod03Rate 4 11976.58 -#> mod04Rate 6 11721.24 +#> mod03Rate 4 12014.20 +#> mod04Rate 6 10963.75 ``` ### REM with `goldfish` `goldfish` does not only run DyNAMs; it also runs REMs (Butts, 2008). We can now also run REMs using the right-censored intervals as introduced in Stadtfeld & Block (2017). +An equivalent model specification to the DyNAM model we estimated above, +including the rate and choice sub-models, is: + ```r allFormulaREM <- - callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + - inertia(callNetwork, window = 300) + - recip(callNetwork, window = 300) + - tie(friendshipNetwork) + recip(friendshipNetwork) + - same(actors$gradeType) + same(actors$floor) + callsDependent ~ + 1 + indeg(callNetwork, type = "ego") + outdeg(callNetwork, type = "ego") + + indeg(friendshipNetwork, type = "ego") + + inertia(callNetwork) + recip(callNetwork) + + inertia(callNetwork, window = 300) + recip(callNetwork, window = 300) + + tie(friendshipNetwork) + recip(friendshipNetwork) + + same(actors$gradeType) + same(actors$floor) ``` And we can estimate this model, to speed up estimation, we can use any of the @@ -862,42 +879,51 @@ mod01REM <- estimate( summary(mod01REM) #> #> Call: -#> estimate(x = callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + +#> estimate(x = callsDependent ~ 1 + indeg(callNetwork, type = "ego") + +#> outdeg(callNetwork, type = "ego") + indeg(friendshipNetwork, +#> type = "ego") + inertia(callNetwork) + recip(callNetwork) + #> inertia(callNetwork, window = 300) + recip(callNetwork, window = 300) + #> tie(friendshipNetwork) + recip(friendshipNetwork) + same(actors$gradeType) + #> same(actors$floor), model = "REM", estimationInit = list(engine = "gather_compute")) #> #> #> Effects details : -#> Object window -#> Intercept -#> inertia callNetwork -#> recip callNetwork -#> inertia callNetwork 300 -#> recip callNetwork 300 -#> tie friendshipNetwork -#> recip friendshipNetwork -#> same actors$gradeType -#> same actors$floor +#> Object type window +#> Intercept "" "" "" +#> indeg "callNetwork" "ego" "" +#> outdeg "callNetwork" "ego" "" +#> indeg "friendshipNetwork" "ego" "" +#> inertia "callNetwork" "" "" +#> recip "callNetwork" "" "" +#> inertia "callNetwork" "" "300" +#> recip "callNetwork" "" "300" +#> tie "friendshipNetwork" "" "" +#> recip "friendshipNetwork" "" "" +#> same "actors$gradeType" "" "" +#> same "actors$floor" "" "" #> #> Coefficients : -#> Estimate Std. Error z-value Pr(>|z|) -#> Intercept -19.71673 0.11613 -169.7865 < 2.2e-16 *** -#> inertia 5.69399 0.16967 33.5596 < 2.2e-16 *** -#> recip -0.23048 0.14452 -1.5948 0.1108 -#> inertia -1.54005 0.17862 -8.6221 < 2.2e-16 *** -#> recip 7.18721 0.16779 42.8342 < 2.2e-16 *** -#> tie 0.94057 0.20797 4.5226 6.107e-06 *** -#> recip 0.92988 0.19070 4.8761 1.082e-06 *** -#> same 0.31116 0.13364 2.3283 0.0199 * -#> same -0.60389 0.12207 -4.9470 7.538e-07 *** +#> Estimate Std. Error z-value Pr(>|z|) +#> Intercept -19.763568 0.136731 -144.5434 < 2.2e-16 *** +#> indeg 0.086900 0.071528 1.2149 0.2243968 +#> outdeg -0.222330 0.040445 -5.4971 3.860e-08 *** +#> indeg 0.010742 0.017245 0.6229 0.5333320 +#> inertia 6.203483 0.189796 32.6850 < 2.2e-16 *** +#> recip -0.313425 0.154555 -2.0279 0.0425690 * +#> inertia -1.589903 0.179494 -8.8577 < 2.2e-16 *** +#> recip 7.013842 0.170730 41.0814 < 2.2e-16 *** +#> tie 0.853373 0.206297 4.1366 3.525e-05 *** +#> recip 0.930856 0.194742 4.7800 1.753e-06 *** +#> same 0.470688 0.132528 3.5516 0.0003829 *** +#> same -0.670748 0.123206 -5.4441 5.207e-08 *** #> --- #> Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 #> #> Converged with max abs. score of 0 -#> Log-Likelihood: -5657.2 -#> AIC: 11332 -#> AICc: 11333 -#> BIC: 11375 +#> Log-Likelihood: -5639 +#> AIC: 11302 +#> AICc: 11302 +#> BIC: 11359 #> model: "REM" subModel: "choice" ``` + diff --git a/vignettes/teaching1.Rmd.orig b/vignettes/teaching1.Rmd.orig index 90940a8..6e982ee 100644 --- a/vignettes/teaching1.Rmd.orig +++ b/vignettes/teaching1.Rmd.orig @@ -82,7 +82,7 @@ estimate <- function( # Preamble: Run a quick DyNAM in five lines -We use `R` version 4.2.0 to compile the vignettes. +We use an `R` version higher than 4.2.0 to compile the vignettes. The native pipe operator is available in `R` from version 4.1.0. ```{r quick} @@ -244,6 +244,7 @@ different time periods using `migraph`. See the `migraph` package documentation for additional information about network visualization. ```{r plot-teaching1, message=FALSE, warning=FALSE} +library(igraph) library(ggraph) library(migraph) # The network at the beginning @@ -251,8 +252,11 @@ callNetworkBgn <- as.matrix(callNetwork) autographr(callNetworkBgn, labels = FALSE, layout = "fr") # The network at half time -callNetworkHlf <- as.matrix(callNetwork, - time = calls$time[floor(nrow(calls) / 2)]) |> +callNetworkHlf <- as.matrix( + callNetwork, + time = calls$time[floor(nrow(calls) / 2)] +) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkHlf, labels = FALSE, layout = "fr") + @@ -260,6 +264,7 @@ autographr(callNetworkHlf, labels = FALSE, layout = "fr") + # The network at the end callNetworkEnd <- as.matrix(callNetwork, time = max(calls$time) + 1) |> + as_igraph() |> add_node_attribute("floor", actors$floor) autographr(callNetworkEnd, labels = FALSE, layout = "fr") + @@ -479,14 +484,19 @@ AIC(mod03Rate, mod04Rate) `goldfish` does not only run DyNAMs; it also runs REMs (Butts, 2008). We can now also run REMs using the right-censored intervals as introduced in Stadtfeld & Block (2017). +An equivalent model specification to the DyNAM model we estimated above, +including the rate and choice sub-models, is: + ```{r rem} allFormulaREM <- - callsDependent ~ 1 + inertia(callNetwork) + recip(callNetwork) + - inertia(callNetwork, window = 300) + - recip(callNetwork, window = 300) + - tie(friendshipNetwork) + recip(friendshipNetwork) + - same(actors$gradeType) + same(actors$floor) + callsDependent ~ + 1 + indeg(callNetwork, type = "ego") + outdeg(callNetwork, type = "ego") + + indeg(friendshipNetwork, type = "ego") + + inertia(callNetwork) + recip(callNetwork) + + inertia(callNetwork, window = 300) + recip(callNetwork, window = 300) + + tie(friendshipNetwork) + recip(friendshipNetwork) + + same(actors$gradeType) + same(actors$floor) ``` And we can estimate this model, to speed up estimation, we can use any of the @@ -515,3 +525,4 @@ mod01REM <- estimate( summary(mod01REM) ``` + diff --git a/vignettes/teaching2.Rmd b/vignettes/teaching2.Rmd index e831a36..4fa15e8 100644 --- a/vignettes/teaching2.Rmd +++ b/vignettes/teaching2.Rmd @@ -464,7 +464,7 @@ system.time( ) ) #> user system elapsed -#> 172.01 12.90 200.93 +#> 231.94 6.51 245.44 ``` Did the model converge? If not, you can restart the estimation process using @@ -556,7 +556,7 @@ system.time( ) ) #> user system elapsed -#> 21.08 1.33 24.31 +#> 137.27 0.86 139.80 ``` # Extensions... From 32e1d4d138302656f4dc4e96e8554ebe25c0dda0 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 7 Mar 2024 17:15:13 +0100 Subject: [PATCH 27/36] Fix CRAN note, update configure file, and update URL addresses to new organization --- DESCRIPTION | 2 +- NEWS.md | 3 +- README.md | 1 + _pkgdown.yml | 3 + configure | 499 ++++------------------------------------------- configure.ac | 219 ++++----------------- src/Makevars.in | 22 +-- src/Makevars.win | 20 -- 8 files changed, 82 insertions(+), 687 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index c908569..a9fb5e7 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,7 +3,7 @@ Package: goldfish Type: Package Title: Statistical Network Models for Dynamic Network Data Version: 1.6.6 -Date: 2023-06-20 +Date: 2024-03-07 Authors@R: c(person("James", "Hollway", role = c("cre", "aut", "dtc"), email = "james.hollway@graduateinstitute.ch", comment = c("IHEID", ORCID = "0000-0002-8361-9647")), diff --git a/NEWS.md b/NEWS.md index dd4425e..fec5e53 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,6 +1,7 @@ # goldfish 1.6.6 -* Debugging `GatherPreprocessing()`. +* Debugging and extend documentation for `GatherPreprocessing()`. +* Fix note from CRAN checks. # goldfish 1.6.5 diff --git a/README.md b/README.md index 878ddce..d90c4cc 100644 --- a/README.md +++ b/README.md @@ -55,6 +55,7 @@ An updated setting up instructions thanks to @timonelmer are available [here](ht More details can be found [here](https://medium.com/biosyntax/following-up-library-dependency-when-compiling-r-packages-89f191b9f227) (Thank you @Knieps for identifying this.). Other links that may be helpful include: + - https://asieira.github.io/using-openmp-with-r-packages-in-os-x.html - https://thecoatlessprofessor.com/programming/cpp/r-compiler-tools-for-rcpp-on-macos/ - https://ryanhomer.github.io/posts/build-openmp-macos-catalina-complete diff --git a/_pkgdown.yml b/_pkgdown.yml index ca2f1ae..ce84b99 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -56,6 +56,9 @@ reference: - starts_with("Fisheries_") - starts_with("RFID_") - starts_with("Social_") + - title: "Gather preprocessing" + contents: + - GatherPreprocessing articles: - title: "goldfish effects" navbar: "goldfish effects" diff --git a/configure b/configure index f7e898c..9f3b3cf 100755 --- a/configure +++ b/configure @@ -584,8 +584,7 @@ PACKAGE_URL='' ac_subst_vars='LTLIBOBJS LIBOBJS OPENMP_FLAG -ARMA_HAVE_OPENMP -ARMA_LAPACK +OPENMP_CFLAG CXXCPP OBJEXT EXEEXT @@ -2440,476 +2439,40 @@ ac_compiler_gnu=$ac_cv_cxx_compiler_gnu -ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu -if test -z "$CXX"; then - if test -n "$CCC"; then - CXX=$CCC - else - if test -n "$ac_tool_prefix"; then - for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC - do - # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. -set dummy $ac_tool_prefix$ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$CXX"; then - ac_cv_prog_CXX="$CXX" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_CXX="$ac_tool_prefix$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -CXX=$ac_cv_prog_CXX -if test -n "$CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CXX" >&5 -$as_echo "$CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$CXX" && break - done -fi -if test -z "$CXX"; then - ac_ct_CXX=$CXX - for ac_prog in g++ c++ gpp aCC CC cxx cc++ cl.exe FCC KCC RCC xlC_r xlC -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if ${ac_cv_prog_ac_ct_CXX+:} false; then : - $as_echo_n "(cached) " >&6 -else - if test -n "$ac_ct_CXX"; then - ac_cv_prog_ac_ct_CXX="$ac_ct_CXX" # Let the user override the test. -else -as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then - ac_cv_prog_ac_ct_CXX="$ac_prog" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - -fi -fi -ac_ct_CXX=$ac_cv_prog_ac_ct_CXX -if test -n "$ac_ct_CXX"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CXX" >&5 -$as_echo "$ac_ct_CXX" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - test -n "$ac_ct_CXX" && break -done - - if test "x$ac_ct_CXX" = x; then - CXX="g++" - else - case $cross_compiling:$ac_tool_warned in -yes:) -{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 -$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} -ac_tool_warned=yes ;; -esac - CXX=$ac_ct_CXX - fi -fi - - fi -fi -# Provide some information about the compiler. -$as_echo "$as_me:${as_lineno-$LINENO}: checking for C++ compiler version" >&5 -set X $ac_compile -ac_compiler=$2 -for ac_option in --version -v -V -qversion; do - { { ac_try="$ac_compiler $ac_option >&5" -case "(($ac_try" in - *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; - *) ac_try_echo=$ac_try;; -esac -eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" -$as_echo "$ac_try_echo"; } >&5 - (eval "$ac_compiler $ac_option >&5") 2>conftest.err - ac_status=$? - if test -s conftest.err; then - sed '10a\ -... rest of stderr output deleted ... - 10q' conftest.err >conftest.er1 - cat conftest.er1 >&5 - fi - rm -f conftest.er1 conftest.err - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 - test $ac_status = 0; } -done - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C++ compiler" >&5 -$as_echo_n "checking whether we are using the GNU C++ compiler... " >&6; } -if ${ac_cv_cxx_compiler_gnu+:} false; then : - $as_echo_n "(cached) " >&6 -else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ -#ifndef __GNUC__ - choke me -#endif - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_compiler_gnu=yes -else - ac_compiler_gnu=no -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -ac_cv_cxx_compiler_gnu=$ac_compiler_gnu - -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cxx_compiler_gnu" >&5 -$as_echo "$ac_cv_cxx_compiler_gnu" >&6; } -if test $ac_compiler_gnu = yes; then - GXX=yes -else - GXX= -fi -ac_test_CXXFLAGS=${CXXFLAGS+set} -ac_save_CXXFLAGS=$CXXFLAGS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CXX accepts -g" >&5 -$as_echo_n "checking whether $CXX accepts -g... " >&6; } -if ${ac_cv_prog_cxx_g+:} false; then : - $as_echo_n "(cached) " >&6 -else - ac_save_cxx_werror_flag=$ac_cxx_werror_flag - ac_cxx_werror_flag=yes - ac_cv_prog_cxx_g=no - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_g=yes -else - CXXFLAGS="" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - -else - ac_cxx_werror_flag=$ac_save_cxx_werror_flag - CXXFLAGS="-g" - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -/* end confdefs.h. */ - -int -main () -{ - - ; - return 0; -} -_ACEOF -if ac_fn_cxx_try_compile "$LINENO"; then : - ac_cv_prog_cxx_g=yes -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext -fi -rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext - ac_cxx_werror_flag=$ac_save_cxx_werror_flag -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cxx_g" >&5 -$as_echo "$ac_cv_prog_cxx_g" >&6; } -if test "$ac_test_CXXFLAGS" = set; then - CXXFLAGS=$ac_save_CXXFLAGS -elif test $ac_cv_prog_cxx_g = yes; then - if test "$GXX" = yes; then - CXXFLAGS="-g -O2" - else - CXXFLAGS="-g" - fi -else - if test "$GXX" = yes; then - CXXFLAGS="-O2" - else - CXXFLAGS= - fi -fi -ac_ext=cpp -ac_cpp='$CXXCPP $CPPFLAGS' -ac_compile='$CXX -c $CXXFLAGS $CPPFLAGS conftest.$ac_ext >&5' -ac_link='$CXX -o conftest$ac_exeext $CXXFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' -ac_compiler_gnu=$ac_cv_cxx_compiler_gnu - - -## Is R already configured to compile things using OpenMP without -## any extra hand-holding? -openmp_already_works="no" - -## default to not even thinking about OpenMP as Armadillo wants a pragma -## variant available if and only if C++11 is used with g++ 5.4 or newer -can_use_openmp="no" - -## Ensure TMPDIR is set. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we have a suitable tempdir" >&5 -$as_echo_n "checking whether we have a suitable tempdir... " >&6; } -TMPDIR=$("${R_HOME}/bin/R" --vanilla --slave -e "cat(dirname(tempdir()))") -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: ${TMPDIR}" >&5 -$as_echo "${TMPDIR}" >&6; } - -## Check if R is configured to compile programs using OpenMP out-of-the-box. -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether R CMD SHLIB can already compile programs using OpenMP" >&5 -$as_echo_n "checking whether R CMD SHLIB can already compile programs using OpenMP... " >&6; } - -## Create private directory in TMPDIR. -BUILDDIR="${TMPDIR}/rcpparmadillo-$$-$RANDOM" -mkdir -p "${BUILDDIR}" - -owd=$(pwd) -cd "${BUILDDIR}" - -cat < test-omp.cpp -#include -int main() { - return omp_get_num_threads(); -} -EOF - -## Execute R CMD SHLIB. -"${R_HOME}/bin/R" CMD SHLIB test-omp.cpp >/dev/null 2>&1 -if test x"$?" = x"0"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 -$as_echo "yes" >&6; } - openmp_already_works="yes" -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - -## Go back home. -cd "${owd}" -rm -rf "${BUILDDIR}" - -## If the above checks failed, then perform other heuristics -## based on the compiler version, etc. -if test x"${openmp_already_works}" = x"no"; then - - ## Check the C++ compiler using the CXX value set - - ## If it is g++, we have GXX set so let's examine it - if test "${GXX}" = yes; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether g++ version is sufficient" >&5 -$as_echo_n "checking whether g++ version is sufficient... " >&6; } - gxx_version=$(${CXX} -v 2>&1 | awk '/^.*g.. version/ {print $3}') - case ${gxx_version} in - 1.*|2.*|3.*|4.0.*|4.1.*|4.2.*|4.3.*|4.4.*|4.5.*|4.6.*|4.7.0|4.7.1) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Only g++ version 4.7.2 or greater can be used with RcppArmadillo." >&5 -$as_echo "$as_me: WARNING: Only g++ version 4.7.2 or greater can be used with RcppArmadillo." >&2;} - as_fn_error $? "Please use a different compiler." "$LINENO" 5 - ;; - 4.7.*|4.8.*|4.9.*|5.0*|5.1*|5.2*|5.3*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes, but without OpenMP as version ${gxx_version} (Armadillo constraint)" >&5 -$as_echo "yes, but without OpenMP as version ${gxx_version} (Armadillo constraint)" >&6; } - ## we know this one is bad - can_use_openmp="no" - ;; - 5.4*|5.5*|5.6*|5.7*|5.8*|5.9*|6.*|7.*|8.*|9.*|10.*|11.*|12.*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes, with OpenMP as version ${gxx_version}" >&5 -$as_echo "yes, with OpenMP as version ${gxx_version}" >&6; } - ## we know this one is good, yay - can_use_openmp="yes" - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: almost" >&5 -$as_echo "almost" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Compiler self-identifies as being compliant with GNUC extensions but is not g++." >&5 -$as_echo "$as_me: WARNING: Compiler self-identifies as being compliant with GNUC extensions but is not g++." >&2;} - ## we know nothing, so no - can_use_openmp="no" - ;; - esac - fi - - ## Check for Apple LLVM +# check openMP +openmp_flag="" +openmp_cflag="" - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for macOS" >&5 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for macOS" >&5 $as_echo_n "checking for macOS... " >&6; } - RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()["sysname"])') - - if test x"${RSysinfoName}" = x"Darwin"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found" >&5 +RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()["sysname"])') +if test x"${RSysinfoName}" == x"Darwin"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: found" >&5 $as_echo "found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for macOS Apple compiler" >&5 -$as_echo_n "checking for macOS Apple compiler... " >&6; } - - apple_compiler=$($CXX --version 2>&1 | grep -i -c -e 'apple llvm') - - if test x"${apple_compiler}" = x"1"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found" >&5 -$as_echo "found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: OpenMP unavailable and turned off." >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: OpenMP unavailable and turned off." >&5 $as_echo "$as_me: WARNING: OpenMP unavailable and turned off." >&2;} - can_use_openmp="no" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 -$as_echo "not found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for clang compiler" >&5 -$as_echo_n "checking for clang compiler... " >&6; } - clang_compiler=$($CXX --version 2>&1 | grep -i -c -e 'clang ') - - if test x"${clang_compiler}" = x"1"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found" >&5 -$as_echo "found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for OpenMP compatible version of clang" >&5 -$as_echo_n "checking for OpenMP compatible version of clang... " >&6; } - clang_version=$(${CXX} -v 2>&1 | awk '/^.*clang version/ {print $3}') - - case ${clang_version} in - 4.*|5.*|6.*|7.*|8.*|9.*|10.*|11.*) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found and suitable" >&5 -$as_echo "found and suitable" >&6; } - can_use_openmp="yes" - ;; - *) - { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 -$as_echo "not found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: OpenMP unavailable and turned off." >&5 -$as_echo "$as_me: WARNING: OpenMP unavailable and turned off." >&2;} - can_use_openmp="no" - ;; - esac - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found" >&5 -$as_echo "not found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unsupported macOS build detected; if anything breaks, you keep the pieces." >&5 -$as_echo "$as_me: WARNING: unsupported macOS build detected; if anything breaks, you keep the pieces." >&2;} - fi - fi - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } - fi - -fi # if test x"${openmp_already_works}" = x"no" - -## Check for suitable LAPACK_LIBS -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking LAPACK_LIBS" >&5 -$as_echo_n "checking LAPACK_LIBS... " >&6; } - -## external LAPACK has the required function -lapack=$(${R_HOME}/bin/R CMD config LAPACK_LIBS) -hasRlapack=$(echo ${lapack} | grep lRlapack) - -## in what follows below we substitute both side of the define/undef -## while this may seem a little unusual we do it to fully reproduce the -## previous bash-based implementation - -if test x"${hasRlapack}" = x""; then - ## We are using a full Lapack and can use zgbsv -- so #undef remains - { $as_echo "$as_me:${as_lineno-$LINENO}: result: system LAPACK found" >&5 -$as_echo "system LAPACK found" >&6; } - arma_lapack="#undef ARMA_CRIPPLED_LAPACK" + openmp_flag="-DARMA_DONT_USE_OPENMP" else - ## We are using R's subset of Lapack and CANNOT use zgbsv etc, so we mark it - { $as_echo "$as_me:${as_lineno-$LINENO}: result: R-supplied partial LAPACK found" >&5 -$as_echo "R-supplied partial LAPACK found" >&6; } - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Some complex-valued LAPACK functions may not be available" >&5 -$as_echo "$as_me: WARNING: Some complex-valued LAPACK functions may not be available" >&2;} - arma_lapack="#define ARMA_CRIPPLED_LAPACK 1" -fi - -## Default the OpenMP flag to the empty string. -## If and only if OpenMP is found, expand to $(SHLIB_OPENMP_CXXFLAGS) -openmp_flag="" - -## Set the fallback, by default it is nope -arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" - -if test x"${openmp_already_works}" = x"yes"; then - arma_have_openmp="#define ARMA_USE_OPENMP 1" -fi - -if test x"${can_use_openmp}" = x"yes"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for OpenMP" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found as on ${RSysinfoName}" >&5 +$as_echo "not found as on ${RSysinfoName}" >&6; } + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for OpenMP" >&5 $as_echo_n "checking for OpenMP... " >&6; } - ## if R has -fopenmp we should be good - allldflags=$(${R_HOME}/bin/R CMD config --ldflags) - hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) - if test x"${hasOpenMP}" = x""; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: missing" >&5 + allldflags=$(${R_HOME}/bin/R CMD config --ldflags) + hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) + if test x"${hasOpenMP}" == x""; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: missing" >&5 $as_echo "missing" >&6; } - arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: found and suitable" >&5 -$as_echo "found and suitable" >&6; } - arma_have_openmp="#define ARMA_USE_OPENMP 1" - openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' - fi + openmp_flag="-DARMA_DONT_USE_OPENMP" + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: found" >&5 +$as_echo "found" >&6; } + openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' + openmp_cflag='$(SHLIB_OPENMP_CFLAGS)' + fi fi - -## now use all these -ARMA_LAPACK="${arma_lapack}" - -ARMA_HAVE_OPENMP="${arma_have_openmp}" +OPENMP_CFLAG="${openmp_cflag}" OPENMP_FLAG="${openmp_flag}" @@ -4070,3 +3633,15 @@ if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} fi + +echo " + -------------------------------------------------- + Configuration for goldfish version ${VERSION} + ================ + + openMP: ${openmp_flag} + cxxflags: ${CXXFLAGS} + libs: ${PKG_LIBS} + + -------------------------------------------------- +" diff --git a/configure.ac b/configure.ac index 97958ea..f3e94a8 100644 --- a/configure.ac +++ b/configure.ac @@ -1,13 +1,8 @@ ## -*- mode: autoconf; autoconf-indentation: 4; -*- ## -## adapted from RcppArmadillo configure.ac -## -## 'Rcpp' Integration for the 'Armadillo' Templated Linear Algebra Library -## -## Copyright (C) 2016 - 2022 Dirk Eddelbuettel -## -## Licensed under GPL-2 or later +## Copyright Dirk Eddelbuettel for RcppArmadillo (GPL-2) +VERSION=$(grep -i ^version DESCRIPTION | awk '{print $2}') ## require at least autoconf 2.69 AC_PREREQ([2.69]) @@ -27,185 +22,45 @@ CXXFLAGS=$("${R_HOME}/bin/R" CMD config CXXFLAGS) ## We are using C++ AC_LANG(C++) AC_REQUIRE_CPP -AC_PROG_CXX - -## Is R already configured to compile things using OpenMP without -## any extra hand-holding? -openmp_already_works="no" - -## default to not even thinking about OpenMP as Armadillo wants a pragma -## variant available if and only if C++11 is used with g++ 5.4 or newer -can_use_openmp="no" - -## Ensure TMPDIR is set. -AC_MSG_CHECKING([whether we have a suitable tempdir]) -TMPDIR=$("${R_HOME}/bin/R" --vanilla --slave -e "cat(dirname(tempdir()))") -AC_MSG_RESULT([${TMPDIR}]) - -## Check if R is configured to compile programs using OpenMP out-of-the-box. -AC_MSG_CHECKING([whether R CMD SHLIB can already compile programs using OpenMP]) - -## Create private directory in TMPDIR. -BUILDDIR="${TMPDIR}/rcpparmadillo-$$-$RANDOM" -mkdir -p "${BUILDDIR}" - -owd=$(pwd) -cd "${BUILDDIR}" - -cat < test-omp.cpp -#include -int main() { - return omp_get_num_threads(); -} -EOF - -## Execute R CMD SHLIB. -"${R_HOME}/bin/R" CMD SHLIB test-omp.cpp >/dev/null 2>&1 -if test x"$?" = x"0"; then - AC_MSG_RESULT([yes]) - openmp_already_works="yes" -else - AC_MSG_RESULT([no]) -fi - -## Go back home. -cd "${owd}" -rm -rf "${BUILDDIR}" - -## If the above checks failed, then perform other heuristics -## based on the compiler version, etc. -if test x"${openmp_already_works}" = x"no"; then - - ## Check the C++ compiler using the CXX value set - - ## If it is g++, we have GXX set so let's examine it - if test "${GXX}" = yes; then - AC_MSG_CHECKING([whether g++ version is sufficient]) - gxx_version=$(${CXX} -v 2>&1 | awk '/^.*g.. version/ {print $3}') - case ${gxx_version} in - 1.*|2.*|3.*|4.0.*|4.1.*|4.2.*|4.3.*|4.4.*|4.5.*|4.6.*|4.7.0|4.7.1) - AC_MSG_RESULT([no]) - AC_MSG_WARN([Only g++ version 4.7.2 or greater can be used with RcppArmadillo.]) - AC_MSG_ERROR([Please use a different compiler.]) - ;; - 4.7.*|4.8.*|4.9.*|5.0*|5.1*|5.2*|5.3*) - AC_MSG_RESULT([yes, but without OpenMP as version ${gxx_version} (Armadillo constraint)]) - ## we know this one is bad - can_use_openmp="no" - ;; - 5.4*|5.5*|5.6*|5.7*|5.8*|5.9*|6.*|7.*|8.*|9.*|10.*|11.*|12.*) - AC_MSG_RESULT([yes, with OpenMP as version ${gxx_version}]) - ## we know this one is good, yay - can_use_openmp="yes" - ;; - *) - AC_MSG_RESULT([almost]) - AC_MSG_WARN([Compiler self-identifies as being compliant with GNUC extensions but is not g++.]) - ## we know nothing, so no - can_use_openmp="no" - ;; - esac - fi - - ## Check for Apple LLVM - - AC_MSG_CHECKING([for macOS]) - RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()[["sysname"]])') - if test x"${RSysinfoName}" = x"Darwin"; then - AC_MSG_RESULT([found]) - AC_MSG_CHECKING([for macOS Apple compiler]) - - apple_compiler=$($CXX --version 2>&1 | grep -i -c -e 'apple llvm') - - if test x"${apple_compiler}" = x"1"; then - AC_MSG_RESULT([found]) - AC_MSG_WARN([OpenMP unavailable and turned off.]) - can_use_openmp="no" - else - AC_MSG_RESULT([not found]) - AC_MSG_CHECKING([for clang compiler]) - clang_compiler=$($CXX --version 2>&1 | grep -i -c -e 'clang ') - - if test x"${clang_compiler}" = x"1"; then - AC_MSG_RESULT([found]) - AC_MSG_CHECKING([for OpenMP compatible version of clang]) - clang_version=$(${CXX} -v 2>&1 | awk '/^.*clang version/ {print $3}') - - case ${clang_version} in - 4.*|5.*|6.*|7.*|8.*|9.*|10.*|11.*) - AC_MSG_RESULT([found and suitable]) - can_use_openmp="yes" - ;; - *) - AC_MSG_RESULT([not found]) - AC_MSG_WARN([OpenMP unavailable and turned off.]) - can_use_openmp="no" - ;; - esac - else - AC_MSG_RESULT([not found]) - AC_MSG_WARN([unsupported macOS build detected; if anything breaks, you keep the pieces.]) - fi - fi - else - AC_MSG_RESULT([no]) - fi - -fi # if test x"${openmp_already_works}" = x"no" - -## Check for suitable LAPACK_LIBS -AC_MSG_CHECKING([LAPACK_LIBS]) - -## external LAPACK has the required function -lapack=$(${R_HOME}/bin/R CMD config LAPACK_LIBS) -hasRlapack=$(echo ${lapack} | grep lRlapack) - -## in what follows below we substitute both side of the define/undef -## while this may seem a little unusual we do it to fully reproduce the -## previous bash-based implementation - -if test x"${hasRlapack}" = x""; then - ## We are using a full Lapack and can use zgbsv -- so #undef remains - AC_MSG_RESULT([system LAPACK found]) - arma_lapack="#undef ARMA_CRIPPLED_LAPACK" -else - ## We are using R's subset of Lapack and CANNOT use zgbsv etc, so we mark it - AC_MSG_RESULT([R-supplied partial LAPACK found]) - AC_MSG_WARN([Some complex-valued LAPACK functions may not be available]) - arma_lapack="#define ARMA_CRIPPLED_LAPACK 1" -fi - -## Default the OpenMP flag to the empty string. -## If and only if OpenMP is found, expand to $(SHLIB_OPENMP_CXXFLAGS) +# check openMP openmp_flag="" - -## Set the fallback, by default it is nope -arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" - -if test x"${openmp_already_works}" = x"yes"; then - arma_have_openmp="#define ARMA_USE_OPENMP 1" -fi - -if test x"${can_use_openmp}" = x"yes"; then - AC_MSG_CHECKING([for OpenMP]) - ## if R has -fopenmp we should be good - allldflags=$(${R_HOME}/bin/R CMD config --ldflags) - hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) - if test x"${hasOpenMP}" = x""; then - AC_MSG_RESULT([missing]) - arma_have_openmp="#define ARMA_DONT_USE_OPENMP 1" - else - AC_MSG_RESULT([found and suitable]) - arma_have_openmp="#define ARMA_USE_OPENMP 1" - openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' - fi +openmp_cflag="" + +AC_MSG_CHECKING([for macOS]) +RSysinfoName=$("${R_HOME}/bin/Rscript" --vanilla -e 'cat(Sys.info()[["sysname"]])') +if test x"${RSysinfoName}" == x"Darwin"; then + AC_MSG_RESULT([found]) + AC_MSG_WARN([OpenMP unavailable and turned off.]) + openmp_flag="-DARMA_DONT_USE_OPENMP" +else + AC_MSG_RESULT([not found as on ${RSysinfoName}]) + AC_MSG_CHECKING([for OpenMP]) + allldflags=$(${R_HOME}/bin/R CMD config --ldflags) + hasOpenMP=$(echo ${allldflags} | grep -- -fopenmp) + if test x"${hasOpenMP}" == x""; then + AC_MSG_RESULT([missing]) + openmp_flag="-DARMA_DONT_USE_OPENMP" + else + AC_MSG_RESULT([found]) + openmp_flag='$(SHLIB_OPENMP_CXXFLAGS)' + openmp_cflag='$(SHLIB_OPENMP_CFLAGS)' + fi fi - -## now use all these -AC_SUBST([ARMA_LAPACK],["${arma_lapack}"]) -AC_SUBST([ARMA_HAVE_OPENMP], ["${arma_have_openmp}"]) +AC_SUBST([OPENMP_CFLAG], ["${openmp_cflag}"]) AC_SUBST([OPENMP_FLAG], ["${openmp_flag}"]) AC_CONFIG_FILES([src/Makevars]) AC_OUTPUT + +echo " + -------------------------------------------------- + Configuration for goldfish version ${VERSION} + ================ + + openMP: ${openmp_flag} + cxxflags: ${CXXFLAGS} + libs: ${PKG_LIBS} + + -------------------------------------------------- +" \ No newline at end of file diff --git a/src/Makevars.in b/src/Makevars.in index 635998f..3054ae4 100644 --- a/src/Makevars.in +++ b/src/Makevars.in @@ -1,24 +1,4 @@ ## -*- mode: makefile; -*- PKG_CXXFLAGS = @OPENMP_FLAG@ -PKG_LIBS= @OPENMP_FLAG@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) - -## With R 3.1.0 or later, you can uncomment the following line to tell R to -## enable compilation with C++11 (where available) -## -## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider -## availability of the package we do not yet enforce this here. It is however -## recommended for client packages to set it. -## -## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP -## support within Armadillo prefers / requires it -CXX_STD = CXX11 - -## Armadillo itself use the following define which we also set -## automatically if we see USE_CXX1X defined; outside of a package it -## may be needed explicitly -## In general, this can be enabled here via -## PKG_CXXFLAGS = -DARMA_USE_CXX11 -## or via -## #define ARMA_USE_CXX11 -## before RcppArmadillo.h is included +PKG_LIBS= @OPENMP_CFLAG@ $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) diff --git a/src/Makevars.win b/src/Makevars.win index 7f0ae2b..3438d03 100644 --- a/src/Makevars.win +++ b/src/Makevars.win @@ -2,23 +2,3 @@ PKG_CXXFLAGS = -I../inst/include -I. $(SHLIB_OPENMP_CXXFLAGS) PKG_LIBS = $(SHLIB_OPENMP_CXXFLAGS) $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) - -## With R 3.1.0 or later, you can uncomment the following line to tell R to -## enable compilation with C++11 (where available) -## -## Also, OpenMP support in Armadillo prefers C++11 support. However, for wider -## availability of the package we do not yet enforce this here. It is however -## recommended for client packages to set it. -## -## And with R 3.4.0, and RcppArmadillo 0.7.960.*, we turn C++11 on as OpenMP -## support within Armadillo prefers / requires it -CXX_STD = CXX11 - -## Armadillo itself use the following define which we also set -## automatically if we see USE_CXX1X defined; outside of a package it -## may be needed explicitly -## In general, this can be enabled here via -## PKG_CXXFLAGS = -DARMA_USE_CXX11 -## or via -## #define ARMA_USE_CXX11 -## before RcppArmadillo.h is included From 58f65cdc6330c5ecf4a60b34d4f0c0ef9d2d9968 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Thu, 7 Mar 2024 17:52:27 +0100 Subject: [PATCH 28/36] Add missing documentation of argument in `GatherPreprocessing()` and fix some style code issues (`lintr`) --- DESCRIPTION | 3 +- R/functions_checks.R | 28 +++++++++---------- R/functions_data.R | 6 ++-- R/functions_gather.R | 17 +++++++---- R/functions_parsing.R | 3 +- man/GatherPreprocessing.Rd | 6 ++++ .../test-effects_preprocessing_DyNAM_rate.R | 12 +++++--- 7 files changed, 45 insertions(+), 30 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index a9fb5e7..25ab4f5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -40,8 +40,7 @@ Imports: generics, ggplot2, rlang, - tibble, - lifecycle + tibble LinkingTo: Rcpp, RcppArmadillo diff --git a/R/functions_checks.R b/R/functions_checks.R index ff64a82..bf90b80 100644 --- a/R/functions_checks.R +++ b/R/functions_checks.R @@ -15,7 +15,7 @@ ## Find composition changes events for one nodeset findPresence <- function(nodes) { if (!is.null(attr(nodes, "dynamicAttributes")) && - "present" %in% attr(nodes, "dynamicAttributes")) { + "present" %in% attr(nodes, "dynamicAttributes")) { compositionChanges <- attr(nodes, "events")[ which(attr(nodes, "dynamicAttributes") == "present") ] @@ -232,7 +232,7 @@ checkColumns <- function( ) } if (!is.null(incompatibleNames) && - sum(colnames(inDataFrame) %in% incompatibleNames) > 1) { + sum(colnames(inDataFrame) %in% incompatibleNames) > 1) { stop("Incompatible columns", paste( incompatibleNames[ @@ -388,7 +388,7 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { ) } if (!is.character(attr(matrix, "nodes")) && - !length(attr(matrix, "nodes")) %in% c(1, 2)) { # styler: off + !length(attr(matrix, "nodes")) %in% c(1, 2)) { # styler: off stop( "The network attribute \"nodes\" should contain", "the name of one or two nodesets." @@ -403,7 +403,7 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { # validity of nodes isTwoMode <- !is.null(nodes2) if (!(inherits(nodes, "nodes.goldfish") && - isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { + isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { tryCatch( { checkNodes(nodes) @@ -422,7 +422,7 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { } if (isTwoMode && any(dim(matrix)[1] != nrow(nodes) && - dim(matrix)[2] != nrow(nodes2))) { + dim(matrix)[2] != nrow(nodes2))) { stop("The matrix dimensions are not coherent with the nodesets sizes.") } @@ -447,7 +447,7 @@ checkNetwork <- function(matrix, nodes, nodesName, nodes2 = NULL) { } if (!all(dimNames[[1]] == nodes$label) || - !all(dimNames[[2]] == if (!isTwoMode) nodes$label else nodes2$label)) { + !all(dimNames[[2]] == if (!isTwoMode) nodes$label else nodes2$label)) { stop( "The order of nodes in either row or columns is", "not the same as in \"nodes\"", @@ -575,7 +575,7 @@ checkEvents.nodes.goldfish <- function( stop("An attribute should be a character object.") } if (is.null(attr(object, "dynamicAttributes")) || - !(attribute %in% attr(object, "dynamicAttributes"))) { + !(attribute %in% attr(object, "dynamicAttributes"))) { stop("The dynamic attributes for this nodeset were mispecified.") } if (!eventsName %in% @@ -588,11 +588,11 @@ checkEvents.nodes.goldfish <- function( ) } } else if (!is.null(attr(object, "events")) && - eventsName %in% attr(object, "events")) { + eventsName %in% attr(object, "events")) { if (is.null(attr(object, "dynamicAttributes")) || - is.na(attr(object, "dynamicAttributes")[ - which(attr(object, "events") == eventsName) - ])) { + is.na(attr(object, "dynamicAttributes")[ + which(attr(object, "events") == eventsName) + ])) { stop( "The events related to the dynamic attributes of this nodeset", "were mispecified." @@ -677,7 +677,7 @@ checkEvents.nodes.goldfish <- function( } classEven <- class(eventUpdate) if (!all(checkClasses(object[[attribute]], classEven)) && - !all(checkClasses(eventUpdate, classAttr))) { + !all(checkClasses(eventUpdate, classAttr))) { stop( "The type of the attribute ", dQuote(attribute), " is incompatible with the associated event list.", @@ -732,7 +732,7 @@ checkEvents.network.goldfish <- function( if (!is.data.frame(events)) stop("An event list should be a data frame.") # check nodeset type if (!inherits(nodes, "nodes.goldfish") || - (isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { + (isTwoMode && !inherits(nodes2, "nodes.goldfish"))) { tryCatch( { checkNodes(nodes) @@ -786,7 +786,7 @@ checkEvents.network.goldfish <- function( # "\nevents being checked: ", paste(eventsName, collapse = "") # ) if (is.null(attr(object, "nodes")) || - !all(nodesName %in% attr(object, "nodes"))) { + !all(nodesName %in% attr(object, "nodes"))) { stop("The nodeset(s) associated to this network were mispecified.") } diff --git a/R/functions_data.R b/R/functions_data.R index f690447..2dc5740 100644 --- a/R/functions_data.R +++ b/R/functions_data.R @@ -56,7 +56,7 @@ NULL #' @export #' @rdname update-method as.data.frame.nodes.goldfish <- function( - x, ..., time = -Inf, + x, ..., time = -Inf, startTime = -Inf, envir = new.env() ) { df <- x @@ -443,7 +443,7 @@ defineNetwork <- function( } if (!is.null(nodes2) && - !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { + !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { stop( "Invalid argument ", dQuote("nodes2"), ": ", "this function expects objects of class ", @@ -595,7 +595,7 @@ defineDependentEvents <- function(events, nodes, nodes2 = NULL, } if (isTwoMode && - !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { + !any(checkClasses(nodes2, c("data.frame", "nodes.goldfish")))) { stop( "Invalid argument ", dQuote("nodes2"), ": ", "this function expects objects of class ", diff --git a/R/functions_gather.R b/R/functions_gather.R index 3ee50ca..41ea974 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -8,9 +8,9 @@ #' Gather preprocess data from a formula #' #' Gather the preprocess data from a formula and a model, -#' where the output corresponds to the data structure used by the engine +#' where the output corresponds to the data structure used by the engine #' `gather_compute`; see [estimate()]. -#' +#' #' It differs from the `estimate()` output when the argument `preprocessingOnly` #' is set to `TRUE` regarding the memory space requirement. #' The `gatherPreprocessing()` produces a list where the first element @@ -23,9 +23,14 @@ #' to estimate the models (or extensions of them) using standard packages #' for generalized linear models (or any other model) #' that use tabular data as input. -#' -#' @inheritParams estimate #' +#' @inheritParams estimate +#' +#' @param formula a formula object that defines at the +#' left-hand side the dependent +#' network (see [defineDependentEvents()]) and at the right-hand side the +#' effects and the variables for which the effects are expected to occur +#' (see `vignette("goldfishEffects")`). #' @param preprocessArgs a list containing additional parameters #' for preprocessing. It may contain: #' \describe{ @@ -70,7 +75,7 @@ #' \item{effectDescription}{ #' a character matrix with the description of the effects. #' It includes the name of the object used to calculate the effects and -#' additional information of the effect, e.g., the type of effect, +#' additional information of the effect, e.g., the type of effect, #' weighted effect, transformation function, window length.} #' } #' If the model has an intercept and the subModel is `rate` or model is `REM`, @@ -82,7 +87,7 @@ #' \item{isDependent}{ #' a logical vector indicating if the event is dependent or right-censored.} #' } -#' +#' #' @export #' #' @examples diff --git a/R/functions_parsing.R b/R/functions_parsing.R index f539494..19022fc 100644 --- a/R/functions_parsing.R +++ b/R/functions_parsing.R @@ -447,7 +447,8 @@ getEventsAndObjectsLink <- function( ) evs <- lapply( evName, - function(x) sanitizeEvents(get(x, envir = envir), nodeSet, envir = envir) + function(x) + sanitizeEvents(get(x, envir = envir), nodeSet, envir = envir) ) events <- append(events, evs) diff --git a/man/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd index 53021ea..bb291b7 100644 --- a/man/GatherPreprocessing.Rd +++ b/man/GatherPreprocessing.Rd @@ -14,6 +14,12 @@ GatherPreprocessing( ) } \arguments{ +\item{formula}{a formula object that defines at the +left-hand side the dependent +network (see \code{\link[=defineDependentEvents]{defineDependentEvents()}}) and at the right-hand side the +effects and the variables for which the effects are expected to occur +(see \code{vignette("goldfishEffects")}).} + \item{model}{a character string defining the model type. Current options include \code{"DyNAM"}, \code{"DyNAMi"} or \code{"REM"} \describe{ diff --git a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R index a59df05..6b7ef14 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAM_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R @@ -234,8 +234,10 @@ test_that( ) expect_equal( preproData$eventTime, - c(eventsIncrement$time, eventsExogenous$time, 30) |> unique() |> - sort() |> Filter(\(x) x >= 10 & x <= 30, x = _), + c(eventsIncrement$time, eventsExogenous$time, 30) |> + unique() |> + sort() |> + Filter(\(x) x >= 10 & x <= 30, x = _), label = "events times" ) expect_equal( @@ -353,8 +355,10 @@ test_that( ) expect_equal( preproData$eventTime, - c(eventsIncrement$time, eventsExogenous$time, 24) |> unique() |> - sort() |> Filter(\(x) x >= 6 & x <= 24, x = _), + c(eventsIncrement$time, eventsExogenous$time, 24) |> + unique() |> + sort() |> + Filter(\(x) x >= 6 & x <= 24, x = _), label = "events times" ) expect_equal( From 9fa6ffe0e940d78f7a05c62c6a4ee72dc27247f3 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Mon, 11 Mar 2024 22:46:40 +0100 Subject: [PATCH 29/36] Debug opportunities list log-lik for choice model in a two-mode network --- R/functions_estimation.R | 8 +- R/functions_estimation_engine.R | 9 +- vignettes/dynami-example.R | 59 +++++++------ vignettes/dynami-example.Rmd | 107 ++++++++++++++++++++---- vignettes/dynami-example.Rmd.orig | 57 +++++++------ vignettes/precompile.R | 14 ++++ vignettes/teaching/plot-teaching1-1.png | Bin 1745 -> 1739 bytes vignettes/teaching/plot-teaching1-2.png | Bin 4392 -> 4461 bytes vignettes/teaching/plot-teaching1-3.png | Bin 5733 -> 5812 bytes vignettes/teaching/plot-teaching2-1.png | Bin 13231 -> 12948 bytes vignettes/teaching1.R | 58 ++++++------- vignettes/teaching1.Rmd | 3 +- vignettes/teaching2.R | 50 +++++------ vignettes/teaching2.Rmd | 4 +- 14 files changed, 237 insertions(+), 132 deletions(-) diff --git a/R/functions_estimation.R b/R/functions_estimation.R index 0e0d7dc..f30f5ed 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -811,8 +811,8 @@ estimate.formula <- function( args = c(argsEstimation, list(engine = engine)) ), error = \(e) { - stop("Error in ", model, " ", subModel, - " estimation: ", e, + stop("For ", model, " ", subModel, + " estimation:\n\t", e$message, call. = FALSE ) } @@ -821,8 +821,8 @@ estimate.formula <- function( tryCatch( result <- do.call("estimate_int", args = argsEstimation), error = \(e) { - stop("Error in ", model, " ", subModel, - " estimation: ", e, + stop("For ", model, " ", subModel, + " estimation:\n\t", e$message, call. = FALSE ) } diff --git a/R/functions_estimation_engine.R b/R/functions_estimation_engine.R index 58798d7..bf71915 100644 --- a/R/functions_estimation_engine.R +++ b/R/functions_estimation_engine.R @@ -872,8 +872,8 @@ getIterationStepState <- function( } # IMPUTE missing statistics with current mean - if (impute) { - for (j in seq_len(nParams)) { + if (impute && anyNA(statsArray)) { + for (j in which(apply(statsArray, 3, anyNA))) { statsArray[, , j] <- imputeFun(statsArray[, , j]) } } @@ -952,8 +952,11 @@ getIterationStepState <- function( } if ((updatepresence2 || updateopportunities)) { keepIn <- presence2 & opportunities + # reducing stats array alters the correspondence between row/col + # it needs to consider the reflexive case to avoid wrong calculation + # excludes REM and DyNAM-MM if (!allowReflexive && grepl("DyNAM-M(-|$)?", modelType)) { - keepIn[posSender] <- FALSE + if (!isTwoMode) keepIn[posSender] <- FALSE allowReflexiveCorrected <- TRUE } else { allowReflexiveCorrected <- FALSE diff --git a/vignettes/dynami-example.R b/vignettes/dynami-example.R index 9d62a7c..41bc7b4 100644 --- a/vignettes/dynami-example.R +++ b/vignettes/dynami-example.R @@ -1,71 +1,73 @@ -## ----setup, include=FALSE-------------------------------------------------------------------------------------------- +## ----setup, include=FALSE------------------------------------------------------------------- knitr::opts_chunk$set(echo = TRUE) -## -------------------------------------------------------------------------------------------------------------------- +## ----load----------------------------------------------------------------------------------- library(goldfish) data("RFID_Validity_Study") #?RFID_Validity_Study -## -------------------------------------------------------------------------------------------------------------------- +## ----headParticipants----------------------------------------------------------------------- head(participants) -## -------------------------------------------------------------------------------------------------------------------- +## ----headRfid------------------------------------------------------------------------------- head(rfid) -## -------------------------------------------------------------------------------------------------------------------- +## ----headVideo------------------------------------------------------------------------------ head(video) -## -------------------------------------------------------------------------------------------------------------------- +## ----defGroups------------------------------------------------------------------------------ #?defineGroups_interaction prepdata <- defineGroups_interaction(video, participants, seed.randomization = 1) -## -------------------------------------------------------------------------------------------------------------------- +## ----assGroups------------------------------------------------------------------------------ groups <- prepdata$groups head(groups) -## -------------------------------------------------------------------------------------------------------------------- +## ----headDependent-------------------------------------------------------------------------- dependent.events <- prepdata$dependent.events head(dependent.events) -## -------------------------------------------------------------------------------------------------------------------- +## ----headExogenous-------------------------------------------------------------------------- exogenous.events <- prepdata$exogenous.events head(exogenous.events) -## -------------------------------------------------------------------------------------------------------------------- +## ----headInteraction------------------------------------------------------------------------ interaction.updates <- prepdata$interaction.updates head(interaction.updates) -## -------------------------------------------------------------------------------------------------------------------- +## ----headOpportunities---------------------------------------------------------------------- opportunities <- prepdata$opportunities head(opportunities) -## -------------------------------------------------------------------------------------------------------------------- +## ----defNodes------------------------------------------------------------------------------- # goldfish requires character names participants$label <- as.character(participants$label) actors <- defineNodes(participants) -## -------------------------------------------------------------------------------------------------------------------- +## ----groups--------------------------------------------------------------------------------- groups <- defineNodes(groups) -## ----warning=FALSE--------------------------------------------------------------------------------------------------- +## ----defNet--------------------------------------------------------------------------------- init.network <- diag(x = 1, nrow(actors), nrow(groups)) +# goldfish check that row/column names agree with the nodes data frame labels +dimnames(init.network) <- list(actors$label, groups$label) network.interactions <- defineNetwork( matrix = init.network, nodes = actors, nodes2 = groups, directed = TRUE -) # don't worry about the warnings +) network.interactions <- linkEvents( x = network.interactions, changeEvent = dependent.events, nodes = actors, nodes2 = groups @@ -76,21 +78,21 @@ network.interactions <- linkEvents( ) -## ----warning=FALSE--------------------------------------------------------------------------------------------------- +## ----defNetPast, warning=FALSE-------------------------------------------------------------- network.past <- defineNetwork(nodes = actors, directed = FALSE) network.past <- linkEvents( x = network.past, changeEvents = interaction.updates, nodes = actors ) # don't worry about the warnings -## -------------------------------------------------------------------------------------------------------------------- +## ----defEvents------------------------------------------------------------------------------ dependent.events <- defineDependentEvents( events = dependent.events, nodes = actors, nodes2 = groups, defaultNetwork = network.interactions ) -## -------------------------------------------------------------------------------------------------------------------- +## ----modeRateM1----------------------------------------------------------------------------- formula.rate.M1 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -102,7 +104,7 @@ formula.rate.M1 <- dependent.events ~ 1 + tie(known.before, joining = -1, subType = "proportion") -## -------------------------------------------------------------------------------------------------------------------- +## ----modeChoiceM1--------------------------------------------------------------------------- formula.choice.M1 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -111,12 +113,12 @@ formula.choice.M1 <- dependent.events ~ tie(known.before, subType = "proportion") -## -------------------------------------------------------------------------------------------------------------------- +## ----modRateM1Est--------------------------------------------------------------------------- est.rate.M1 <- estimate(formula.rate.M1, model = "DyNAMi", subModel = "rate") summary(est.rate.M1) -## -------------------------------------------------------------------------------------------------------------------- +## ----modChoiceM1Est------------------------------------------------------------------------- est.choice.M1 <- estimate( formula.choice.M1, model = "DyNAMi", subModel = "choice", @@ -125,7 +127,7 @@ est.choice.M1 <- estimate( summary(est.choice.M1) -## -------------------------------------------------------------------------------------------------------------------- +## ----modeRateM2----------------------------------------------------------------------------- formula.rate.M2 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -140,7 +142,7 @@ formula.rate.M2 <- dependent.events ~ 1 + egopop(network.past, joining = -1, subType = "normalized") -## -------------------------------------------------------------------------------------------------------------------- +## ----modeChoiceM2--------------------------------------------------------------------------- formula.choice.M2 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -154,12 +156,12 @@ formula.choice.M2 <- dependent.events ~ inertia(network.past, window = 300, subType = "mean") -## -------------------------------------------------------------------------------------------------------------------- +## ----modRateM2Est--------------------------------------------------------------------------- est.rate.M2 <- estimate(formula.rate.M2, model = "DyNAMi", subModel = "rate") summary(est.rate.M2) -## -------------------------------------------------------------------------------------------------------------------- +## ----modChoiceM2Est------------------------------------------------------------------------- est.choice.M2 <- estimate( formula.choice.M2, model = "DyNAMi", subModel = "choice", @@ -168,7 +170,7 @@ est.choice.M2 <- estimate( summary(est.choice.M2) -## -------------------------------------------------------------------------------------------------------------------- +## ----interceptJoining----------------------------------------------------------------------- cov.matrix <- vcov(est.rate.M2) est.interceptjoining <- coef(est.rate.M2)[1] + coef(est.rate.M2)[2] @@ -176,4 +178,9 @@ se.interceptjoining <- sqrt( cov.matrix[1, 1] + cov.matrix[2, 2] + 2 * cov.matrix[1, 2] ) t.interceptjoining <- est.interceptjoining / se.interceptjoining +sprintf( + "Intercept for joining: %.3f (SE = %.3f, t = %.3f)", + est.interceptjoining, se.interceptjoining, t.interceptjoining +) + diff --git a/vignettes/dynami-example.Rmd b/vignettes/dynami-example.Rmd index 6b781c7..d0140ae 100644 --- a/vignettes/dynami-example.Rmd +++ b/vignettes/dynami-example.Rmd @@ -246,9 +246,11 @@ and `exogenous.events` ```r init.network <- diag(x = 1, nrow(actors), nrow(groups)) +# goldfish check that row/column names agree with the nodes data frame labels +dimnames(init.network) <- list(actors$label, groups$label) network.interactions <- defineNetwork( matrix = init.network, nodes = actors, nodes2 = groups, directed = TRUE -) # don't worry about the warnings +) network.interactions <- linkEvents( x = network.interactions, changeEvent = dependent.events, nodes = actors, nodes2 = groups @@ -400,18 +402,43 @@ est.choice.M1 <- estimate( model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities) ) -``` - -``` -## Error: Error in DyNAMi choice estimation: Error: Active node 1 not available in event 14 -``` - -```r summary(est.choice.M1) ``` ``` -## Error in eval(expr, envir, enclos): object 'est.choice.M1' not found +## +## Call: +## estimate(x = dependent.events ~ diff(actors$age, subType = "averaged_sum") + +## diff(actors$level, subType = "averaged_sum") + same(actors$gender, +## subType = "proportion") + same(actors$group, subType = "proportion") + +## tie(known.before, subType = "proportion"), model = "DyNAMi", +## subModel = "choice", estimationInit = list(opportunitiesList = opportunities)) +## +## +## Effects details : +## Object subType +## diff "actors$age" ""averaged_sum"" +## diff "actors$level" ""averaged_sum"" +## same "actors$gender" ""proportion"" +## same "actors$group" ""proportion"" +## tie "known.before" ""proportion"" +## +## Coefficients : +## Estimate Std. Error z-value Pr(>|z|) +## diff -0.107578 0.067179 -1.6014 0.1092943 +## diff 0.262945 0.225568 1.1657 0.2437353 +## same 0.292121 0.298317 0.9792 0.3274665 +## same 0.024975 0.384103 0.0650 0.9481565 +## tie 1.316141 0.378545 3.4768 0.0005074 *** +## --- +## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +## +## Converged with max abs. score of 0.00026 +## Log-Likelihood: -195.16 +## AIC: 400.32 +## AICc: 400.84 +## BIC: 414.39 +## model: "DyNAMi" subModel: "choice" ``` ### Step 5: Estimate a model with structural and time effects @@ -540,18 +567,56 @@ est.choice.M2 <- estimate( model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities) ) -``` - -``` -## Error: Error in DyNAMi choice estimation: Error: Active node 1 not available in event 14 -``` - -```r summary(est.choice.M2) ``` ``` -## Error in eval(expr, envir, enclos): object 'est.choice.M2' not found +## +## Call: +## estimate(x = dependent.events ~ diff(actors$age, subType = "averaged_sum") + +## diff(actors$level, subType = "averaged_sum") + same(actors$gender, +## subType = "proportion") + same(actors$group, subType = "proportion") + +## alter(actors$age, subType = "mean") + tie(known.before, subType = "proportion") + +## size(network.interactions, subType = "identity") + alterpop(network.past, +## subType = "mean_normalized") + inertia(network.past, window = 60, +## subType = "mean") + inertia(network.past, window = 300, subType = "mean"), +## model = "DyNAMi", subModel = "choice", estimationInit = list(opportunitiesList = opportunities)) +## +## +## Effects details : +## Object window subType +## diff "actors$age" "" ""averaged_sum"" +## diff "actors$level" "" ""averaged_sum"" +## same "actors$gender" "" ""proportion"" +## same "actors$group" "" ""proportion"" +## alter "actors$age" "" ""mean"" +## tie "known.before" "" ""proportion"" +## size "network.interactions" "" ""identity"" +## alterpop "network.past" "" ""mean_normalized"" +## inertia "network.past" "60" ""mean"" +## inertia "network.past" "300" ""mean"" +## +## Coefficients : +## Estimate Std. Error z-value Pr(>|z|) +## diff -0.133077 0.073387 -1.8134 0.069776 . +## diff 0.095857 0.231054 0.4149 0.678238 +## same 0.141033 0.321444 0.4387 0.660843 +## same -0.284446 0.418710 -0.6793 0.496924 +## alter 0.033538 0.017678 1.8971 0.057809 . +## tie 1.274992 0.393714 3.2384 0.001202 ** +## size 0.097754 0.093141 1.0495 0.293934 +## alterpop 0.288526 0.170532 1.6919 0.090662 . +## inertia 0.211654 0.458129 0.4620 0.644084 +## inertia -0.096613 0.235330 -0.4105 0.681410 +## --- +## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1 +## +## Converged with max abs. score of 2e-05 +## Log-Likelihood: -189.76 +## AIC: 399.53 +## AICc: 401.49 +## BIC: 427.65 +## model: "DyNAMi" subModel: "choice" ``` Of course these models ask a bit much from our data, @@ -573,6 +638,14 @@ se.interceptjoining <- sqrt( cov.matrix[1, 1] + cov.matrix[2, 2] + 2 * cov.matrix[1, 2] ) t.interceptjoining <- est.interceptjoining / se.interceptjoining +sprintf( + "Intercept for joining: %.3f (SE = %.3f, t = %.3f)", + est.interceptjoining, se.interceptjoining, t.interceptjoining +) +``` + +``` +## [1] "Intercept for joining: -3.434 (SE = 0.089, t = -38.477)" ``` This script can be continued by looking at better model specifications diff --git a/vignettes/dynami-example.Rmd.orig b/vignettes/dynami-example.Rmd.orig index c3dd514..095357f 100644 --- a/vignettes/dynami-example.Rmd.orig +++ b/vignettes/dynami-example.Rmd.orig @@ -34,7 +34,7 @@ First, we load the `goldfish` package and load the data. . You can find out more about this dataset and its format by callings its documentation. -```{r} +```{r load} library(goldfish) data("RFID_Validity_Study") #?RFID_Validity_Study @@ -43,7 +43,7 @@ data("RFID_Validity_Study") The `participants` object contains the nodeset of actors interacting together. The available attributes are their age, their gender, their organizational unit (group), and their seniority level: -```{r} +```{r headParticipants} head(participants) ``` @@ -51,7 +51,7 @@ The `rfid` object contains the list of dyadic interactions collected via RFID badges. Each interaction is characterized by two actors (`NodeA` and `NodeB`) and two time points (`Start` and `End`): -```{r} +```{r headRfid} head(rfid) ``` @@ -59,7 +59,7 @@ The `video` object contains the list of dyadic interactions collected via video recordings and has the same format as the `rfid` object. We know that these measures should be more reliable, so we will work with those data in this script! -```{r} +```{r headVideo} head(video) ``` @@ -76,7 +76,7 @@ More specifically, the model is designed for events of actors joining or leavin interaction groups. We can use this function to create these group events (please note we need to use the right labels in the dataframe: `NodeA`, `NodeB`,`Start`, and `End`): -```{r} +```{r defGroups} #?defineGroups_interaction prepdata <- defineGroups_interaction(video, participants, seed.randomization = 1) @@ -86,7 +86,7 @@ This functions to creates 5 objects: 1. `groups`: a goldfish nodeset containing the interaction groups (initially there are as many groups as actors and they are all present, meaning available) -```{r} +```{r assGroups} groups <- prepdata$groups head(groups) ``` @@ -95,7 +95,7 @@ head(groups) to model, when an actor (in the dataframe, the `sender` column) joins or leaves (`increment` = 1 or -1) a group (`receiver`) at a particular point in time (`time`) -```{r} +```{r headDependent} dependent.events <- prepdata$dependent.events head(dependent.events) ``` @@ -104,21 +104,21 @@ head(dependent.events) happen but are not modeled (for example, when an actor leaves a group, a dependent event is created for this leaving but an exogenous event is also created because the actor "joins" a new group, its own isolated group) -```{r} +```{r headExogenous} exogenous.events <- prepdata$exogenous.events head(exogenous.events) ``` 4. `interaction.updates`: goldfish events that are used to update the number of past interactions between participants: -```{r} +```{r headInteraction} interaction.updates <- prepdata$interaction.updates head(interaction.updates) ``` 5. `opportunities`: list containing the interaction groups available at each decision time (this will vary when groups are being joined or left) -```{r} +```{r headOpportunities} opportunities <- prepdata$opportunities head(opportunities) ``` @@ -129,25 +129,27 @@ Now that we have all the data we need, we need to define the link between our objects in a way that goldfish understands what is going on. First, we define the first mode nodeset, the actors: -```{r} +```{r defNodes} # goldfish requires character names participants$label <- as.character(participants$label) actors <- defineNodes(participants) ``` Then we define the second mode nodeset, the groups: -```{r} +```{r groups} groups <- defineNodes(groups) ``` Then we create the dynamic interaction network between the actors and the groups, updated by the previously created events in `dependent.events` and `exogenous.events` -```{r warning=FALSE} +```{r defNet} init.network <- diag(x = 1, nrow(actors), nrow(groups)) +# goldfish check that row/column names agree with the nodes data frame labels +dimnames(init.network) <- list(actors$label, groups$label) network.interactions <- defineNetwork( matrix = init.network, nodes = actors, nodes2 = groups, directed = TRUE -) # don't worry about the warnings +) network.interactions <- linkEvents( x = network.interactions, changeEvent = dependent.events, nodes = actors, nodes2 = groups @@ -161,14 +163,14 @@ network.interactions <- linkEvents( Then we create the dynamic network between the actors that records past interactions, updated by the previously created events in `interaction.updates` -```{r warning=FALSE} +```{r defNetPast, warning=FALSE} network.past <- defineNetwork(nodes = actors, directed = FALSE) network.past <- linkEvents( x = network.past, changeEvents = interaction.updates, nodes = actors ) # don't worry about the warnings ``` Finally, we define the events that we want to model: `dependent.events`: -```{r} +```{r defEvents} dependent.events <- defineDependentEvents( events = dependent.events, nodes = actors, nodes2 = groups, defaultNetwork = network.interactions @@ -197,7 +199,7 @@ For the rate, we have the following effects: if the proportion of same group in the group is high 8. tie known before (leaving): tendency for individuals to leave groups faster if the proportion of previous friends in the group is high -```{r} +```{r modeRateM1} formula.rate.M1 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -220,7 +222,7 @@ and for the choice model: if the proportion of same group in the group is high 13. tie known before: tendency for individuals to join groups if the proportion of previous friends in the group is high -```{r} +```{r modeChoiceM1} formula.choice.M1 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -234,12 +236,12 @@ The first model explains who people want to join (or not join), the second explains who people want to leave (or stay with). Now let us run goldfish estimation! -```{r} +```{r modRateM1Est} est.rate.M1 <- estimate(formula.rate.M1, model = "DyNAMi", subModel = "rate") summary(est.rate.M1) ``` -```{r} +```{r modChoiceM1Est} est.choice.M1 <- estimate( formula.choice.M1, model = "DyNAMi", subModel = "choice", @@ -256,7 +258,7 @@ We add to the rate model the effects of: who had more interactions in the past to join groups faster 3. egopop (leaving): tendency for individuals who had more interactions in the past to leave groups faster -```{r} +```{r modeRateM2} formula.rate.M2 <- dependent.events ~ 1 + intercept(network.interactions, joining = 1) + ego(actors$age, joining = 1, subType = "centered") + @@ -279,7 +281,7 @@ We add to the choice model: with a high average number of previous interactions with the group members within the last minute 3. inertia, window = 300s: same as above, for 5 minutes -```{r} +```{r modeChoiceM2} formula.choice.M2 <- dependent.events ~ diff(actors$age, subType = "averaged_sum") + diff(actors$level, subType = "averaged_sum") + @@ -302,12 +304,12 @@ All effects can have different subTypes, please look at the goldfish documentation to learn more. Now we can run again -```{r} +```{r modRateM2Est} est.rate.M2 <- estimate(formula.rate.M2, model = "DyNAMi", subModel = "rate") summary(est.rate.M2) ``` and: -```{r} +```{r modChoiceM2Est} est.choice.M2 <- estimate( formula.choice.M2, model = "DyNAMi", subModel = "choice", @@ -326,7 +328,7 @@ We now have for each rate model a general intercept and a dummy interaction between the intercept and the joining events. If we want to report the actual intercept for joining, we can calculate the following (for M2 for example): -```{r} +```{r interceptJoining} cov.matrix <- vcov(est.rate.M2) est.interceptjoining <- coef(est.rate.M2)[1] + coef(est.rate.M2)[2] @@ -334,6 +336,11 @@ se.interceptjoining <- sqrt( cov.matrix[1, 1] + cov.matrix[2, 2] + 2 * cov.matrix[1, 2] ) t.interceptjoining <- est.interceptjoining / se.interceptjoining +sprintf( + "Intercept for joining: %.3f (SE = %.3f, t = %.3f)", + est.interceptjoining, se.interceptjoining, t.interceptjoining +) + ``` This script can be continued by looking at better model specifications diff --git a/vignettes/precompile.R b/vignettes/precompile.R index 2a5180c..c5209c6 100644 --- a/vignettes/precompile.R +++ b/vignettes/precompile.R @@ -23,4 +23,18 @@ rm(list = ls()) knit("dynami-example.Rmd.orig", "dynami-example.Rmd") purl("dynami-example.Rmd.orig", "dynami-example.R") + +# check if the RMD files contain errors +lapply( + list("teaching1.Rmd", "teaching2.Rmd", "dynami-example.Rmd"), + \(x) { + text <- readLines(x) + haveErrors <- grepl("Error:", text) + if (any(haveErrors)) { + paste("Error in", x, " on line", + paste(which(haveErrors), collapse = ", ")) + } + } +) + setwd("..") diff --git a/vignettes/teaching/plot-teaching1-1.png b/vignettes/teaching/plot-teaching1-1.png index a8d66363f80ff64b59f69c2b5062cadfa4bfb0af..43d7b07b249a333a8aa990a3027df526f2f5abbf 100644 GIT binary patch literal 1739 zcmeAS@N?(olHy`uVBq!ia0y~yVEh5X9LzwGiQo8rffQSSPlzj!{{R2~(wp<|0$H2| z9+AZi4BSE>%y{W;-5;Q;Y)==*kcv5P?{MecH4|{SnDT$Np41kHOUFKLUZT!hdH$xu ziJg6RQy%8u_x$zk3sXhghrmPbobswQQwTCbdH%26@$$dcIfozb&wi*8xAXp?@o;fV zzmT05gb`)Gr+A0+wfVOmKa`I@py;hvCH63~17WUw`S!PSREYQ#Phu?1JewZ#WubKnu{r~4DJvWS>cH_x) zj`PQm`~~+Qh|wDJQ}p4b554E5&kN4Gyrc^*dCP2%d5`_=GMhvHXMO}a$<%Vs>aWti z^WK_0RL@I!FzK7JO)|_TY$0BM;K=&i_|nf}WfC{#b_>{fb)bf>P#rsapL@&vr#CpK ze~34Kqw{gwQ<oqv=~(PsbREO3JQdZ;?>=R$MVhxG=nn07PHvj`TdV|ci;7nT~XEP7ZQ zV*k36F)qOO$7V6!^N~_mV%O5P7Z~hYH6E_te#Eq()pVU(#WPqu+`rwd!_{{80AGRAjg}b`l_N$KepTjNB!;mt}Uj04&x{EpGm-?aRA6@x-g$E5!_xt`x zj+2@FaowxMMThd=rBswD!!z2StUr5ydFIvJ6|I}}^_=CjXoKs(NJq<3Fkb;PS(ej} z_I;V_zH5H<5;oKS!+dGBzA#jM{fzzL@~Sr5;i`98)%<3tQ9R`SQbe`p%JPS?yT7Z{ zOj!fU>id_T&%bae-?PGQLs`XonfA4|mJj)jcf!31V*Ed|Y<*AlyH{SuhvN5j3GTji z;p)Pc_#-{9kI4JP%jYY>{eZ?e%Vq!X@-e$K->4tAXOtj^$iffzMC-+*+CJDUK$ z)&g46X(e#)|07vomPi7rw0}RbdijU*!t;{*{ygE>&-k!%CM;3F4Z3pZ;orCelHC0H z9zPUM|5#-jZrk}`jSH4Ai`S{*DR)R)yk2nLS!m*AK2$EZLQT@3~XPT?_qvx`S~gDPjdWMoZJacM@tXw zPK{4r8OT*HySN7u1^rQf8k65%wfC$D1BN@;ANEJj@^>HdSF|YynY`lpA%5$hQrqTi z7yc)Ic-rT(jc-5cqZFp_xI|%WpY{8-Y_j+^_J@*g2yd@&J#@ZSH|nYqv*^DpHmR-2 z71P_r-&iO=j8AZb7w_?#&o)2S`@N(4!x~?h)>X1~v(vwFh b@k%_a^nJO%EpKK5>mmkES3j3^P6%y{W;-5;Q;LQfaRkcv5P@1D++wiICqJpcdy7ly|=Y8_7_g6#DopX+Sq zI1xQ5dP&cd$MTcx-o-I|7qIjCq498WOTQ37#y9@|8~=;NZ~Pz9@_*7w7fyNAKgrSd zDrNU>?`}!AKjaP+sG0I15X9IT^keP$tKrd^(-t4@kGmr-7X2>f&}J6m?0NJs{CDfh z$0_FjJS&ob4*RE8ZlBV!zw^VLNAo_E@4q9s&#Q68-b24VKP6ZDdi{_$UWwHMZtd}J z*veKu?TdRIG&v?`r}o;Z%t%gzx%L0trSBfi+x-4qpMuS9L0}-f^sBnVVL$hSjOULP z!iVx}*lu-v2vl-K(|TRH@SnxBkl0j36w>9%anX%sTo(?;&5oZJzrp)c-Js z@tkMuvByyLFE=~RRd?r$$d+_PPyl}Q`(Y}d_s9K*#@lJ%Z~gZF@s#ttFeH*z`q>$C z{-5or9`bO#iN>FkM$%8qQ34<4GemTl8rM9}{&@S$oDb{%|9ZIK=-J4Vj%;VY`8SK1 zr>n+*9plGu|6=2@{~YqF-q1Mw+Wf(8-dm3!8iDAkWAC3Imt24BHjJ=hA2+_n)l(+%5f1QMaN&heO%??b(KF;%XanN$k2W+Jnt!5Y=RRlG~7}TzyIQUTYJ-O z@p*>pY7DvTJ3h>LxAw!==TAY%+x?g4{)V>qBy4qDx9y&> z%3I>NS&_afapd_V{Pn-C_^-Z+bLq{+9oI@rpLP zaThcDd;ez|z1s0%{U6^$`3@CzZ;pOwydQF7&WAuIH(-fUS<%15-AumcL%)u(1ZV%& zGZwA((+Ytyh!6q?)&A7G*-KN!?V3O6xPeNxcij8mJuc)vqfB0S9<+>l_2a`E=$woci`TNt^pT`~L6`y#2h=|GRV zq#nLr|14#@zKtiU1A$(9E?pUJQs}!|aGoV1fgy_RDAhkFvd>RlYvlisKW!dTg5IC@ zGx*r6*ZaFatjRq6;q-o4{S8k$TK-!rcfsP~|I%-b2HWl)Z&7z7wl09UU`0KnNz8q@ U;#8--z#56c)78&qol`;+0IbJQ;nl7hs(>$qtR$LH#e`xTMx=$ z+1c5BX|R!y4d`0HmecLSZm|vF*jtI~v1;!9=DkOpP7zkLPlS zE{vCnozlZNQ}Lg+V&`9TyT&J&l^*;WRex3Yno@=D6env_^fc=dGVX^Fm~W@A3K!<1 z#hd&;*~Y|;&C1-HpX``>=huJ^EOW1F!=AkE>8{3nNDPk=&bCe4YoIEZ&Pm0oXSy$x zKsihrPMxO%X=!D4fQXDO1>DopeNM4}@Ig?c4F2;|5+@arzch@p<8jch)_;nh9;?VAR0nn2nl9_yf(=P*;fu5oSVG1J96VNzm|}SzJUWXfrdXX_uy6fb=L;$+ z|MT`5N!hy}!8M4v%ENGt9jBC1C?k8g^6?SYSta=0huK6>fK4P;Ir$ zp8{>R@J+u0?a&j)b}R)mIP1uInw`{rrGGem*6|~O4ph69=q3PbC&AkV_-GIMq$@rm zNu%%{IW=g+PrYFum2HA(5t~TNJkvE^hX?U2a8(=7qzlC!S3H3Z0A40tyfy>&ggwdc zjWoi=6lk|UC+?AGUxFh{)Zi``VVOYukBH18w%|ZM-cD6cVgOW<|EDvA`R+j*n|Z&6 zrSd%XD6(Q~{V+2>6HM#~T&naVa6@i0{aNT}4>hyu6-R;#(C*T~W$FM9k6cZgqe{eL z)b&3OYuYLdf~<+i`!XXf5n_#w3!{mG(W)LquF={|Xyyk|gqW#t#*jYv{rl~l^%Zr~ zcN{X;7OhY2Ad$Ca=I5y9i3eIfT-)G07ZPKPq)nf`sr(I2QrtH4Nt14#%uT?!VB2{3 z4iwmIh(ve%C)>1V_}80eN!NFtYD#qLvJTf0yHgnq+?>*i9c5o*V+K1I`*ze^Xw{=V zF#)lx&3L?u2qHvyi{+JN4&AN$msbQ9;3@xSdJv3%>G&rB?OuaDkx|r8(RhKBmhsPw zVzF*tD@}blp3Z4y){nsvKCmy=g;1u8Nrc8pA^bmubuI3*UZqSVUy~)RVEJSM(iJup z62|CG^+|*rCEB5vb$ZS;G-B<>E+wI3?O!%xKsv2!h4;JHMdRPXV-rewTtgbHhm+z( z@q0o&KOJw%?lH|h>Ak8&GHg+~gwtt%**6v6t8#a=pz_eC7XZi$lduqs~$~F z7qPc79s3rDCU$3x15%l(+DKY;TKB^Tz`23xwp!i1&Od+aNP2V%kkpX0I=69=F&!k` zPdb82m=+%r!Ye_WZnFR@#zQBI@HV}Ze9rAR*wte~DW*HesLI3)2!GD0a%iWnSegOn zT3VElppwGBkws{k4C%3H;;tOLTy)5u&_0GQSBaQ8N*N+)J=0s9^Nq~}92PVm(6o7Cx-8FyuF0mi7a z`nDG5OQ^be)7}C3R3`&kP#jxo&j!699FfKR_sH9vTt&w;0|u71zL1*Z)_H?n^MI{Q(8tuTW(rrJMa!O!uAr$GeVg>rxg@*xhIwz4~HnO0b!M9i+2M{=r{e*Z)!Q#boLpNygTD^c5$Z zuCijTS}qs=t20!L8}oMZy>!GK{}AD605*xI=YJK~kWGW}(U48d^Y)=(1SvrLxsYUB z7!$P}19N5P1vp9irPGET!Nb&*VGc$ZZ>RIYit*N+7q%<*e`YMZR}@kif#^9UpOY3q z5ITn;u+xpwmGZ)vLPW8~S7d1^Yz{t$aoP*Wo~&WpovxBMh2Gwg?A`t`{^EK7Rbp#- zS$s9p+%tp0E<=WfDjk=R2l&~_Re@RaIov)`+hyrH2k3g!b>dxz@qQT$Y6PgUz;B-Q zmk}s^La||};gj~d!THES&%-(@I`Z`STfXo{n{41x%)?y(E+NX%k^X{xP}uJ~L1=IP z{h^gHuP)YOnYwyZ^a%NjV69W#r4FQBZapxI(8QNXDcNT$0>|Py>$HClf)PgGp>#BY z0nF8$yoz$5)Oz`N4P<7(53)3{VE6Q~X5Zt7RSr2aagLWt#$erkGRvQU>WT>zhEpeF z^(A%JAQ&6*`-egV!{`IhDz-bRJNPxlbIzd>5?E^~RmE_wCrak77U7SbK6#GenJbY$dpxcC2)HcAXG65Qk`v9=DZo| zm`7C}@B9zCQfen38&k#4zrlxwRl+3>at?$hC|;l1UebFL@)tEf zmQ^;1im|o?r>dCW$P&G$!M#QjB(3Jp4(GNmTs&g0n0TCuRE8YFj{7Y$ye;?R&Kv^7 zg`VG%D<8OaxBqIFU9q*MA|`kJb7;TVLJ7&SSiMRi<|*uM_}n_KJm9^qD7kOXQANym zt{Ibaq+fYf))z&t?k71>k;&Od1}aHDA;BODX*Z2{KIKqP+O!ut24DxSRu5(f{*_Co z*owY`ifldSd*6M~K`fu|7pcILbH+E6>K~1uS?gbS$){)`R>qupwJzzN&Yh0k?$VGS6T+WnE>y_gMu{qk<`0Z;fMy zEXLo1p8f)DVltnG&}y8^FD|bys#NM|_8&@ISb9g$#=V7lR%X|PNA+?9rX^+|`#PIz zTGRQ^O<`2kx>x&8y_w0?iRg`fyBWvTa0$5bkL z!w5GLlWh58m`bma{*OkwX_2wcH|&q9HYomSneW&zKE`;TR}#kAaDypsMSh8Dc)obH zbd5BhTa#aJ)$-z&xb9NuoL&35ii#lXI$PcTrounB&GaKN1LB@ zbTTP-56`G@(u(s1?FWtCzIn1}xM@6m@3@w~R)A{aCD6Xpx$|nvRu@iHD25`zR~PE7 zQtgk-vxzEJc_byW&={gCEF*J_Am`VW{A($*T0SN)Q;&$~TWkC_7{iFF>}B_dV zhW~WPmNe{;yWKKqs9e4z=Pk>cy`8V`=rZk3bTkx=9Y{CBB;z{zg{K9JE&k7DqRS3r5&oQUC{4YF$;FbZ@DJo_q7 zS4Q}>on-P_b>^RGRG7^jk9OvzS}>m8gbWJ4U{+s*>;<~b;Zu(nYXBY}@ zffiU?0_6HNm9-6nkPu9kWNh2%k+|^6oL@mdkHh*_XJGBz6_ zIXUXG&NvZA-q>$i&EN}l)DB&Ccjl0Y?QL=+)suhlNQO5AS<>z^_HP90+cA%K@nwlJ zY8K4~*T!R(?bjC?`J}vM8x!^v2daKtn~GZP6J1GR&OIwd7nRSPH^_i)ew9EJS8cv) z)|$U`|Mg}E>-uW@<&&s*l>A_>zDQdcywR+pzXSL1mv#5dgV($CZVe2*ea2&U+z)wu zQ0xqN$W;27P)+4UzTa_B&FE962mi*`Oqo;G#PA-ozP&m947AIT;t3P!M}XuNa7w9h zDQvMgXVTyX3Ul-*QmF*EZMg6zxFPfuD1RZ`O_F-qB_D$I+%9XjjTB2jk*@>0iuN|H z6mr24MlO`MJVa7~j>_RnvIv=G@pz!*i}yEFAwLRpQx-(2*SYj|vsBdJhAQVK`p&N< z1KJk*CMX9zzH-sll#&B*vM&nog2Szq>ESNP;o@COaNGmU!U}JL&#Ay4;HTtkM@TAy#^PS&3rwnM zo4>y!%&_W882oxqKCTk_l2RbqctqmB4~2DZCQE8s{1C=p7?+Z^u9lNx6Y2vP8RDH zrmHmsn39Q^x>Xl^ujHw=0exM~br)OzkZ_|^haW#U**(gEvO)e!bMwz&dwcpSd`o_A znMGc0kPjY7dbp~vHe}QTp% zsb+U`G1WX=etd{MNwWpZ6l(*r$6tRA{8s$SZ0;=Yl)J0G2fB@K7)TU@3lppGC%v;g ze-LZ5E^~12Om;8s@gzKt{O4EOe~$0}`%u3lT{oOoT2M!X57n`MgTO3K*_c+Ec;5Ig Dz^>P0 literal 4392 zcmb7|c{tSF`^QxzTf!hp_Wj9(GG!T$&}1EJWEpx|WSz(|%rHqxBU?m>A!V`@T12Lq z$cI8CWQoCu$ujgIV}$V=p6mKvzdxSe_j-PRoX@%M`#R@*uKPak>s;q`Zadf`Lgcmym{{Z=H})HEw^>5fa~OJHCv>afACFSy`C5U>-0F zl4B~g_MOU)Jz8wH$f?3UoObN zfZ6rbiZ1U;U}H0_jAt=?@bwCG24@k(nABIA)9_6d5SL~Em!Rz-W zh-GHkH){QDmhC~rm6UKxC4K-g(e^41rU7>*wTBYEhB)G6vb={EAoA}gYBuUv+>{~y zw{OxDtiCv|tdN2V=?U9K+t**KW7lsy%MQD2B#7>y7PB|%2xRB=xM6d0r0f?n&}cd) zs9bYCiZE&g%0=jF#EJI#lh`IMPYUR-%NBG-&B0lh@&dYB-AG6TZ4#?NYkg{NBo^jC z7Twwo$Fd=ARquMQPlvZ{sDIp94-oB-qIYiZ)Hyj(LC@uXU2n#@6CY}oAjCwZd#pA@ zndZ@wXa?2{wAU-lsS@c+zB)Q!=;7N{7QB-47JV>&=dfyA0p4$=Q(L2tm*p z_)XfBPouk&k094Utyc$L(r@mP^A_~?l|yG_Ow|VGw@4}!J{mi}DuYg;JJz6DGfx(6 zX)B8Ws1NEt@tBb$UdXAADP~JEmd^fhcy}>douQw-8Uyfu1-DdFa(%LZp5}ZhE0ADn zT^!2P9ZtnXl0&)ojJfk`Fx z@oa0dI+Z{1Y0N*#UDJwN!1x8-pHh#F_GZ_*K2)r-n0>{0>v4f;K+@z{YYhQb6Wu~r27(={1doJzfw z)3=J?b^E!}21x(eY!`E?7vVtG`4kGK(%au#_I8fSi$zU4khR9UM)j4@GLR}Omlt!h z%1UV^7}vf1KQmx4gnr8|BcQ$JeA9R+*o|-^L$Ia${jRB0uTKF;1cAytO=I1XNUOqP(^`Rd_-aq2JdVx0ea2YAR zgmR5#b8|a0_N>ZmfMl4p?Rub}mtJ+YjMl1(OY3MuPw}eyi1=yzrGbu8bMIOLxN6&7 znfE#u!M`@+PdT529{-rU9BZL^_eF9^!qKC6Jb#^gM{=KV01+#xVe!roZirYOQB&UN ze_Z)<%3ggz+MTfIU@rpK$|rHD-`mZDm1c;_>Y| zuImBCqsMMK8dK~}t*aUTtE`5zx8M zCVKI*fW5(ktDo?e$v%3c3zfUaH?FcWO?Y!?1NMj$4+34@V4Uo0AC#l9;&J3)seo1B z;aF*&C+X=nuK(AmL1k-Mb zj_pxaj^iwz(nm+_#nl=a3^*GL_jNR5u?EMw6e8pnc7xvd-tRRR;}%1jFY&DOk5`Fw z79@Tcz4}{4BskyEbwTb4)O&qN5MMa%Fy_5^1QzQnho}Dh(f>BA-b-q;X`Nglk$7j8ms3fbSPQl8>}DaCAFiw-&W}3>v0{(U^p?# zM>P(F>KtT@Z%l!V;0Fu}Cmi-0e_jn$Mju`ALc=~)M67iL_FH*(jiJ{6`WUKZ6_VdExv$n0BPg)sFOvI9efs*MQTmNLCCxRlzk!D`LlT~UFS&0+t68xjr)%k7kD zj#~cIvdTh7c)s4ZEY)TPDh9bTuWG$m>6W|DZUN@snnpQ zr)V+NJT{Ph2tSVd@L{o~r)!QW2k7OWH~R-kVw9SsxKNa-3s_V66zrCt)zxUKo1 zi)_{7@QJ0`DU)PO*UDO&R_b8UT(w8bm%cxsv}nA$X@`Sa;?nZ3nUimH7Zr49mIT;6 zn?|y_YD(Pmh{HC?n}&nw&aboVihq$t3^K2Wv^9{~ee(UH$L=}C|8k8n@*nwTD0dEg z5xSzxpVR!}!|2l(X(?0rFp;C^KVI+r;U~kQ6HOV&rhq%kx|c7 zE`LL*YUw4D^0G(ll4M>_w_kdJD;%U>eO(@VqJr1E+h+deb6PZ7Hf8Cv1a-}F6Oo0h zT2PmXta$&j)2uAj=gh&FNog#59HB{dqYX>5*%uyX6DD4Ldiz}O!I|;{Of(J02mk`#yS#K5}FG>Q!VZF8$Cs?31^AhN^=Z)qH`jLZ7kk;Y{W8a z_EJl;;Y74rhP+)J@^DSVe{f-qiiy?TlSfVXtT2n=>HqmSemjMyt=s z!SQ)mf@$aSQ2yo=w(JR1hmaaWFil0SujP*$p-GPkYjbkPm!n4^n|jnQo=mU#)`B^D z;DzqB3pI0}J*l*uf+&I%kgPl1HjQ^5DJ@Cv8Y%NB(9GFO$e}m1PEqPT&3y)|x>D@; z0UO=f>Rf6qFObt2G&n|S`KCb0WiF-X4FR*32Rz*2Q>>0ROd)dMf$>jnTGCbfeS#W2 zKH~!WZ?zzE9|}OA&39kCyUlv# zRpE*TikET0pock3ivB{vh*A8`J-$H~QI=^>pdVJQ4>p{|yuVMhum|-ncNNlZYyp_S zT#&_hBAxHZ%jG-L1nFyAF_$?k3FGn)WF{aXdSKuQ{Ce}QTQAG^{wo@Y1pEZ2k_l(Q z`oG>h{F}`#0f;_OavrOc=naY;9G>12P`d-5Hs<+QfM^YhS1N5<^N_g80wnEknoCOZ zp@n6-pFBzS%k=(B;D7y9HMC*GDHZ}qH#4(4jR9%it(*3f>eSZvsnCB7Q?ilV&LH**&UBGu9i@q#bwSehk8Bnlz1(54A;+1empH zj%B!Z7y)*BT}6!m697t-;Mh;;?4{Mp0$zo=BvYb4TzMNe|3Yvfta86NGK`y?!tGmv z5zqP3F_mMdJpaanbj(-qe0p=H*!F0rXYBULhXpt8epH38HeYW~oJvc#!u>9@pwkmt z?{F_Uw$>I!7}3U(W|FhxRI()0yVV&dOAv~cR!4=4SU9x>_t{9ewTcFM3VlX`WzkQN za#g2x5~PdlgCZ(z3F$!#Nj;ZQ2&SPtAlm27)e>Cx5(CeR`05*5+Zxjo4 VIll0S`-s6~Wod8m?4;1tYgW(gfx{!b{CI>L_jPoEXS=Z z%^X=+SQ-D6V@D1pIluXA4;xj7OHSr2ZL=)x7g&0*0s;ck($c!Rx>v7Wz5e(hubQQ} zxOgm=g&4fc2)}c1z4zeYAVb>b&z`JWQ0sBH)`@|+st;+TOGAwuK2rc%w<-a{rqkg2M&xc2sp=1E@q=$ zdVs1lhQOtsD1q?;|ChMJpN7NXD%793y9*uca&KPwvn0Q;uRJs2OB3oE=YMAnn@3o2 z-Z>dy9BqN9j~q6Qw)kVGAhOF8;vz+QkH_0D+k6B8rQ6&7Q%u!9BP@QZ>OKR6hHjRo zFhFfE2!&yT#?2(Uc*=BBZ|=hdUMSP3x|7jsHaQK#wxzfV2KUn3;!NSVY3B*)e8y-| zPEIwzzrtW1n~VX)43bp%kzBC!Ach4WO$d6&po!u(`j#$1z7ri6SJa)@Y22AZrA`bV zF8;?EAr)a%a8Nnj#}M$ik9yLyCQerUm$x>}U=aI~Enb?>zdVQ@-5(PJMEz$B0MUOr zc#$iiN)Myk^X^aq_8io6uyDm}UGh{g8*9_h76Wz_R0McHkbiVu=LQzvf#a=%|L)(}sGttrL=#3{Sx3pOS`{=|2 zCeu>sI|3fgMizGZQeal3YLJiW=`{fA9mpzWGJCtbHgPlpfv|jADmJNoj6f+1++Rt* zCP5}-vr!v=eqpDf(OrmnyR{8=nj5;yx+G!;CXUTZ>r><;yW|T})m}pLek;`{F$AB# zj8GhvHRSep)Bx0Z&h3DVhTIC!a=)J1vd1%$vVMf8o>EHd9aA{FcP7zV$3I9wv9)+aEyCJ8d6P%bd`;VnQ^{XwML zTs4TSD00HykPEQ)qs@y(bd5*=zTN`J9W4$XER-BJqAp2RoYPLIX5%T=XNzcJqwzPC z7<4`R2s?h+Aj zjS9nR+i0pPX=Uj;dBuOPvK&e)%`Z(PM2QsWjKGUL#<}FfN2%+Dhj4P52F7&Uz z{Yi7~hCR30_KdHk@=ewRCtDzH#t~|FJEy~Q7~cmh*z^T&cod=0j1L3n$)aZCh=#XO z#Zxh1cg@9-)UzAceubpf-f8a9Yuos=!UnBlC37!6{P^I@`QABRTT7z2lY>BA>s!lfvvsen_Z?bhOrmdyYF~=>JU-)> z`LMluzuQ|5C0Tzz>aU9T>!(~sB>hT`fRVpo26vSsy~!hGa{IKQwh{b#IqDw6RscMc z6*r_7-1$_Y{Z_9C5fy! z_%r)^cY4SkT1HIOl)BUgvUAI@@-$h4v4c8BC(2P{)}?IW

y&q&Od%tUY#p3c* zuktJJQ)h5Wc1W&K0V8)O)HllSohJB8Qc$+Z4xC%t%!&7w$hkqx zR@qVkmZ!%yGY>suC31pl*u2RWU=FR=z9*pZBfGRTdQy#es#*ZM=VMeWbh`6f&Uf3; z(#7^OQn50d!wAQs`%Qn>S%Bw<`&?Z6`O`Z!L6oECXD`ilPUZbH!g(i9MGtWgjHlewYK&)e`U;f&4m2pF?ld;B3UYFfK-dF=YGXzz? zWqLUZ- zrdTvgtY!9^M)OXY#~SL&MBHoP?OXuQkgCshx27|dS!5zM58JLJ6NjF)a+Mz z5-*(!v3OY^>aIJPFeI69Q*uj7uzde9nOqnkxkrCPrMTcahueZ;H2l87WWdZhUH2o5BdFy@D1qj~Up*Inzbv_G^3W z%D^ruj6$tq{MoH3`JDCH>pR8{d{u#>fz)3|l1uFsyI(bPD*zC&Zh&MdA3N56QAhsh zO=|;BMPL#3arJ(N)8NrhwmB|DuC){bSmX}EEqqCRnw6$_>66@|PbUguLEC+2Fc>^D zSRa-4Dm!$6^=YP&>BFv-#OJe(&8J$#^ncg#U55^{7!~y_*u16O9`d_woOuwodFvW{ zavHZn%wXT#kG#)q~m| z+COr5V*czh5>Xad^u9V5VZuj9>wUMX-CYlGy7GyHaoM7h_4o6wn4QJZe#tetlcy1#ra1lt>*+0<9_IkW8ExijAWI!;3o zGI}Z{bJYfe?|1lKzROG>eAp&!NkH zI~B#LO-NvjE*6Dp?iQ?Y)h-U-8g2DtjCajYv!|u@^PMT=PhDaLH|;Iv3T1&kQs1t) zj|ADi7%rSO+ZeoD3Kz9Zx!a{of%4H#Pd3edkSMt+mK=V}MMa7^AO%%fkuab?#Gz7V zK8A}^7||bxU0!h_=GTfAFTOF{5M(8Doh{S0$)Gba5|etuD~6$Q7)1?S+gQkBgiJiC z)gv?XZ(>%5HlB8$9i#Zyug}X={gJ_xCEK1;RVlf3l3iS$X~)P`XK;gN6VLD#P>ESQ z$wa3{+>5#iD1|FXJ$Y9>=vkdTfY;@FlkqiD;?DU!<+XO1!m`FRoK@(Md~JW{yms4y zCNCi=BXd|4SW@9OiZ^F^l7FgQGdOxK<3r7f$-uP6VC!rL*hr3By z`*Mko-06A?gQIn7UPw%Y)bT9JppIt02gf6O8pp+HO^1HsH(^_P=#mTHDNSM~klct32oME>9*ndkmISlQ| zK0DWSl7!SHrl9b%8t?}4%M!lf^T*#7^HWM zLJOv-%yseovof>(tAnnzdmW}sP*Ga~=?&HP5n>jazJC(3S{2ms_$P%& zaXpAm0rA)EWs$d9x>|{C>x!`2GFZ3V634Z(2)vh~OLMTtSNfJC&&A?Jx7LRNMnWex z951z!RY(TvGwz*VTR?g)5dw;+; zsDQl0@mnq_0<&e@^)q2jTEJ9r3sHA*A$gbX^Q%Y(~cRr z_^fp`P&0JQOKp9xr&FkY;?23Pr!7IU2vd+0iF>?6^cEv_^`uXh$V z-F8lXtd(H9BN4HuT`Ky{%SdCPPW~|OemJB~<`dTn;YPRyGRF!ZygNg@L6Ro%>G|L^ zMV*m4dv7N&Pc&$++`|olD4G61NqsTF2W|Wy2LYf1Tr_nV*VWlq`3meLFu+FrpJ#uL^_X zI71=Px@uMpugEQw2&DLzG-gvIIx385=%50Lc)qJEr)dOytRpBp9yiW~=c27VioWt= z6wif@hkMKLT)&D8WPb2|fjwDtJ31c2LH>k6ob}fj(p&kZg9YbtcfH(9Nb0!P!-V zhuhu<$nX_I0G{*V7BLXv8W$CuZ&SMkwg>bFd`Qqrn{}PIg2VrMs%y-*p)7y(m?5NJ zS4-MfmR^vE<3Qr^v4Q-<W1s;Mefm3Y!jQs%pJ}-bpJKY^PM@oC`H4=xhs}8E90zJHfd-xiy@@%I z>KUTe|E=Z-#wdZr+7egcq_nE<4Ksl6Tsl#_^O+lC)Kev}b|>7?R}UIB-K1xp=AjIx ze%M@&B;f0UOC%G*{_cn>I}5@@%+|vKJpw$7>lkn;lGUTif++v20qx+)IXEWb#AV2$ zfM0O)d}#ejWvOXr`bT2J*X^7SPN;lCscw+t*M7&H&;(fYak*P5XnI_EX8nD$RjNKG zRElKXuvjP3W!hPg$Tw90X%D)O66LxxKI-47P|w(X0lARoVOh^bHat@(td}5qmwvQ6n60UH&+9|)dY)0%6`s-fhd(WXD5&fQ-%IG=IKe+W%37NC zHZ|&SbQAEXqQIEWhxBDYdquh%(wEkG&j3JLcn(KmaED1K2-q~6Z+^{*!KFdcVVp;3 zMXa<-IWBdkcR>J>6F65lfEs+l;fLuXMt%L6 z%`kH;?L{JEfNYC)ghgXj;2KZiPcx~`S5S}CZQiJP9M(PEkuTM)KADI-Qnwr#(Nh}X zhNm_3HY`P`a{RIHc!7I3plsDZ!Yzm+cw<^e`fb`@;nFFbDhlYB5|~RszoljG0>zHVg111yg31rBE&} ztwm9sc1oFq1%7DG0BW24><3#-p+@rt1BFNTG{k z6kc8;gnUaei}Bm1$HFJ7I!iQFz3qj~jo21YTNdMa`UMk64uoBTJa!LzC1&y_(S0*k zmKLT;437$wlX!9TzvG0+$6BU)U}Oob#}JGZ`NQJa!yv8MqvW{QSP;@AinU1&lzywaI9~F!j#Ms;aYLIqep)KdoRxZv}>HUXe znvkA-Y*EXi8*vIM3qAeP+! zi@EMUp0hy_SODxsWV7F4&h>{By14)1rCmMjYVadXa$j5jknfIfifm^2Lu%JgX6eT! n7o#)|-}b+_;(y6=_mAkx4nK@yc?UbB$t+gpc4l?3Yw`aB+VFmM literal 5733 zcma)Ac{J4j*H%O z$;gU}YY*$sI>^1td9n^N+uhDsn%Z3Cs-5Jj)8=X+h=_>D$jE4EX*oJN-pbl}R>GB$ zkPaHwEzEPvxc^|LgpOgxyU3^f;tHJqm>?ii4KMx`44S-k)5?Q+fC8o zLVdv5Sw%|VukpTrSn*$2bUMAS=0g5OU|?l?EP11wG9!tNX4!wz8x#Pl9)~==s7sZ} z`Pkl$WSJ=D`2qJjSScw2U1()E-(QcHW2rJI#s3J|<|JonsciKO{?#eK&rgNG|2L-m zQ-J)WnpG<1G3Y;H{O^OqkYAH8<6*`>Uh(2#2mZwAnk&+QiImUppmLERuigjYVTM>b zm>^{vjmGyROSJPf%m|KKn*KAz4u+h7+ljm-5D16uc<+dL^-@z=1j2#N6qh;Ow-<1l z^L6#f9jp$DT~NsRf%($lw{p@=aL)EtI_EgpS#pQ-OO?Pmen%Rf$*POM;L{T>{7okF z^;#7hOh+=l>Pl1p#(gFK-oK^ULAs?t8$8aXP~8&6IuP-viZ+&Q(bsp2IWI~;GtpOV z&cOTD>CJooX5Fd^^BkBfa?rbE{EOy&!)8<}H9_hoTyU4h_Mv-~suGCDQKl*T5_UE> zt@oW^qOU4qs-Y)k1Imybr!x_QH7eokE9OG%fOHPPYLn^0HM5* z-XavP_i@7~%r$i{h?FKT4-NKNk$U3AS+d;mLJZ;eugL!8pWE@nltV9q>`t}$uF>iX zEo~Ntzpyw@q@mgonBrCEw&?f>)+1ieHwL)+eSsGGxca~SsVG0W=jeZyFGt_vU8Ho5 zx!oWZprEPiBalCpkHHT;c=l5!CsuE_VKnwqqIv(_AxlmtDPSJ}T9x>5m?jm$8ji$> zf_IDvRNY~bLsh}h!1x_T>{5jWkngT-r@-lvYT9TcL!A4$0M`f%1Wd?Lq~s-9SY*@A zdzj%o|CbwAC!YQga|#T5b~i}j5k_=-@rnR&`mby%s==_qCO$qqBt!{|g$2h&SzED3 z9HOT~c<=H8ron%x-nZ{2Pm$t1hHFBDB2~fs*p+gtOMs+4p_~{jo)gXD?bhMP(+}>Z z$0bsL%sfzGAwa8-9@OFn#`H&GxoBI_rb`D)p~I1Gl`*piKz1mLv-4?J?GXAVn4AogdH z?7l#Vr>e~!B{FJ0xHjAYK+{-S)oTAxN6#b{j4(ZE4Pr^z%0}evOW_R$2gD?`joB)P4dS=2zzUfg-BRU`_n7x&oBY0PZnjf$xhZ5q zVJz$iGqZ*D;0LGrBJO_my8jM$x~IJ$RKFHEJ7nkQhpuw|eBH&z5w%M0^ax+4bjE`E zOjD$p*InSA^UZx)U3Y@cEosZFoEBs$_MRjGKXFl&`6dZ13{ zr*JrxSWFneEzzvc7P9X3swK*6F6qY%Xi~F76vvHUT2Y9u4YuW?%A{NdCe;epRu({s zCrwSmZmQRwCo{X|V9n-wIH8@bnTb*mt@QT#j<<~kqCWcpamWNa)Mwc?gs&7fCsvtn z>$)7R5SGqKekqrQvfFD$H|O4cvRkGC%zm3Q11RGJ#{~tMoaD-+T1uBmqYG9x-SO4^ zUB=50`rxgXjlm1&jd0aspTQRH^F>4NRH_&FswH*27~vL`W!EDxI$rk1>em?y_0jg1 zw;^RpJJUix2CWSAvK2}w9s!Jj6wj79w6j}<$@h~6P2F6yIeCr436mPPU?)~P*wC~) z0UG;vea)phIG4}!=w9EEh$@`9fD1jwnDEtV+JJqWI)*2LVxLtVf?ZqW!V{BA_dNeF zVIbY4xg2XM)8w#w<3P`3p>1=YFW>_8%%9>_4}*X;U{>}Kc2}?C@Zw=e95=aNMmv%P zeT4_D9{|?$?+N)pX$#R!A5_;a9_Ioc;1iSr9A%H;3k@Gc0W9i2@u2%WyJCStnhVN5 z>yM4nF77XoGYk^C-Bg6R5en!Z6p_AI%`G{Ilo*w)^B z6X?ErXvnF}8_<-!GwHvx2eqf$(}iT{&yF#5Wxww&+A!nWU=obkeoHdABviG1C~Gf` zh8cycY3nQ<_m+RewW2Z8CLdmOassh*QahNOV8oZ3UL{GKyo3u6pJ{M2DgjF=VQ#Mr zWYOtvU3SuNRHrGv(7GuxMNFycF{|RCKM`3uy3%zq7ygbNx~9{jRmhkd8eJP0@lOxB{Yy(D% zbk;>=n?pB)aLGr?`mi2RB33v(RIz=~Gu)#MR(f+`RDs_pJ!@7 zf=BJAgeRX7-o07-NEm3qv||0=>C4vIi1>%)|xBGa`bO87}bXD z+m4cFr|7P;Umjs}vL=ksJxV~rxi*#Ef0MiR*P1WeOG{^ZdXJF%ZzU2@pF(V25+TAg zaTT)KI3bdy_=;H{Y+BfB_zgU+sTDltm-2EvF}y{n?zw$ zSK}s_)~}uD#h#Vj?>|-Y0b_6clDV(4N#Q#$XsOgE!>5(s=;M$|BY78ucN#ElV{r(@ z>>q}>hnB+Z{&{gGrYxgqKTu{MNIV8xMCEJXk>cS|st##y9nG`DvzbL@2721L$ItwB zUWN9Bq)mu(lLKz@cT%%wwCCYHl^r$j57N%b_w^n8cs6#mv9mmyby-|tTEXR9{oc@Q zTV5d5K-i+UP}6t4Yaa+t6uG>Vd<|N3u714iO*G33d(F_1<2%@$Qs3(;K9pprC;SxC z5m%7BF`<<{?grXuFw}!w-q^l} zdBj(WRNBSqL|zdy_U>T%#@g2WEk>=_s%9$TB+G*~K2CW75+<&uoeXO1eC5DJD?KGk zB(&-bmj~Ovxyu7UV`MjOt(E89TAIESGbRdp4&e5Z>4grnp}Jx-NxWWbI4EPYFi?F# z`i+DpMUOm`Oknl@TzF2^`YO6|0P_$7Y9JHxsB?W`W5koCXgqU5!M6_bB@3>Jn2{x% z%T*(9HA6^8abr@hNXANVEC%+S=2TYQ71Cd+g!hZ!xl(A6J*K{p2@Mh5f8qjrXvl6g zppxvINWOrxZ)y^HF%ySw8h(=>!4i2b7>)o3Ful@$E;ajv(XGhH6dqGZxW;OUW-G8& zK5}{$Mok0SO+b;4DbD*VsNIwS5&g~YSg`1VW;THumYOD9@ya}6aU1&K|ZG-j=W7ekL zUb>0VzX#+qpE1+J8CChqcaJ|$&O@E~HD7^1vF{Zj1~27c0OG)T#yuf&=0oA2+e_zs zm5|gh^xz98L9m~SxcovbJbv6abK%l(ccb~;z0Sxb+-c>eJK`kwslkl$lxzo|QjA^N za#L2nAN$N~M*{IczNz+&7479DmZ#9KZ#*Ht#$++*PLcLDSKd>e7udWj{?usJQX(D2hSBn{Njo} z;h&?R*jIo~W_b;dP_#!7gC8|7ey}AGPnwQcno`<_n|4A&>+sv+YgCKJ6uZ9GYgvt< zRak2#w@=;Af$>%!#iKt>#TfxrVWZn?+Q#0yvnce<3Ic&x%TizjXF*8wH{C*(G`Yv! zCR;}%U7qeJ=$hy-MQNcK$HL5g48RLEej#4%trhDt3svgBQ5s%b+Eo2 zNuKVd`D&7|AqpS6wo2Dr!M!4jdBtp}MJ4+Lmfa>F@`^{2JzI6L?xv|g^zz=y`E&$- z=%Nb2W%DWt^P=XviJuN}XtK6dh1oqX6fWSRRYIDS(S4g5iDfUl=26cn=YC4MkrZ#0Bx z{-gP!mma8o*owM7nHa1xW8h1BB2kUml{zana=Kq3eB}Po*jnH6M=nw0X$;}|B6O@F zb3B3b{fAREtqXSOcv@nZDhXGDK9D2#L(*%jJs;2t*fv)Sx{W}GIXC(<77WBjfPydg zs~)r_MOWQP(JfEPA~os`4A`#wT@3vVjaJX4^q8$sk|fa?T^1QNl8*_bw^Q`k_E2Hf z7dcj($$9_s;}eh%qN$1dh}@SoK}7QNMv;&^&x%s$O=%VA_Qi}zGGA3kAeN+cWq9?s zATdttp7I#dR`-KxBFi z+U%!xEj>#&a-cq8Wdx^L3thvN>Z9AU=fnDmJ7-+f=70a-n9B0Sg*S$Ug|T5H(gi1$ zOE4P6j%JLq!RoD+#otW&_|Rrko)V$|n(|4`4Dto`*-MKt`j_^C-#gwzma|V-tumzi zo$%KCi$CqlTRaOP3X}P9LjeoQ`QBmKjU>`YUl_FDJXCESkvJD>Hz-&fXTF!F@Iv7l zh)3a_aC-NVw2qPDg*Nkge-8gIpOblsg*OYXpRe#~36gl8nSpXLeIMM2GdQ*xovJSK zg62GwcRJl#$$5DcAr7{PqJ`ElsZ}4b8_#v1X*G6-X}pi;ho^jRYgrS~86nhiL45cl z+P2tWjN8>N@81l1e}*kCb4@>rsj#nYLUO*gYGbc1V_Ia~?aVK1WI#?*;N&Nb%f4D>f=JlzXgCU z!Ry&_QkG(PgiyOKx&2|C#bd;iU2`^{w)SlZDG=nK)=!Noy4Q-0WE#ZV&sm$;i;$d3 zg;Ec8G1uO{buck^pv|bFVnve5;RR^CMT}FHM1R=xXf9y=e%!DVa@BrdY_2{K%sa`sX$G@}B|k@0TT~e+*g|1KL6D z*k}ItAu4vVWJs&Ftxk(>hkrJ6#7BSWURL4)@S)Zt@WJUYs;V)PDrxMFIcqJb-9Spv zBIU%Rml8sAOJBJF9WhF8h1&b67oLrmPQa@Y`WGktBUo1QE`DL0JgeB#+pa6YGs?>& z;IAk??-a&p1*>II@cnh&Gq;>a7}2FN2s;k@X?YaO>bu0)0IfPO{YiT9uli)Z7aKBG zxIX^3#oBeV$%Hbglx0B<7Z3;mJjsP)0_mUNCQ|TWcGCuScC5abU1iZjt3d=wEpE

%QJhF*U z6w6P$GVy6H+oAb&yr6R}^Dd?5Xn1+~n1aJ%c}8Qr6v*M7v)k-B7xIu1krwOe-Vm5q z<6WPMetR;{0qA!lOggsIn+zBT<7#MyOXJ3prg~o$>j&qqHK;DUfjW4@J2Y5Pf_stT^e<4(t(`jn^+P!k%lxSqI zNJ_cR-d)^rd7ansfgH-I^D$3IurQ)dv@J@lF^-_=p&WY1%+eC~viQTLW%Z6Y3$+cX zM)2|MxLCAeV_Zt;$GdZ-iO49qe%mrAb#C=!(<;BZkp*ocTOUb#@-<)_xo>wK?NIj3je%t8O}+d?L@iKaSO>)eCjP$D-j&2|H|d3f70Q?R?P14$pYiEJ;sb8;_ex>*rwUh5)+%)U zR@zzt{XKtkOWY&M!g<*WQR=e-N?tmZ5JWlAd==akkG%9w40p&RX(g*(? gPWu1jt}BSmk}q9S@J|`L@GqCiMRTKagPT$R1%?xZO8@`> diff --git a/vignettes/teaching/plot-teaching2-1.png b/vignettes/teaching/plot-teaching2-1.png index a2698b9d8291f220c0af5418bfe5f9a01170a92a..0b71bdc9ce2c703f4204bb10d50458c625a4c4f8 100644 GIT binary patch literal 12948 zcmb`uc|26#A3r{fLAEJtb|sO$?2HkSWSPX+jbzQ5Y=g1CONf!OWvj>HUy#zfp|hBZ6Mm75bX?zu0O=HiH}c} zPZf2{mW1d^O4>;3+DO_YNPqVB`se9OL2M+Cqoj@Qv4TXK#5^Y_eJ3ZBlarI@KdZ+kJ&)x*wU23r=f9BQnKAC! z)a2Q8Opp9^A^v%Ji8hk|6V1!ehGhJI#{P%SI1c0E8RJKJ{<_DYyu5$dyu7?7Pe_xe zc2max)EtdB9UYBlXpd)jjyHM!gO4|jj~|U6H64@jqoboH&tvxS?HF~OOa9Q?fBaxh z+`VQW41ut7|GOBzO~%k65DAEhp}sY?V6~7vf4(Vn>H@mg=b8KRuw08=Xl83zNtlh# zaD(VrUSokz!zIt5mEq;S3EF|4aWcD!(-#J=+H)?Oh=DcYy6H)>xE|vNQRmnniZzbf zj7bV^EVRO(3^ClKi3htYhwY$qMAi(zYpT3rX|c5 z1WU(QXmf6F9x5nAErO#b6OH`tjHM=ZgfQ{H+$7ghgm zm(7WTh*M@?HXG3daXK@GrxMVet*%yt7Y*>uyL~?3EH>H#7ekM>@(Uu|$07I%uAZws zfpA2z#o6;Gb#aH2ZPP~rUU`6q<*-{-Vx8`6->1Qij)w5tLOtS#-3u9$n9aPBj`lB1 z9WkBgB#)9=rIf3KZ+`*n1GD8_gpZ8zNjd8sKNzrPYWnI1Md*MPG*oGxBQ?T3uwx32 zbyPD_H^T-4MlZUg(>9lS{=KBmg^NJ*59oi@=X>TK=J(ZFwM2y~){$@g+~955Q)b4! z&w9maYo4kKElAUfQ2{<$#U6fGZaTQZn4&=~mxha>k9p%r>}S1uj~h)uY>vVR%RbBZ zKz7_ANpa{>;+@8KD?IipG`1@HBY)?SYSaEZ7p5D+tap-MD_6m4+_HUk!1bjnjI)nL z^{4WYUv((=`<4pc&PSiD`vYPywxN8n!9OL2sx~&pY@^REvlLhUC2)-B#T-<(R{7HM zNB$P1Mm9P)Z707L!!<3*nX9$wdWE71ymX=iZiPoH8VvWdIdBUd@s(eis|srTS7@(G zW2}lTus*u0KD=CARXY=SRqxNln^S^EN{9N#io|gYBYNWKqw?^H=4Vyaw0srP8_J?@ zZ=H2`nfU7|2bT0Vuj5~Fa(%m2T@tAWX!yd=^>tMJus9`859|7k4k+E`b%xJ(aiH1b zm34hh{FKit`JvuEPpcr8!Cu$ASC^J|t*+`-yY1W$K`B9wt~=_3L()3E(ws4Wt#7D} zTU*A)b=4XQ4{6`^8Dl^W$i^3!V@B#Sfw`LrI$=|b%iR{DxQLOufM#7V5E&(1p1XGY zi#2S7d(SibM!$)KfWV5!7wd=-Zrq%_OG!n?BJ$S&-E-b-&W>|L;n@b7{AUh!<*eT^ zCVS+DZUUi~grLc7tnT1cg3Ib&C-|rzxIDp`fVjFJtAcIfMf>HWIpcXMS#EsR1AuR) z($Dmcg#qp5K%Hn&dsA>VDoL)w^UD$C+PVMGBmy}BmEc;FQfa6y%+m5W`J@w8L<#VeSIp?M*B_19!#n z3Y$VH!Y&e_H^a;{rJg+e7^2OqEVIVZezR{DQJI<$?3dQDreVEv6OeQ$^6=vWx-Jgi zv==imT3zlX`*wEKbf>=Sn|%54^6wDMU>(rvOxJbJVz)7`!}MMZ6XNiCl^0^or`bD? z5tqDYJL?Z)|6!KQ_v~EK?zoxW^Ev^@0H|@(XeLNJJhkX1kRN8HmupdZBYQXGM_R}8 zy8Og&spd0NciN0l9@MQV$e9NqG!!Ro__dEaWi28<4^Y54my^27H zn77|s?)q5+bIC(F*|sxSqQMXoo#@zr?N{^tqE+XC_lTDl_v2B)uc!kNT`y2x`SS22 z$G3g_Py1(MVReXCDoobWsR^v6=4THxH>&&?NqZ8U@@-PsCQ!m$v*7-`;V>tEwr=Q@ z2MelugVv|lTbB~qp>TzCufkian!Ip-fQ)}9nG*a#)+W({n^-=cusvp9#6%tXfPeFB zd&;O=i4!Tus0tdje&zyUjJIZruL8QFd+sF(s45dheUe|U>KG5rY10}kdaG0QnBvwk zD%AmYGC!DA&oc)XEptCjy{~(rSSr&8Ti=yy|>wLg9oboGyf=hyCgzKOAWNvJf(}HiXdbh@o@)bXnW-O zT#NNx26B|U%CeHyXR~m$Kv_C4mwx-KZUEAcO)M*oDfeg4?vNM+^`!rio_n?SwI{xk z*p`yqiR<7{Hefks7p>jM7fXSFhGTbDAO2POs=^WVnuvGIKcioYEMzNEYAOsEa-p@l zRy|=sqAuC$MDmOfIRP*bSI^;2Tz-Ht%NWb%CK?DR+WsLg;! zDNp5HL~s)@8CP%1_r>_{_Lw-0nD4jay2IL+Ul;P-;(NICpZ450z>TOZGHo=q32e*5 zsRe9e=>G4J!^LeZz3sR68g4ntkkh7Uep6X&<1+KW=?0nh!7s+1111`kBGYeP}tDl-2xwck>}(dhP;L&8z@mo^O+iMHUJ3FEO%qjnh5X?Ut<$mx1~Ai7QE z?{zOQ+^mAc#=o7t!hriui(C=SN{NKx@PVVsS{=Gm>NNXpR%-aUQxa`%p4n4kSj+y1 z(AqR*#IJF+hk0C^sySx?o>pRJKSZzE(_lNx+B|2{URdtKEwjbN>aPVeIt>N8Gpx`T zTGAH5CKJS-E&tble(H_t6B@^K4Atz_ONK`Y5TF#h zY2P&zH|u@$Y)mB|v08iS!JH!QdCe^fkqImKRLpmkFRm)yz1}<#6*c{oEt39~nMgG% zs*e1;?wKUf^PMq9e>rl5Q+6tUB%G4abv3i>!<)S5l}TrOH}w=P>88 zQ3gunD)vs)wA)E1x9OIzt$Xyd7d;wa!Ve2xyb^wG3{LxH9GS$443$^!^NM%r`aO~I zy5|k?D30qk?;~!5LsL9r;|mY-)PFd@o!@~sB|(}R88^UDqKP#*gcQ4Rc1uR6)V@|? zFXI2rfYf-%XkR2){Gqv^#ODu1L+@exn^*C8%e0Y>60*v& z9bPJP8K}IoF9nfi89i3=BI9~(!w zmDQ628JJKSlg_)pt{Vy_2Ub^DgvHv6Z&fqX-uU%1sK0+ZCo6Vl)4nQiM=u1{#@05B zGn9j$E9w3&!Xx6}|NcUplV`*GU+2hAoc#OGa+8%GxYRjqp8?Or$ zrm*AE!y~#*qp9)SV$Ze$hnS@(RE*8T6d2i)!`)k3^_aRHc`qWhrZ~L9r|BH_fvvE9 zUv8vYamRbGo&$3;<`B3Sr653xuuag#IJg>MVWN%o zG%8EqoL(?U@zG{LRJESQ!aE??vwOApr~dH*3xtX%OzQ*gYDppB=SVX}Arha58ljAb zJX0mvin&>jU_++hMvZ%s?TU_~2tpYPB}!><{~zO?3l}zJWk|SmkeurC7cE}o`CoM{ zmzXb?cl0*zrZzTnW#zNTeyMeAohtb9+2J3g>A8X>RlY|6i4ps3$!qSr1KYhGI4QwnVRmokVG# zn%5i(cj*eaQT`%TQm3sxW4}~JkpDIH0SD80w91u6IQ{uE{VLZ|t1P5!-#BJ?qR%Ev zd3WIOGs?MLt0b=2;)({>e0RzNLBqwWlKhoRQIoNLRm>0m{FpubD41wHM1E3-D_uDY zjA#k_JndXiK-F!iZgtt_P*|jCPl> zQ}N$$tJqE3>3N5nWVsod!613oHB1I%5Jy>tiBhsOmmMor&v_steO6uIcD1ihL{gB0v{VV z#Nm0H_FVj7X=AbF+_z{It6 z)J5s(!9<5o_5wJOy|X~{Y@7FpG%LnB7*hy0Aq%`2WkktUuM!>uJ@%v_>+*P)(bi_{ z%;16}y>M3&OAU??WGt4@IYBpj8m6Px7yitL0a@|0wXTT|Kj>*#e5L~$jy}J>Gs(vS z#~cq;4f@Yi$NsahU2wbz&I_1r$D~9~CL~^{m+DD}1U})|2HrL5F9=8KneUtk3OoLM zm%8=pD%afuF2WxgSe(X*^zwq#e4>YL3H1@0dt)CCK9(`{iV(-nYhMo7i8DrAV{nOB zy6z_Vy`+|s)^ClLMSy{g&A2e2M4z};FC8b`bJsc zw39VI4}R_W^Y9llH59=kmG7<%FNM01FdJ_qWCd$2sCMhegC|&Tcnzo$a5+a@lB5uLR ziA(TfBVnZRHk0J3c8}I^?0}HT<}%P0p-{i+yd68VJ`&obG#8jO!m#&8WdKk|QaZc!nvhMqZkkDR5t` zI`S1Tq=PrzQn%^b)Cap!`rt;@C|eOt7^pJT2>vJ!N0S%mtJEuU%ffMiLs7*SrAOp;)wxX+~{&(im;TzK`oxl z!;58m!mi6OrJWE#GX4+dj%6BwdYgKB@JuzAd&Ft_R&?e8ym{E4w5Jibsi>vL_VZBWg{KVoMxj z&Q($wv0Cd{C(%06v$+ETO7z=6+9D}zx_0kznRf0oqffdo`yomT?GH+NAL&I*v!G{I z+Gh)I|GeuOS6sG#Def;0^>PUaQJr1roo%yVQJQaOF6k|R3sO2sxt8Qhq>e#Oop^Ha z*z3-TQh|24uO8 z=Y;{3I;6820}&Y>dK4`O{^#lT2`6{j^FWbW>}GdI#~hEdBZHf%)^Bq^8-+C{1&n|2a(2=M%3 zZt+%>sUztnRZh;XIfYBJuqe&>ij0yay>fn;%~7ke<*HUJh}>2v`#Oo z`pfvt$Uok=_13~oO8zVRDMq40@#7{)*f$@ly` zj;T*gmR+YsL|^^(>nSd^dwq_&k+>xO4K1g9^}c^qOH}Kv#;E8}oARo=vZ9)0_8*@` zU)VBz?Rwy`0YtSYe`>IeJdLRLNW{mNpIB^^z<$-wzoYrg^$y=PvU_4rSEahF=gXfl zFI0Ao3ho@;YFNYHr$|E4LGiqA?ka8^@%u_yFRKw=6dhT4KI*wi&ab09bJ7JDZ8rBV zbEi76&N7R*h242!{%}}$k7WG)-fVO+6c4+Q9rUGysAzvl^XK$B4WGv_Wd5Z8b<9L% zKvKk`xaN_4mz@vZpS19st&G@rKB-!YLYGFaj(uMIlt*&56AiVn`ywF*CADZ68L9M! z7GxC4lty~8+(>zSN>{AZs7*cjA&b(Cer*k1}Q4qxzqQBDaY&KlfOo?N@4Ku*mF) z9=)l8-AbJl3u>C|h|K(bWNva+MDJ39hNEkSpJ(^?Wz1E3xRF)2*vHm7rCWDklCb;#`Hxj{qH1e`ve^UL8Ks| z2$?pw9S-eIX=8P+GP*(z6ot(lx59PdU>2(F5wk`b3%q-~RN@(`z2%tP?h%gOthTjRXdoE@CIX?Q80vA;)Mk<$?KmqT$ zu^mV2(_Mmq%#I**9$D^r*mfPhW)WmHm+EiANOJ=d-^>RhGa^3qSf zuMMBD|H#{PE(GMr*6nB$9h1bKi2|GRwg2QYAkRgq0qCPq@F^8TE&h|#s3HtA(-OIP z%g4L-CB~iBlI`X<_sDuGHKF{SyU#-6UL_FwV6?A!vSW|WP494$5OeTHJmwO8TKc+f z+a+25_A^oMJiF)BqCKlWIVgY&F#olq$o+%xb+L|!Bcs4Mnii}m^+6e?CI6?>(t}!+ zj;B@C?ir)|)(i4VvZdL6RA1HSE04NL-RQ3lS6N&R*92m<5b|~RH2TB>-bqwoPtOVr=BqoOEEs=n$-0Z(J@3vXq#mAXiJQwVr9wgx7a(LevQRnk#y;X#=6{?1JG zB7^JWDqARKJ9Zm>6y4p^Ojiv#jnH1a9vj<}BBuT@FTj1O8*m+i(8f&NkR)f)6EuOD zxN`IhHud%Dbk7T$3Y~3715>L}e%rfd!XHh}YGaU-v@2m$1blv*ZGfs66V)#6#b(cn4vyMe)}-kh98kT=Y|gCLd5H= zlwOG7#SwPpFKJ`zNlVmtu4>mR6c?hhJx4rE)9dr0NcU#8@Hh)Ag8%VBoN-|R2llsA zY@D#ZLOTR2H3nX z!@F19jtwiX<$YxQRI)-RNl+YU%iEjslfl~V#E|PRz-D>(P#p`c0y`zUi}T0*$TItPL<_gN0QrpNaB z#I=Ve|M8GpvgfSGZ5{_sE%ol}Cx||y6mi`g{W zhiC`&{^eOC>yIO|t4lvhY*;4WO=$Rmu%|M@t+_?O@^M=fY-;xO>|MjtU=PuPVM^r# z?CW!#kwL9XH2!RO42IzbE3ULqh^9VqVw#Dv`!inZ-NI?wihZdtBZ|9C4V190S6~ec z4~c7@7{)UzJXglrJ4q)DC@u$+HS`{P^8x*7LhnyeL|=Lw^il)}vPq91B-rk?O|fu+ z=+ngdw|iT`67)EKR)kc8Iw`SqnMa z=>0%_4E5sCJ&==)(g*$h6@W_DQ}=LsYp(NS3DXd9ZPNlr(=|g7W6Kdx{v_q^=N$S2 za{ZehWdQVrCAnID9kw3Gd0to)(PUkM=EL7P+Mj%?TD-&!beX{?h2C|X!cOu3XMgdz zP|a_7f3XpUO=&18PTcaryebNR?YSjg(mIwnfH zM;K_}gC;5_zQ5mOO1@^3jb|7LFBFvCedyd8z=m?!{$Mu1LwjSKW_Rn@|C(cufd*3D zot10&ux|&34~&P-FfGZX!^k{bGBW(^)}euO=9=nH`G0@xrA(y?{tYCQpUW@~vW60x z=6EQ&9r<|r+i#vtLTN2rXlE|sTYGbS_XBRNBpegX5&a=KSGO%+J+p=x6JS$y^Op8z zxpCLEsyJix4E(v6=(l&@?jOo7M9o3#1ejwxHM*?_NZKhSve*`bxMG^}YM1tE!kqZH z3?I9-+6ly&>z>&;0K*u2Le70^e=gIErHH~k#8j81=w1nIVHK492g7W751KH+yD=w; z74ry^(34veM(@^i4spl{q9!_aZwW7nh=aSf5p;bRw9+1qvO_>^JmU>9kF&}xNysg;}-rXI&CC} zZdMYsj*`=?Ae4B^gK|<76sw0NygL9!RnZ*uepDu$6I-d0HcTzXLOYmfykkY_h7M2d z^iZ#b<-*ffJb{@4TV++(Rg%*;?`!V4rNv#WfWTR@TytS$C|@&tv7YXEokHNhH5souX71 z9onTyjZZo;*^_Ma-*8b}t6yNcfES`?rk|e?HHv0C_AmyWF&-8?8##1t{%W0R-+N$g z!&43_KKfHCpBa-g2_Zh78x&^mJs&5~=BWS`GuM(3<7hkSs*N>Qr&!&+dIN!7gzu!p zK~z=@$iKAjJ|jFdjxn~9c!HSrw)k*~GB6WNhqH-sz7wInG!8CvFngfHh`ge9a?~2c zn&2Neo}>$XW{)Y@k;j{V(UESAYY9rL$X|xm|KLB}{?*28`x#|s@%+tOMLY7Ivd;Zo z-AcDD{7T5a_F^4`V07vohgXzl#WDXs38Uq@dNIM}Wir{2Vi{qGc-CAwE@qm+#iDT` zeP=yn2vPZcd)|G$9yv4Cd|;8~-=)EYi@mr@1pw!f1N_He`dQScI<}|m$C|!f+^mSw{2D) z9JRT2qqpZz1c0_z3b?Yi3>i7dR~@N_t(&WyTF!4V3f3~Wl$Vj29`@WfMPTRI^L*>k zyYlASS1E~up1-q(H4R@5KnD~*>AYbUt@`^PnI)5Bwy)RL^sFh)Gdex$Zj3hPw_Cv5 z+NFf(ZBs{?o~1`$;x8sI#j5C?PwZNgFOSRuc)Tq51v8WAX?a&XVp3ARoztm(bM1*U zJI;b?+TYSh-re#GBoLC5zsW~+0`=D?`4Xf(qZH;_0N(+UgCuSC*Gt)m>rDd;19rdK zs~L-J+bv*rf`~KYYOnluzC>cS2hZk<}m zeL~6G&f&KysA0rae!n9OmZpfo5LJ<;K)tp#hb;#^%e{uYYo%_4enMVGeWmHQ<`jX;$6ee!$OG*dHfugIEn-W=t?re6$^WQ_MlJWiwVvzZQ_z5CqhTz1Jn*pQ)n@| z|62W>$FCH|;TWVM57tqg#(cRXL#9oHb|*TB3;Sub>}W?Dh8sQ8WBr)ubZ@(}E8S0= z7LiyjmhC^mBT{BKp$bz9=k12XN);9Ex}1w&&tW_QH;ap0&eRp2UTn+RdE@s-OmB}X zlsm&&yQ@#Ph=+pzI6uD5Ly^|q7gYBzjq7caSVA)%hz533PtzFJX$wBDmO2+qfI0V> zJNA~7P}K(Itd#}ZKsr#90x(gt{ew8RU=mgN^E46)rsT=ikw<)I^2611^~9Loqw(Bf z-OFxV^~D}=shB|K%Er%ramSw1bS8K;m6aBS^a`}NC$I2^e_sAf6eV&2_18| z@BD1(AV5-Tf)kJ>1| zFOPi<3L~xQnT4u=&y9z#h9vLoZmm>%7-hk~X1JbpZW6jPl_C?XcjOlX;sV;MTlr}8 zG~RnrlV#^Jgat;Bm#@Isgz{Ci+E{-l2>s#oKygfUWRPIN1-m^|R zuSo zENR}-oI-5Ef<`3pzKONU!7fl#GX8_wuOJC$CIxQX1-!hRarJeI7( zL;}g7iJO)=;hQ0y*gW6WH}xnL;QP5=^a+=++xcxOKdGCZTqrkqeGJ5ln0d@G$q(kp){z=<>pUDh5`r;NWa zY`=d65QUc{ff`WE=RI2$t3BSC+8?UFnE`0990JfED_r)yY&hG-@V0dL%UEZv_yQeo zm6_E0HWx*T1n=c!-eA?l+BH!ZQzP|R&wRgmQ>T36W8l-^!_`IsUzPzh&yMbUN@rc@ z$Y)L0Y_Shl$YziLJ*`~qceyb<=KRUtt7JS>lvuyN^C5i;a2(y~1lp_TlFVfsm%3HJP$PZlL zwp#{F>`H9hs9zB1akX!fOK9Ea5tQyg>H5U($Nfupi-l&z40qp$(!EoI32dbBI$hHZ zTmuxBc={=0pjXs4JF(j=H0Dz>EF_J(0|v}bBzbwP=wlS}Cj&{Ji7j!x+%Gmxph*&x zjC|j~`N4t(w{M;<(pf#@L3~>P`;PhRzc(!Fe*aU%Jr0&*Ut@S)ZRFwySnJ0Od9oh(So1_n&@IMbL7OTaAu6i>k9s7eI>}n zDCMkX8{o`H8-D0!u!&93Xro^B zKvao)d!A?*Vrnly&}PFy$Hsuh)pvVWWZB#EZvtIBqOb7F4B`asOUI7-LQagH*Y31R z1iz$SkPe*qb0SK+>z+R_b38R*A1hXUT*w~tGd)WC-aVPkd#Eg-wWs+}sG?d<9MOjx zduG2Xd8K4Q@#8O@yD~uYaB%q6h!x>$+nV~IZS12jkKL{<)l7Z)J>hCC39k=yMOC~&_SXO}mi zgUl~KL%4W??OARJk#i)Al3IB|!|Omb`tE&`8((>83Kg{+n9ov{DmOodWb&QY*S7+i zpSNDZMhEE7Ue)Fbmzt$WAW*T!Cp}l0 z`2L)X_hgv$C^S}SUKr1rAM_q%d-D8w=(y$NyS}irV{_`ItwOX_4%?>Hk;tuL&aNBsW%U1DNnVOVQ$E8+hDw1whK literal 13231 zcmd73hgVZi)HWJw=n-iGLO_}*P3aJViZl^|(xgjQs)#_4&;?XPnt-&>R3J2^3jq>Q zAXF72LMTC+63PJt0tEQ-d*8LbyYBr9?yPg>%7;}70zlp^ z0s?CEGAWRhl$5QMo~@K^f*Jy$hH%o<)T9%1Ksq`gZ=L@FJxGXr72h!6E z$U`_e*-C+I|Cg*sXD8Su(JwL@Bc!&cRIEz_3#hYGCztBKcUMiWM`V7@){48qINs_J2*9CP9d+1VA zCwZdFTM}j~*T|Z_|NqL`o}yw(-rw{IsZx?_sP;`+@Ue2XaM~bOL;(s2mVlJ0y_&8| z8sQ-C4Xv8X;YC7A1-CVLmz54r)bGfB!O!dyyTQV224(_OaEIqIP60 zZ5%=2ktc&G2TO0d{ALahbC>(9NPqYKMpaj& zTITCvT_o)g>C^W@YydB#w)vqpQe+e+pht zrYq&~KjmbBAc{)UmEY)I9QG&Pq*Z_7?_2*;z=I7PsvI?LQhEXdb?qYrEV}Dpti={h zEU{@Y*PIC}A00q)tD14NFGIfy0~YG55L!Kk2)$WWhN6@Y53gxtx$R}SiXq{Cf95*m zCnhz!yo>y6#nUpvJ-h$V1_j@n)?n&KLV+D(!fSrlaWj_LLGPl~=PU%> zhFs3$m-V2p2||sZG(lZi!wXy!6@thow8uD-x$uuZ(j{DXgj|y&r;51-#m27rs`$0E zeiw0M+h*P)so%~&zovRW_4k&36pNKg!&hYWWDk~WrTo3`@JP-)sHSe1rguHsiO31+ zKCOy(G)141%q#Z?>t}0|r3gYy(Uv^eI{;yNq2>?~9{-W&n)pJaC(xgIeanm`jlenB zavEE(U=Vzp4fzi)vi~JMt?R498EkiJ9THH3YJz77em-Oj<2mE4mKN z9q6pPZ8L^DJooM_;M{ZC6=$mW!}MP;p3G;{L-yzwVnf%DR|u|1AGEOow=j9Tu19Y~ zdGGyr#dK^+(i@qLYPOX7*2j{7u;P|RN)yV1t$2|8>nTAlt^ZdZpPU7=ZByo^{jEjr z5dTvu1cBdHe?8`5D*g<;g&XfntD}pX#CJ3BX%jJ4Z>wH1BVt6G(hV^qR&9p`u7pG# zrlSSITG1^@(Z=Pvfy(yhQqVI=(CWtnIUVbnwUQSrgYm|$Us-?IH&ksSW^5fIV2yaZ@ z-WyVp8|R^g`ihbpQ4#ryR#_C@^BblVQ#JX{LV)FC*jZ9fL;tSyK8{=y zx43YXmtPofL;5jcbTudA``Bo4T6SvXIxeeUx7he18yAeiE}T<;1g2m#Bo93RVU$m{;? zGx20htCAh`7AVVSbFrbE0%}(W?@VNn=h6+~oW2ATO%|8Wfh7It>>w#kth8~~@MJ7# z=h7N>T(x9mJl?LM`$bMsIsy1;Ie;H9s-uNEyf(GM@1YH(tBWFso)yI5w| zUC$`$BL00=7hPO?)r{9CY#yns#yXd<;h!(Iq@3D6MZGhTS0ugz{DWF= z4}rCpbPFl(!2}8nFFRcG^1cyR3w%0w!K_KXV%?3KMoZntSnyOl0ZK+ z(J9eY^5QV$wisk4#EhCEmr$ICa$#B&J8k1vq`;*tZ%NszOnJh#6TfW0D(+O7!SrxK z{Y3G&q|w5auyE0&83L;cN$p-Qy?jn`Bev+x^$IBVwNRxIPk*9d&`~ij;_MlLf_Q>m z$%;XyFCXk!@d;_3VA0E{9Qmq!L}nwLnVrcaC+i^{;H!+hAvjbR|B;fu^(}U40qpuL zkVX4p?5p4SE3rooUoz`2SG9~>&iiw;m+TPnIql!^xoI}}t{f@w`B~(7ev2#Y`;&#X zUboiJ|1#4+kk9Y+@4f$q+sp9%=%MA1|U{s>FnG>IgSZ#>dqfsw}_FGVo4Y;3#k+cqo-k1@i9&1-5ze5MJN*>O>#0ODs3R-L>ajK-U60Gp! z^7Do2qJICh_kZX2i}H|f*cGgAmfdYL#p$$K0%qr+%=I0Bx+}GR3=i?;D1g#1{eFfH zP-Hq*lQ3Uz;Qr5xA?;OiWkP6Gb58z2264b3DM^QCwu&Lw z*GNo&OEp~5@lxT%CD)~a-Hblc^&8A-)OBWc-#`5|?_?qrbUi}3>ht!g$#P1ny+jhd&HtMQggw)n$6-;Pd|cWl71wtNx!`a`P4;8B*rR(RC2@#&mt+WyVe(-xo&SzAQrUL4|i z7mWPHGV!4H)p6n!!?L^P;D3SW^v%5-d` zI9|U+z4E;8!sR*&BO$!13Bxb}o7=8IGozoiRz55O?H%If(nrC^nEj#V2$#F8P+=OG zyib`l{V5y4BAz}>t~2#M@pKlzJv_}It|WNMb9rc`e#FLmoVGuyNjFCTc00!2gRkuk zhVVY}Rnb$_{5*!g7Yu$F)pgw|`B+jpa;Giw#Hs7Rz4yZQFxg;0Z7oT;Vgv1RT_JG| z;y}wz7t?__P5AzHKmVoG@G`qg*6{kt1BMnRW;{i|f=T%yw&j|X#;|vnFzP(AS?wR) z%3w+GaS%;ZbToHjCXKxgm6&Uc7JHy{*gb~d>#ksifS)pVL4t&sDqNi{amn33eD8NI z%W01r=`f4CWZ+uA1aqULI+)T7GxzWQ;x!Bv1U|@|=f_S0i_?EQe3*eJm-C(6*7hTc zLIU1s5XyUTwgRlkPk2@5urt_FkrAQum_Ceh1Vw0$Kjv^ZR0D_!a4#8Y*EoGAZ0rSo z?Y?*Bh869t(xH!-_~BT|5V&jbUJqs&TyOdv2h}HJ6JuykayuLAQu*(R`{x8b7K1ER>xmcw`TJpm}UKJ$PKhSzyI& z**L@tjf|1U82gEAXH>*)*zJnD|Mm+V&PrZOuvc0**B ziR@=@z=c7JVOyv11B3ITbDsOV>pheqx{gc~NoSsA)@HfTO|%A5(0$6@BV*`1CWUds z=lKSBzPhy~o8s>$MX-!q2qi~_2Cs$0R_8!hZ^R`3yCyC|;3tM8>2F z?^|V6yPTwfr4%fl*Puvk? zap|t?(6(OEFdhoK^-O>;L9D1-sf4@@NMV|V1p7uxEHNVNgX?5A7)E1t|FP;Y98+RI z*2;n~raENJi(TdGa5d^#N$YWz7de8M;OC{3s{eP7ejR<=a zqCZbY{RRO%`*#y1zIcO_llh;2152&)X;zhH&8}MIuNGh44OJG+4_s`bMhKahHKD$l zo29~7Kc|1{;L{j^2V03i!2;>i3Cj)ok=y;RxJMd21c~%6O2)C}PZFp6$etbl@a(Y@ zQ*lgj8#}k-#E7i&z*6^7N3nLpTwb$mgw_`!#+e;smLc)$QbsICCAW@|O;NvP)wT`% znmW$NUEEFSQu{B*@~EY8lhS#E)@PA@TaWqW@7_Sz*NkbFfme zW&==W;7c28)XhEdncoN#=Qq`A)$3GuZwJ{GnwvGQ84Cq0e8Gi74`gD6wr5@< zVvbKkg|ees2_I{~$}5!*896=355e#KgED#a|`JBcBQu+1m1z- zs^&>Z=G-;P=D{jX6sF&On+~e#(ve&43{7#@LZtJ-IR{s65hW*_cEH8K#N@#Z*GHjN zj_L+pk$B2JzMm|grSjCSRD%?)=4QVTOk|#Tamj-}b-uJ_u%{t!yIlXxr`H=m&N<6|Zp-ou+hF=es%~Z&FphHN-*wja+ICXq4V!nh7uV z|Kn_Ib|1&Wg#8vY4-vqZ1dcgsceb-16OPPoU0x2+EKBh?>Ug0r>0s#vH`So@^~R_E z9qHg9PFwa@hke2 zGX-;J>Qq?h*CU4LIQe|xRtrWtN@|(%IX-!uYBdfsRuwkX*qysQzEIp=+rT8_z$$hH zijp&U@0`YnrgVKX>XnY$`#JuVV;Cj)YHju)ai>;swM53Qn)%*z`N=oPl+~_XG(Uh{ z+nEc{zbwlFvkv-D|GQ81wQJae9;j{jTJ?~~>A`(O8vV+%-+5Cb*$*30<2$GL*ZJ};lTL0dN2_P(LhPWB}|m=CcWYi z7Y!^#hAE|xdJ#K4?~ievjy>L7@7dxvrg4Ue*Awt^X;~6KetcCvp(UuoYKP#eoI&fi zdscjFi`Ji`MvfcAfv~GV>2Voi+lHDiZoBlw7ty}@FZp@xPFy_-=o2}+03C~EtUp`e zR+)5}bL}hzs`}$$d<8d)q9}^y{CKqbCS~Ni&17lq3`*9?yY*toTdy6<`$bC%2c<|! z)Yp!z&(8H<$mG0jCZw!o_ZT$8Cba9i5v{~WK4a-#K);94%#_Bg*rZuf$D|(RF{}1p zT=nut7wPm-fm=@&kKe0qF0ub>BCkCxyzo_3^Y3MH?!4&IwS#d4oT=Z+07mBd`n61F z!s|sg;|$?DNh4D3Z-dAIJC#-E8@{J;ahVZuYCc5da1C=%L_*kXADpEKGZlM!$0n;% zcf&u+IihqOh%w4OGb@;7kgLs;H4$L`%9-?riVqc!lXxY6r6xhW4*EH;BKY_jjg2ZaYNpZuW+FJJQODVgyH?iSp1w58ab^jfYl zDO>Azc_ppv-`HuBTsz}^hWa{pek{eP|4{ju(#|Vwq*0Dn)vOU3w6rF|=#5aTNMj0; zi8wzyW)l;Dsk^vL!Z{FcRz~Bwh=VN3sx|YC2h^ZpJIb0N8@4MXayzJN=S2c}SXO*Z z$$95(l?c~NwNb2@0qpKnQ}$f3k+$I5 zv<35)l205{0!BN1j%yJuQqDU;0YngW{pC9CYKY3!EXA2O@xoIN*r%pYl)&So6w;yH zNr)gw-&T%0@Q#+mRdB`CBeITrr|(i_pyOg>-vxq?wKFTS>p63AC6Xr8wP$4Yo;$X9 z%H30!Jh#a1NGxv0@B+=DKgR+ETQ1|qHM3uLpA&pGzlrY-v$<;K(AV!hv|<{UTNYrW zYS)}yMNv->##aZNTNseT++Ep8V(6}PlK=-TTskI zmQ7dRPrU3nz!XjG^TXD6Y(cHp)-RqL893SZ+lohBQU5{f^M_^%7b(} zv9*(6_<7L?C|BAGXidvBg3BfFoD`*yA24}7Y7Vasf4NuUdj@N=?qD<8U#_@yJlaG_ zAYQor$Tq0&%1YMu9e3+Edp!fSr_5=?57cqs=RS21%X0lMP80XZl=7fx92g&gzUb% z$g2!Nz4Figt&KEmMw>q2+^N0T=3x|mWxMzNW_dTbo6HY6BR+qcHXSa5GzfK7V6&T# z3`g_3Y9Nobu?PPGd4PF!C<|^J<#%-nMV`cTla_yP*3=8~68NkUEXUMuxu>xXp7+iH z=!|^>MYiJwOIICCIi8ZOrGxx@YcV);dNO-8ZzZzbOk6hSAJDe_Xj{UHEZPih!_?LZ z-^ldAA!1B87$Ab4@ACNcpwt^m37)#uHEku*5l4!pGW+LneBq+ve<#W&=B{=J=$2|` zcryU#(VDzKc2k$2{WmfZj=OI!MwT^%zT43)GuKd?(WC8pbvIVP^uL~;_N{Sd9PSbU z&%91IWDV+{xj>!&+c8FRC_r8orjpBA__uVBBJ>(iQHOt>fm9tnYI}I<@E4$WLmi9k~ zU;1jZ{As$MUn+jt@AU~=7ry~|g1Z$DvTqQUh+HH0-EVlCP!D1I{q%yEYC#~IY1cKS zKrl_KNNo=L@#x#aKb?pdVQu}m^l(}>I4$mgOFes25brnmcM=QQ_+K` zb@3E!3NPd?PxgD$o%CCd8@B$12cE{;^oQK6_ZQ_7fwGx>wjkY|FzOLZ?u^h=B=F(O zT~^84cNCBxuCwO+kzdH$9bMKEfZ0+;Hv?aBirb_T-kDs&t9m0!o?u0J;4A(tv`^F0 zj(GAnPW0c?lBz3fFFr)C8glIOJU$=!3qPh9z1V~VP#xN|T{htU!ZNd~LimY4qTl59 z&6}uVH*Vp{m-G8Zsw6{Oz}M(rD|_t9prbBTYl58&IojPS5kfMQ=x*qgX353oR>S`k zfSz{#80UfC2!kP){53_5(Q!%*2`9g8XPK|mJnv)ytS8iDWRW)IWA&;yZ59;JL9SL2 zS@PVGJCX%Cnr>cdcy^=dnpT$0zKC~#c{g4W~HnOslkd`6F?cyHN z`jV00K`s@6sneTen*N@o~XIA!#ET>XhN4!29My}KS|=64dJSPElzuCdzpHsoC3n> zg2eQBx9%l^IC(6?9t41)ZW-j^7iTTDlp=JHw=*l^p|=PVOd8LOk5p`Uis!w|R?|ssT^CU{ zxd^qPNL%F>P4335fb>>lEcD9&7{TuG>Un}=t@{=2+U^>=d0`|whgmv}2YwHKrMD9F z95|K^QX{_(@=ZRO81+1;LPNi5?A?qNvf>nCKCbVM-dX0MZT=(W zu6Jy_W_9@=679Y+@^XZOYB8tFfGydPK7I$yb}f+&OOYHvRVr({kkgjk=(;0NSo#_) z%ArLG6vE_H+8jxrlQVse3?%Gqb$y) z6;>oHV`hsk9hZVYr`7-S1$d2-402ArPj-&s!`U4Oym33nO56NP$;G(yHRf8OnbQh6 zshMB@Tu3E$t`s|B;$quG^opv)w=Cl8d&rVo%tQl`2M-Zis_0+Wbw*1P68{F@jIBSI z_5LL>J|h1L3&FnC;l>Im{7Tr=y`PEi_T!L#va+ouOW^aWhy@eua(quyTZGSW{yYUR zDRiza7D=P|V0tQCRDrN+{qr*Q^$NsC05CYt!pi3MmE@LV%bR6?Wb?($Mi}46oTRNE zuQUuU-Mb&jtn12a)!ZM(rY)PfK-y)qRM*qs%UTBk*gT+zl80-}j&P_FL0YoGUM*a- z3gtp-o{fr!GQ%^-u{AD0mv(_%bx`%AtHgexA7en-;!aEXfVDXbL~eim^ZOdO0P6AF zdV%aD|G-o%00;{VuG;ML=RuNr->@%kA51@qgS{s*Yc<&RAVy zOT<0U)BJ!DxW8B zN~d`e#V2q{V{I#&xU{0*w{YY{>-FP>U&$<%<~KHxnaTL_jpkLcKh6lq@vrdn^$ghD z8&JV3^!+PIf)x3irGqKlTIg)mgFTwR5-{8WDLM;C{BZ$;OY(VU_SnuLB_k~Wfej16 zPOb|a)MdHB!0eIoArb4=x2FRBg*;){(}B8}>{PfA!PBavQci&QM6Z%oG;xBoQaisn z8FZnMl^Ae}J=BkDj%RAE5R|`SxK7CsyRmg1S-dKY_gN__hxON7trBymu;ZAz3~f~2 z$Qjk0Wth20y2phU#NO|5pYqGLPhZ!0?-vdXezjEDkX(Y3hx#d-PG1-{vdvdnD#w|- zMz?>Pvb>0R`CyMBJWd+H5=7_)N8D+-3wU#5NJoy@4;xrN1@M+@?RBWpo5Q!{_r1Yg ziyxQtM2Nl2^}d$0sBZ21;ZJLg88*~jq&q^3iLBZ_`{G&@>c`Rf=w(hN_5|#Jk{ItN&#_cC@ zy_eSsQ7#+leXb^a`Xn!*k}{>M6nhgc)S2X6XWU$+{=X8%4w^Np4+Rf6@}ej zw!|b#HAdC!2!-EcV12$NKPN|UQK!~S8_aFp-uO;SDL7X8;7>MfFlNzL-K!zT{Zvmg z+Xk=mn{Me+<8svTX?p+yh@&Q~(Q74-fq3wSdW68Y0NXm;I~>#x}YQ;~ZVr4AM)qc&_s!&l7qATBQxVIylWg zN1XL)ltrqsZ9W%%eCmN1r^_t_IB4%CWA6L;7lH-V-b49~@jhrNT;y;JM>A7xNS?Q0 zY+7Pcn}u|J4muj;IA|E>_dz%dd)g;V`ry_XjQo#6uOLrOx65?HEFNc!hU~v{C!ZH$ z33OlJ`@~}%o60%kYr70?z$W|H!)JXPRv$JTe89C*q+E(-Pwkcm52fy(iolrtomx3` z`-n^S%(ZHxv_xdN1&&(^b9CjTFm9JtexKJmk>HMY4o>V~#Yz^8wjW-}Dk>xBodzrX zSkM4h*VS;Te73Y=nw6)n{S50_FD9Io9|cZ#w3w=zN$MH;^zAp!wdh2tp@@s{B$>Ow z3=C~=>{z!l_iaqX$%TEtKBab=Zs)`Z&su1#rf@l2Mn2xCEK~lCrJo%%&48^}JG}Ju86$N06@WtMW z`~#{>*l58{@&^ql^_^1hZxUezYvtM|6E8Qt6dP{C2i<7eQ52vZRr?*U_J=j-=u?AR z2mC0joxafnmgd`pfCaB+^qjGXY4fQ0zhCle;RR>ChgY&@q-JF^-hKGl8FfJrn?-~$ zBCOVePm2ZYb1pI|%78BIH7x{Bd?3F*PEcgQ1{&lKZQ0+BhkmW3RHB(^|Li-xy&fPM z{-h@B_5CFa>~H=KeuG8g$>lF1AmKoD^AI_2rvQ6!16#`uo1$t53TKsq`-K~VJc0X| z<`nJn0CD=REo*g){hXbY9v>L|xzrnZrStR!vfV3i$#B+KMeN?a@+veG^GRI2~4N{Cgzs+D;TTIlZi0r#k>zb7Ws+E3p=+; zykArai!cDMSO3UH^33EMT^o?yXR+pZPc${f5XdCaeZR-DY3?(2260_Bmh)9DdJb<~ zub6xon>Ny0vpl12AO#Z7Dq@|2!S0KUIt1s+lebym&{d99m~-~a zhn_oA)!++Ci)UF=?!VPo`TIY&8x2&hssTBxZuWX$Xy)22bLRTlJFa>QA(Sx=Pemj; z1@p)=FfGUP_k8dk;C#q2t>xG8L}P_PdAhv8;~J)Yl&F}$D)euP>BdCO>1e8FWWIkC zLbRO0IM#0ak&VvfR%5e<8`*bAcKs~H-ve{Z)cq)zb5@0J?@9ozLl;GD%vp+;7|KdA z>EPQj)IemYQsM70?66b^OIp7LcvOo@YcRft$l%RMrzFvc@UVxw*VZDx{*Zn0aV3@^ z?==It;4$NTynes3ZX~wZRK{w(G(y2oafMGyY^TS5Jhx`ZFPSdntu^ z<4mWk;Lu+IYQ9&lo~>>1tQt@TI13`JHS%DrE(+w&4TB?MLH&2w2*h7lJDvZ-SwP!^Q&aqkstY9HTcLVw}=-t@>+}$ z9WEiEIONx2GC^TVv&GQIW7{wbK)5^%4E6Jf?VEbVE*@lVuNy(7@sqa=*Ul@tQCQO^ zc%s1wE%S$}?%DDjuuzr$b{xdo{3+KDQ(^MoLsUIG%=T4J(pOy#5Vk%oy7C*|c<7sh z0CFpl7+>K!Axr(&dvG4ea}NhY--}@%$d4yys)_;;>D5dSf~-(L{0CmE7O4o64_d&{ zfn{@0Z9;P#*ei$w+XA;hSJuMr^aQ#zN5ASGH3A{WcG?4p|O-iHxk~b zi5W0}&$GlU`+v!Nrr>2Wc6G5;a=}>AdP>AF>&|zlPhzyKfX9GAzfdL-5`F6ia_o2G z;rfy$ z8H%mKq5HE-<62 zb>yg@6(2TE^KOkkj~}a7(qQYdDH6bHf<9<4BH{C7Hz>;n`YL(jg1TsV!DA&^j3pjg z45Vi3W7lE0ipv&mmA<0%6>2aH)6NC_?4Y~9G;^Xia^y8yH!9G5aVJ#!tlVR&!yYJa zKr68nqX+~yI0LU&F5{v447iktd(H427!U0)G-&oDKV^KWuE$EaLdCk78-AmOQ{2k= zH1b$>rtoQbH8{{V#^%{svx3Ls?8gY9aQ*vbSGG%@@CQ}5G#;Fv03ol3nv(aIS4+R| z@?V(hjG6fyr?CS&P19VCi8#XSl}x)t$pUmIH^nK#epZ|mCIy6OD~X;h{A)ETg+JLD zuRo@(IBZMo5J%mQWgQb$Y&AgQx12%9?`L~3U4AbA`FpSZ2+20+rSI!h`|Q=%?R=!T zNA7&Y9eTBr=RKLoyhNE;IrzUMpWD;_i|g*ZA9xa?8QwYV(mA9Qr}V{`@SkG3-|xMw zfbVaGhx=C;L?=Bv_yL1RQGmp`wrfY0Vp@wGt!f{7>QL}D^t}?sF-)^R3=nM=qZui( z&$VsS2Xd=l|M%;FR$uv3;lRcB^wI!u_bn1W=*RznQSkzk^MYRNr;Kx)qu&UU#zj0f z$$j*6;X2v)1Iy>X9Bmu+N4B-tYNZ_nOad*jYs^!cV09Tto-8o2yf!=zIO zTw7#~aa(yxuE^Fqja-Fs!^pn8YnqVYsi$VB(r z3^Sq{{vOzV>kc+ diff --git a/vignettes/teaching1.R b/vignettes/teaching1.R index 74f4c69..a493ce4 100644 --- a/vignettes/teaching1.R +++ b/vignettes/teaching1.R @@ -1,4 +1,4 @@ -## ----load, message=FALSE--------------------------------------------------------------------------------------------- +## ----load, message=FALSE-------------------------------------------------------------------- library(goldfish) data("Social_Evolution") # ?Social_Evolution @@ -8,7 +8,7 @@ head(actors) -## ----quick----------------------------------------------------------------------------------------------------------- +## ----quick---------------------------------------------------------------------------------- callNetwork <- defineNetwork(nodes = actors, directed = TRUE) |> # 1 linkEvents(changeEvent = calls, nodes = actors) # 2 @@ -34,42 +34,42 @@ mod00Choice <- estimate( summary(mod00Choice) -## ----actors---------------------------------------------------------------------------------------------------------- +## ----actors--------------------------------------------------------------------------------- class(actors) head(actors) -## ----define-actors--------------------------------------------------------------------------------------------------- +## ----define-actors-------------------------------------------------------------------------- actors <- defineNodes(actors) actors -## ----calls-events---------------------------------------------------------------------------------------------------- +## ----calls-events--------------------------------------------------------------------------- head(calls) -## ----hlp1, eval=FALSE------------------------------------------------------------------------------------------------ +## ----hlp1, eval=FALSE----------------------------------------------------------------------- ## ?defineNetwork -## ----call-net-------------------------------------------------------------------------------------------------------- +## ----call-net------------------------------------------------------------------------------- callNetwork <- defineNetwork(nodes = actors, directed = TRUE) -## ----strNet---------------------------------------------------------------------------------------------------------- +## ----strNet--------------------------------------------------------------------------------- callNetwork -## ----hlp2, eval=FALSE------------------------------------------------------------------------------------------------ +## ----hlp2, eval=FALSE----------------------------------------------------------------------- ## ?linkEvents -## ----link-call-net--------------------------------------------------------------------------------------------------- +## ----link-call-net-------------------------------------------------------------------------- callNetwork <- linkEvents(x = callNetwork, changeEvent = calls, nodes = actors) callNetwork -## ----frdshp-net------------------------------------------------------------------------------------------------------ +## ----frdshp-net----------------------------------------------------------------------------- head(friendship) friendshipNetwork <- defineNetwork(nodes = actors, directed = TRUE) friendshipNetwork <- linkEvents( @@ -80,11 +80,11 @@ friendshipNetwork <- linkEvents( friendshipNetwork -## ----hlp3, eval=FALSE------------------------------------------------------------------------------------------------ +## ----hlp3, eval=FALSE----------------------------------------------------------------------- ## ?defineDependentEvents -## ----call-dep-events------------------------------------------------------------------------------------------------- +## ----call-dep-events------------------------------------------------------------------------ callsDependent <- defineDependentEvents( events = calls, nodes = actors, defaultNetwork = callNetwork @@ -92,7 +92,7 @@ callsDependent <- defineDependentEvents( callsDependent -## ----plot-teaching1, message=FALSE, warning=FALSE-------------------------------------------------------------------- +## ----plot-teaching1, message=FALSE, warning=FALSE------------------------------------------- library(igraph) library(ggraph) library(migraph) @@ -124,15 +124,15 @@ autographr(callNetworkEnd, labels = FALSE, layout = "fr") + table(as.matrix(callNetwork, time = max(calls$time) + 1)) -## ----effects, eval=FALSE--------------------------------------------------------------------------------------------- +## ----effects, eval=FALSE-------------------------------------------------------------------- ## vignette("goldfishEffects") -## ----simple-formula-------------------------------------------------------------------------------------------------- +## ----simple-formula------------------------------------------------------------------------- simpleFormulaChoice <- callsDependent ~ tie(friendshipNetwork) -## ----simple-choice--------------------------------------------------------------------------------------------------- +## ----simple-choice-------------------------------------------------------------------------- mod01Choice <- estimate( simpleFormulaChoice, model = "DyNAM", subModel = "choice" @@ -140,7 +140,7 @@ mod01Choice <- estimate( summary(mod01Choice) -## ----complex-choice-------------------------------------------------------------------------------------------------- +## ----complex-choice------------------------------------------------------------------------- complexFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + tie(friendshipNetwork) + recip(friendshipNetwork) + @@ -153,7 +153,7 @@ mod02Choice <- estimate( summary(mod02Choice) -## ----simple-rate----------------------------------------------------------------------------------------------------- +## ----simple-rate---------------------------------------------------------------------------- simpleFormulaRate <- callsDependent ~ indeg(friendshipNetwork) mod01Rate <- estimate( simpleFormulaRate, @@ -161,7 +161,7 @@ mod01Rate <- estimate( ) -## ----estimate-init--------------------------------------------------------------------------------------------------- +## ----estimate-init-------------------------------------------------------------------------- mod01Rate <- estimate( simpleFormulaRate, model = "DyNAM", subModel = "rate", @@ -170,7 +170,7 @@ mod01Rate <- estimate( summary(mod01Rate) -## ----complex-rate---------------------------------------------------------------------------------------------------- +## ----complex-rate--------------------------------------------------------------------------- complexFormulaRate <- callsDependent ~ indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -179,7 +179,7 @@ mod02Rate <- estimate(complexFormulaRate, model = "DyNAM", subModel = "rate") summary(mod02Rate) -## ----intcpt-rate----------------------------------------------------------------------------------------------------- +## ----intcpt-rate---------------------------------------------------------------------------- interceptFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -188,7 +188,7 @@ mod03Rate <- estimate(interceptFormulaRate, model = "DyNAM", subModel = "rate") summary(mod03Rate) -## ----waiting-time---------------------------------------------------------------------------------------------------- +## ----waiting-time--------------------------------------------------------------------------- mod03RateCoef <- coef(mod03Rate) 1 / exp(mod03RateCoef[["Intercept"]]) / 3600 # or days: @@ -209,7 +209,7 @@ mod03RateCoef <- coef(mod03Rate) ) / 3600 -## ----windows-rate---------------------------------------------------------------------------------------------------- +## ----windows-rate--------------------------------------------------------------------------- windowFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(callNetwork, window = 300) + @@ -220,7 +220,7 @@ mod04Rate <- estimate(windowFormulaRate, model = "DyNAM", subModel = "rate") summary(mod04Rate) -## ----windows-choice-------------------------------------------------------------------------------------------------- +## ----windows-choice------------------------------------------------------------------------- windowFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + inertia(callNetwork, window = 300) + @@ -233,7 +233,7 @@ mod03Choice <- estimate(windowFormulaChoice, summary(mod03Choice) -## ----aic------------------------------------------------------------------------------------------------------------- +## ----aic------------------------------------------------------------------------------------ # Compare different specifications of the subModel = "choice" AIC(mod02Choice, mod03Choice) @@ -241,7 +241,7 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) -## ----rem------------------------------------------------------------------------------------------------------------- +## ----rem------------------------------------------------------------------------------------ allFormulaREM <- callsDependent ~ 1 + indeg(callNetwork, type = "ego") + outdeg(callNetwork, type = "ego") + @@ -252,14 +252,14 @@ allFormulaREM <- same(actors$gradeType) + same(actors$floor) -## ----rem-gather, eval=FALSE------------------------------------------------------------------------------------------ +## ----rem-gather, eval=FALSE----------------------------------------------------------------- ## mod01REM <- estimate( ## allFormulaREM, model = "REM", ## estimationInit = list(initialDamping = 40, engine = "default_c") ## ) -## ----rem-c----------------------------------------------------------------------------------------------------------- +## ----rem-c---------------------------------------------------------------------------------- mod01REM <- estimate( allFormulaREM, model = "REM", estimationInit = list(engine = "gather_compute") diff --git a/vignettes/teaching1.Rmd b/vignettes/teaching1.Rmd index d95e3d0..1b358d3 100644 --- a/vignettes/teaching1.Rmd +++ b/vignettes/teaching1.Rmd @@ -824,7 +824,8 @@ AIC(mod02Choice, mod03Choice) # Compare different specifications of the subModel = "rate" AIC(mod03Rate, mod04Rate) -#> Warning in AIC.default(mod03Rate, mod04Rate): models are not all fitted to the same number of observations +#> Warning in AIC.default(mod03Rate, mod04Rate): models are not all fitted to the same number of +#> observations #> df AIC #> mod03Rate 4 12014.20 #> mod04Rate 6 10963.75 diff --git a/vignettes/teaching2.R b/vignettes/teaching2.R index 5e14d0b..8ee8f22 100644 --- a/vignettes/teaching2.R +++ b/vignettes/teaching2.R @@ -1,76 +1,76 @@ -## ----setup, message=FALSE-------------------------------------------------------------------------------------------- +## ----setup, message=FALSE------------------------------------------------------------------- library(goldfish) -## ----load-data------------------------------------------------------------------------------------------------------- +## ----load-data------------------------------------------------------------------------------ data("Fisheries_Treaties_6070") # ?Fisheries_Treaties_6070 -## ----examine-states-------------------------------------------------------------------------------------------------- +## ----examine-states------------------------------------------------------------------------- tail(states) class(states) -## ----defineNodes----------------------------------------------------------------------------------------------------- +## ----defineNodes---------------------------------------------------------------------------- states <- defineNodes(states) head(states) class(states) -## ----examine-node-changes-------------------------------------------------------------------------------------------- +## ----examine-node-changes------------------------------------------------------------------- head(sovchanges) head(regchanges) head(gdpchanges) -## ----present--------------------------------------------------------------------------------------------------------- +## ----present-------------------------------------------------------------------------------- head(states$present) # or states[,2] -## ----link-present---------------------------------------------------------------------------------------------------- +## ----link-present--------------------------------------------------------------------------- states <- linkEvents(states, sovchanges, attribute = "present") # If you call the object now, what happens? states -## ----states---------------------------------------------------------------------------------------------------------- +## ----states--------------------------------------------------------------------------------- str(states) -## ----link-states-vars------------------------------------------------------------------------------------------------ +## ----link-states-vars----------------------------------------------------------------------- states <- linkEvents(states, regchanges, attribute = "regime") |> linkEvents(gdpchanges, attribute = "gdp") str(states) -## ----examine-bilat-mat----------------------------------------------------------------------------------------------- +## ----examine-bilat-mat---------------------------------------------------------------------- bilatnet[1:12, 1:12] # head(bilatnet, n = c(12, 12)) -## ----define-bilat-net------------------------------------------------------------------------------------------------ +## ----define-bilat-net----------------------------------------------------------------------- bilatnet <- defineNetwork(bilatnet, nodes = states, directed = FALSE) -## ----examine-bilat-net----------------------------------------------------------------------------------------------- +## ----examine-bilat-net---------------------------------------------------------------------- class(bilatnet) str(bilatnet) bilatnet -## ----link-bilat-net-------------------------------------------------------------------------------------------------- +## ----link-bilat-net------------------------------------------------------------------------- bilatnet <- linkEvents(bilatnet, bilatchanges, nodes = states) bilatnet -## ----contig-net------------------------------------------------------------------------------------------------------ +## ----contig-net----------------------------------------------------------------------------- contignet <- defineNetwork(contignet, nodes = states, directed = FALSE) |> linkEvents(contigchanges, nodes = states) class(contignet) contignet -## ----define-dep-events----------------------------------------------------------------------------------------------- +## ----define-dep-events---------------------------------------------------------------------- createBilat <- defineDependentEvents( events = bilatchanges[bilatchanges$increment == 1,], nodes = states, @@ -78,17 +78,17 @@ createBilat <- defineDependentEvents( ) -## ----examine-dep-events---------------------------------------------------------------------------------------------- +## ----examine-dep-events--------------------------------------------------------------------- class(createBilat) createBilat -## ----hlp, eval = FALSE----------------------------------------------------------------------------------------------- +## ----hlp, eval = FALSE---------------------------------------------------------------------- ## ?as.data.frame.nodes.goldfish ## ?as.matrix.network.goldfish -## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'------------------------------------------------ +## ----plot-teaching2, message=FALSE, warning=FALSE, fig.align='center'----------------------- library(igraph) library(manynet) @@ -123,11 +123,11 @@ endNet <- delete_nodes(endNet, !isStateActive) autographs(list(startNet, endNet), layout = "fr") -## ----hlp-effects, eval=FALSE----------------------------------------------------------------------------------------- +## ----hlp-effects, eval=FALSE---------------------------------------------------------------- ## vignette("goldfishEffects") -## ----estimate-init--------------------------------------------------------------------------------------------------- +## ----estimate-init-------------------------------------------------------------------------- formula1 <- createBilat ~ inertia(bilatnet) + indeg(bilatnet, ignoreRep = TRUE) + trans(bilatnet, ignoreRep = TRUE) + @@ -150,7 +150,7 @@ system.time( ) -## ----estimate-rerun-------------------------------------------------------------------------------------------------- +## ----estimate-rerun------------------------------------------------------------------------- estPrefs <- list( returnIntervalLogL = TRUE, initialDamping = 40, @@ -166,7 +166,7 @@ partnerModel <- estimate( summary(partnerModel) -## ----estimate-c------------------------------------------------------------------------------------------------------ +## ----estimate-c----------------------------------------------------------------------------- formula2 <- createBilat ~ inertia(bilatnet, weighted = TRUE) + indeg(bilatnet) + trans(bilatnet) + @@ -189,7 +189,7 @@ system.time( ) -## ----broom, message=FALSE-------------------------------------------------------------------------------------------- +## ----broom, message=FALSE------------------------------------------------------------------- library(broom) library(pixiedust) dust(tidy(tieModel, conf.int = TRUE)) |> @@ -197,11 +197,11 @@ dust(tidy(tieModel, conf.int = TRUE)) |> sprinkle(col = 5, fn = quote(pvalString(value))) -## ----glance---------------------------------------------------------------------------------------------------------- +## ----glance--------------------------------------------------------------------------------- glance(tieModel) -## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3-------------------------------------------- +## ----examine, fig.width=6, fig.height=4, fig.align='center', fig.retina=3------------------- examineOutliers(tieModel) examineChangepoints(tieModel) diff --git a/vignettes/teaching2.Rmd b/vignettes/teaching2.Rmd index 4fa15e8..0e69622 100644 --- a/vignettes/teaching2.Rmd +++ b/vignettes/teaching2.Rmd @@ -464,7 +464,7 @@ system.time( ) ) #> user system elapsed -#> 231.94 6.51 245.44 +#> 194.74 9.31 206.95 ``` Did the model converge? If not, you can restart the estimation process using @@ -556,7 +556,7 @@ system.time( ) ) #> user system elapsed -#> 137.27 0.86 139.80 +#> 125.22 1.61 126.84 ``` # Extensions... From 773edc9234889e836a09f95bc3068cc0a6f7bb64 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 12 Mar 2024 02:39:06 +0100 Subject: [PATCH 30/36] Create test for output functions, solves #85 --- R/functions_output.R | 6 +- R/testthat-helpers.R | 4 +- tests/testthat/test-functions_output.R | 161 +++++++++++++++++++++++++ 3 files changed, 166 insertions(+), 5 deletions(-) create mode 100644 tests/testthat/test-functions_output.R diff --git a/R/functions_output.R b/R/functions_output.R index 8bf10fe..df890e2 100644 --- a/R/functions_output.R +++ b/R/functions_output.R @@ -151,11 +151,11 @@ print.summary.result.goldfish <- function( } if (isDetPrint) { - cat("\nEffects details :\n") + cat("\nEffects details:\n") print.default(names, quote = FALSE, width = width, ...) } - cat("\nCoefficients :\n") + cat("\nCoefficients:\n") stats::printCoefmat(coefMat, digits = digits, width = width, ...) cat("\n") cat(" ", paste( @@ -251,7 +251,7 @@ print.nodes.goldfish <- function(x, ..., full = FALSE, n = 6) { print.network.goldfish <- function(x, ..., full = FALSE, n = 6L) { nodes <- attr(x, "nodes") directed <- attr(x, "directed") - ties <- if (directed) sum(x > 0) else sum(x > 0) / 2 + ties <- sum(x > 0, na.rm = TRUE) / ifelse(directed, 1, 2) events <- attr(x, "events") cat( "Dimensions:", paste(dim(x), collapse = " "), diff --git a/R/testthat-helpers.R b/R/testthat-helpers.R index c28ddf9..0f583e4 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -76,10 +76,10 @@ vCache <- c(0, 2, 3, 1, 0) # Attributes ------------------------------------------------------- testAttr <- data.frame( - label = as.factor(c( + label = c( "Christoph", "James", "Per", "Timon", "Marion", "Mepham", "Xiaolei", "Federica" - )), + ), fishingSkill = c(10, NA, 5, 10, 8, 8, 3, NA), fishCaught = c(1, 99, 15, 12, 15, 8, 0, 2), fishSizeMean = c(9.9, 0.1, 0.5, 0.45, 0.25, 0.3, NA, 10), diff --git a/tests/testthat/test-functions_output.R b/tests/testthat/test-functions_output.R new file mode 100644 index 0000000..6f5a964 --- /dev/null +++ b/tests/testthat/test-functions_output.R @@ -0,0 +1,161 @@ +test_that("summary goldfish", { + objSum <- summary(resModObject) + expect_s3_class(objSum, "summary.result.goldfish") + expect_length(objSum, 18) + expect_true(inherits(objSum$coefMat, "array")) + expect_type(objSum$coefMat, "double") + expect_length(objSum$coefMat, resModObject$nParams * 4) + expect_true(is.na(objSum$coefMat[2, 2])) + expect_type(objSum$AIC, "double") + expect_type(objSum$BIC, "double") + expect_length(objSum$AIC, 1) + expect_length(objSum$BIC, 1) +}) +test_that("summary goldfish print", { + # objInv <- expect_invisible(print(summary(resModObject))) + expect_output(print(summary(resModObject)), "AIC") + expect_output(print(summary(resModObject)), "BIC") + expect_output(print(summary(resModObject)), "Call:") + expect_output(print(summary(resModObject)), "Coefficients:") + expect_failure(expect_output(print(summary(resModObject)), "\nrecip")) + expect_output( + print(summary(resModObject), complete = TRUE), "\nrecip" + ) + expect_failure(expect_output( + print(summary(resModObject)), "\nEffects details" + )) + expect_output( + print(summary(resModObject), complete = TRUE), "\nEffects details" + ) +}) +test_that("result print", { + expect_output(print(resModObject), "Call:") + expect_output(print(resModObject), "Coefficients:") + expect_failure( + expect_output(print(resModObject), "\ninertia recip trans") + ) + expect_output( + print(resModObject, complete = TRUE), "\ninertia recip trans" + ) +}) +test_that("nodes print", { + expect_output(print(actorsEx), paste("Number of nodes:", nrow(actorsEx))) + expect_output( + print(actorsEx), + paste("Number of present nodes:", sum(actorsEx$present)) + ) + expect_output(print(actorsEx), "Dynamic attribute") + expect_failure(expect_output(print(actorsEx, full = TRUE), "First \\d rows")) + expect_output( + print(defineNodes(testAttr)), + paste("Number of nodes:", nrow(testAttr)) + ) + expect_failure( + expect_output(print(defineNodes(testAttr)), "Number of present nodes:") + ) + expect_failure( + expect_output(print(defineNodes(testAttr)), "Dynamic attribute") + ) + expect_output(print(defineNodes(testAttr)), "First 6 rows") + expect_failure( + expect_output(print(defineNodes(testAttr), full = TRUE), "First 6 rows") + ) +}) +test_that("network print", { + expect_output( + print(networkState), + paste("Dimensions:", paste(dim(networkState), collapse = " ")) + ) + expect_output( + print(networkState), + paste("Number of ties \\(no weighted\\):", sum(networkState > 0)) + ) + expect_output(print(networkState), "Nodes set\\(s\\): actorsEx") + expect_output(print(networkState), "It is a one-mode and directed network") + expect_output(print(networkState), "Linked events: eventsIncrement") + expect_output(print(networkState), "First \\d rows and columns") + expect_failure( + expect_output(print(networkState, full = TRUE), + "First \\d rows and columns") + ) + + netTest <- defineNetwork(matrix = m, nodes = actorsEx) + expect_output( + print(netTest), + paste("Dimensions:", paste(dim(netTest), collapse = " ")) + ) + expect_output( + print(netTest), + paste("Number of ties \\(no weighted\\):", sum(netTest > 0, na.rm = TRUE)) + ) + expect_output(print(netTest), "Nodes set\\(s\\): actorsEx") + expect_output(print(netTest), "It is a one-mode and directed network") + expect_failure( + expect_output(print(netTest), "Linked events: eventsIncrement") + ) + expect_output(print(netTest), "First \\d rows and columns") + expect_failure( + expect_output(print(netTest, full = TRUE), + "First \\d rows and columns") + ) + + expect_output( + print(networkActorClub), + paste("Dimensions:", paste(dim(networkActorClub), collapse = " ")) + ) + expect_output( + print(networkActorClub), + paste("Number of ties \\(no weighted\\):", sum(networkActorClub)) + ) + expect_output(print(networkActorClub), "Nodes set\\(s\\): actorsEx clubsEx") + expect_output( + print(networkActorClub), "It is a two-mode and directed network" + ) + expect_output(print(networkActorClub), "Linked events: eventsActorClub") + expect_output(print(networkActorClub), "First \\d rows and columns") + expect_failure( + expect_output(print(networkActorClub, full = TRUE), + "First \\d rows and columns") + ) +}) +test_that("dependent events", { + expect_output(print(depNetwork), paste("Number of events:", nrow(depNetwork))) + expect_output(print(depNetwork), "Nodes set\\(s\\): actorsEx") + expect_output(print(depNetwork), "Default network: networkState") + expect_output(print(depNetwork), "First \\d rows") + expect_failure( + expect_output(print(depNetwork, full = TRUE), "First \\d rows") + ) +}) +test_that("preprocessed", { + preproData <- estimate( + depNetwork ~ inertia(networkState, weighted = TRUE) + + tie(networkExog, weighted = TRUE), + model = "DyNAM", subModel = "choice", + preprocessingOnly = TRUE + ) + expect_output(print(preproData), "Preprocess object for the model") +}) +test_that("tidy results", { + expect_s3_class(tidy(resModObject), "tbl_df") + expect_length(tidy(resModObject), 5) + expect_equal(nrow(tidy(resModObject)), 2L) + expect_equal( + tidy(resModObject)$term, + paste("callNetwork", c("inertia", "trans"), "FALSE") + ) + expect_length(tidy(resModObject, conf.int = TRUE), 7) + expect_equal( + tidy(resModObject, complete = TRUE)$term, + paste("callNetwork", c("inertia", "recip", "trans"), c(F, T, F)) + ) + expect_true( + anyNA(tidy(resModObject, complete = TRUE, conf.int = TRUE)$statistic) + ) +}) +test_that("glance results", { + expect_s3_class(glance(resModObject), "tbl_df") + expect_length(glance(resModObject), 5) + expect_equal(nrow(glance(resModObject)), 1L) + expect_equal(glance(resModObject)$logLik, resModObject$logLikelihood) +}) From 01c440298bc46c6134c1a72bff51de06c6f14518 Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 12 Mar 2024 03:32:33 +0100 Subject: [PATCH 31/36] Solves #87, bug when using preprocess init object and add test for it --- R/functions_estimation.R | 6 ++-- tests/testthat/test-functions_estimation.R | 32 ++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) create mode 100644 tests/testthat/test-functions_estimation.R diff --git a/R/functions_estimation.R b/R/functions_estimation.R index f30f5ed..49be059 100644 --- a/R/functions_estimation.R +++ b/R/functions_estimation.R @@ -617,7 +617,7 @@ estimate.formula <- function( } # dependent stats updates - for (t in seq_along(allprep$intervals)) { + for (t in seq_along(preprocessingInit$dependentStatsChange)) { cptnew <- 1 allprep$dependentStatsChange[[t]] <- lapply(seq_along(effectsindexes), function(x) NULL) @@ -643,8 +643,8 @@ estimate.formula <- function( } # right censored stats updates - if (length(allprep$rightCensoredIntervals) > 0) { - for (t in seq_along(allprep$rightCensoredIntervals)) { + if (length(preprocessingInit$rightCensoredIntervals) > 0) { + for (t in seq_along(preprocessingInit$rightCensoredIntervals)) { cptnew <- 1 allprep$rightCensoredStatsChange[[t]] <- lapply(seq_along(effectsindexes), function(x) NULL) diff --git a/tests/testthat/test-functions_estimation.R b/tests/testthat/test-functions_estimation.R new file mode 100644 index 0000000..9634463 --- /dev/null +++ b/tests/testthat/test-functions_estimation.R @@ -0,0 +1,32 @@ +test_that("preprocess init", { + formulaTest <- depNetwork ~ outdeg(networkState, weighted = TRUE) + + outdeg(networkExog, weighted = TRUE) + inertia + recip + preproData <- estimate( + formulaTest, + model = "DyNAM", subModel = "choice", + preprocessingOnly = TRUE + ) + toCompare <- c( + "parameters", "standardErrors", "logLikelihood", "finalScore", + "finalInformationMatrix", "convergence", "nIterations", "nEvents", "names", + "formula", "model", "subModel", "rightCensored", "nParams" + ) + expect_equal( + estimate(formulaTest)[toCompare], + estimate(formulaTest, preprocessingInit = preproData)[toCompare] + ) + formulaTest <- depNetwork ~ 1 + outdeg(networkState, weighted = TRUE) + + outdeg(networkExog, weighted = TRUE) + preproData <- estimate( + formulaTest, + model = "DyNAM", subModel = "rate", + preprocessingOnly = TRUE + ) + expect_equal( + estimate(formulaTest, subModel = "rate")[toCompare], + estimate( + formulaTest, subModel = "rate", preprocessingInit = preproData + )[toCompare] + ) +}) + From caa8b9545faa6e0bc0e81ddbd6eaf49945f9c58c Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 12 Mar 2024 03:37:47 +0100 Subject: [PATCH 32/36] Update news with issues solved --- NEWS.md | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index fec5e53..6a5fd75 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,13 +2,16 @@ * Debugging and extend documentation for `GatherPreprocessing()`. * Fix note from CRAN checks. +* Debug issue when using a preprocess init object in `estimate()`. +* Debug issue with opportunity list in `estimate()` for `DyNAM` models. +* Fix error in printing output from `estimate()` when using + a parameter is fixed to a value. # goldfish 1.6.5 * Solves `startTime` and `endTime` bug on `DyNAM` and `REM` models preprocessing. * Export `GatherPreprocessing()`. Experimental functionality. -* Introduces experimental functionality `simulation()`. * Clean unnecessary functions imports. * Solves `aes_string()` deprecation. * Solves issue on `C++` engine on DyNAM-rate. From e75d85c1b0e7ea0301ddbea8fb4afa7dd95794da Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 12 Mar 2024 16:58:03 +0100 Subject: [PATCH 33/36] configure.ac file gets version from the DESCRIPTION file --- configure | 22 +++++++++++----------- configure.ac | 7 ++++--- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/configure b/configure index 9f3b3cf..b8f2fd3 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for Goldfish @VERSION@. +# Generated by GNU Autoconf 2.69 for goldfish 1.6.6 . # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. @@ -574,10 +574,10 @@ MFLAGS= MAKEFLAGS= # Identity of this package. -PACKAGE_NAME='Goldfish' +PACKAGE_NAME='goldfish' PACKAGE_TARNAME='goldfish' -PACKAGE_VERSION='@VERSION@' -PACKAGE_STRING='Goldfish @VERSION@' +PACKAGE_VERSION='1.6.6 ' +PACKAGE_STRING='goldfish 1.6.6 ' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1196,7 +1196,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures Goldfish @VERSION@ to adapt to many kinds of systems. +\`configure' configures goldfish 1.6.6 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1258,7 +1258,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of Goldfish @VERSION@:";; + short | recursive ) echo "Configuration of goldfish 1.6.6 :";; esac cat <<\_ACEOF @@ -1338,7 +1338,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -Goldfish configure @VERSION@ +goldfish configure 1.6.6 generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1430,7 +1430,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Goldfish $as_me @VERSION@, which was +It was created by goldfish $as_me 1.6.6 , which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -3020,7 +3020,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by Goldfish $as_me @VERSION@, which was +This file was extended by goldfish $as_me 1.6.6 , which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -3073,7 +3073,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -Goldfish config.status @VERSION@ +goldfish config.status 1.6.6 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" @@ -3636,7 +3636,7 @@ fi echo " -------------------------------------------------- - Configuration for goldfish version ${VERSION} + Configuration for goldfish version ${PACKAGE_VERSION} ================ openMP: ${openmp_flag} diff --git a/configure.ac b/configure.ac index f3e94a8..9476bda 100644 --- a/configure.ac +++ b/configure.ac @@ -1,13 +1,14 @@ ## -*- mode: autoconf; autoconf-indentation: 4; -*- ## ## Copyright Dirk Eddelbuettel for RcppArmadillo (GPL-2) +## https://stackoverflow.com/questions/46723854/rcpparmadillo-using-autoconf-to-disable-openmp +## nspope/radish repo uses it -VERSION=$(grep -i ^version DESCRIPTION | awk '{print $2}') ## require at least autoconf 2.69 AC_PREREQ([2.69]) ## Process this file with autoconf to produce a configure script. -AC_INIT([Goldfish], @VERSION@) +AC_INIT([goldfish], m4_esyscmd_s([awk -e '/^Version:/ {print $2}' DESCRIPTION])) ## Set R_HOME, respecting an environment variable if one is set : ${R_HOME=$(R RHOME)} @@ -55,7 +56,7 @@ AC_OUTPUT echo " -------------------------------------------------- - Configuration for goldfish version ${VERSION} + Configuration for goldfish version ${PACKAGE_VERSION} ================ openMP: ${openmp_flag} From 6c5c1861878ddd2835ef9e7ae44a2df83d12365e Mon Sep 17 00:00:00 2001 From: ualvaro Date: Tue, 12 Mar 2024 17:12:03 +0100 Subject: [PATCH 34/36] Revert "configure.ac file gets version from the DESCRIPTION file" This reverts commit e75d85c1b0e7ea0301ddbea8fb4afa7dd95794da. --- configure | 22 +++++++++++----------- configure.ac | 7 +++---- 2 files changed, 14 insertions(+), 15 deletions(-) diff --git a/configure b/configure index b8f2fd3..9f3b3cf 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.69 for goldfish 1.6.6 . +# Generated by GNU Autoconf 2.69 for Goldfish @VERSION@. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. @@ -574,10 +574,10 @@ MFLAGS= MAKEFLAGS= # Identity of this package. -PACKAGE_NAME='goldfish' +PACKAGE_NAME='Goldfish' PACKAGE_TARNAME='goldfish' -PACKAGE_VERSION='1.6.6 ' -PACKAGE_STRING='goldfish 1.6.6 ' +PACKAGE_VERSION='@VERSION@' +PACKAGE_STRING='Goldfish @VERSION@' PACKAGE_BUGREPORT='' PACKAGE_URL='' @@ -1196,7 +1196,7 @@ if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures goldfish 1.6.6 to adapt to many kinds of systems. +\`configure' configures Goldfish @VERSION@ to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1258,7 +1258,7 @@ fi if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of goldfish 1.6.6 :";; + short | recursive ) echo "Configuration of Goldfish @VERSION@:";; esac cat <<\_ACEOF @@ -1338,7 +1338,7 @@ fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -goldfish configure 1.6.6 +Goldfish configure @VERSION@ generated by GNU Autoconf 2.69 Copyright (C) 2012 Free Software Foundation, Inc. @@ -1430,7 +1430,7 @@ cat >config.log <<_ACEOF This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by goldfish $as_me 1.6.6 , which was +It was created by Goldfish $as_me @VERSION@, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ @@ -3020,7 +3020,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by goldfish $as_me 1.6.6 , which was +This file was extended by Goldfish $as_me @VERSION@, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -3073,7 +3073,7 @@ _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -goldfish config.status 1.6.6 +Goldfish config.status @VERSION@ configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" @@ -3636,7 +3636,7 @@ fi echo " -------------------------------------------------- - Configuration for goldfish version ${PACKAGE_VERSION} + Configuration for goldfish version ${VERSION} ================ openMP: ${openmp_flag} diff --git a/configure.ac b/configure.ac index 9476bda..f3e94a8 100644 --- a/configure.ac +++ b/configure.ac @@ -1,14 +1,13 @@ ## -*- mode: autoconf; autoconf-indentation: 4; -*- ## ## Copyright Dirk Eddelbuettel for RcppArmadillo (GPL-2) -## https://stackoverflow.com/questions/46723854/rcpparmadillo-using-autoconf-to-disable-openmp -## nspope/radish repo uses it +VERSION=$(grep -i ^version DESCRIPTION | awk '{print $2}') ## require at least autoconf 2.69 AC_PREREQ([2.69]) ## Process this file with autoconf to produce a configure script. -AC_INIT([goldfish], m4_esyscmd_s([awk -e '/^Version:/ {print $2}' DESCRIPTION])) +AC_INIT([Goldfish], @VERSION@) ## Set R_HOME, respecting an environment variable if one is set : ${R_HOME=$(R RHOME)} @@ -56,7 +55,7 @@ AC_OUTPUT echo " -------------------------------------------------- - Configuration for goldfish version ${PACKAGE_VERSION} + Configuration for goldfish version ${VERSION} ================ openMP: ${openmp_flag} From c417c6e5a27a601b824fd793c0406c714e431b6f Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 13 Mar 2024 11:38:47 +0100 Subject: [PATCH 35/36] Update date in DESCRIPTION --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 25ab4f5..f219098 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -3,7 +3,7 @@ Package: goldfish Type: Package Title: Statistical Network Models for Dynamic Network Data Version: 1.6.6 -Date: 2024-03-07 +Date: 2024-03-13 Authors@R: c(person("James", "Hollway", role = c("cre", "aut", "dtc"), email = "james.hollway@graduateinstitute.ch", comment = c("IHEID", ORCID = "0000-0002-8361-9647")), From 7057fa002354262151936b3d73c53a6d9f474b0c Mon Sep 17 00:00:00 2001 From: ualvaro Date: Wed, 13 Mar 2024 12:03:43 +0100 Subject: [PATCH 36/36] Update cran comments --- cran-comments.md | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index 389e548..5d5d274 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -1,14 +1,10 @@ ## Test environments -* local R installation, x86_64-apple-darwin17.0, R 4.2.0 -* Mac OS X 11.6.5 (on Github), R 4.2.1 -* Microsoft Windows Server 2022 10.0.20348 (on Github), R 4.2.1 -* Ubuntu 20.04.4 (on Github), R 4.2.1 +* local R installation, Windows 10 x64 19405, R 4.3.1 +* Mac OS Monterey 12.7.3 (on Github), R 4.3.3 +* Microsoft Windows Server 2022 10.0.20348 (on Github), R 4.3.3 +* Ubuntu 20.04.6 (on Github), R 4.3.3 ## R CMD check results -0 errors | 0 warnings | 1 note - -* This is a new release. -* Global environment is in no longer mentioned - +0 errors | 0 warnings | 0 note