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 6519253..f219098 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.5 -Date: 2023-06-20 +Version: 1.6.6 +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")), @@ -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), @@ -54,6 +54,7 @@ Suggests: igraph, ggraph, migraph, + manynet, broom, lmtest VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index dab0f53..43f6a2f 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -18,6 +18,7 @@ S3method(print,summary.result.goldfish) S3method(summary,result.goldfish) S3method(tidy,result.goldfish) S3method(vcov,result.goldfish) +export(GatherPreprocessing) export(defineDependentEvents) export(defineGlobalAttribute) export(defineGroups_interaction) diff --git a/NEWS.md b/NEWS.md index 9c508e0..6a5fd75 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,7 +1,17 @@ +# goldfish 1.6.6 + +* 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. * Clean unnecessary functions imports. * Solves `aes_string()` deprecation. * Solves issue on `C++` engine on DyNAM-rate. 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..40680bd 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}{ +#' \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_checks.R b/R/functions_checks.R index ac643e7..bf90b80 100644 --- a/R/functions_checks.R +++ b/R/functions_checks.R @@ -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,57 +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) { 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 <- mapply( + 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)) return(all(checked)) } @@ -292,7 +301,7 @@ checkNodes <- function(nodes) { # columns names and types tryCatch( checkColumns( - inDataFrame = nodes, + inDataFrame = nodes, mandatoryNames = "label", optionalNames = "present", classes = list( @@ -302,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) } @@ -359,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. ", @@ -444,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) @@ -510,8 +552,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: @@ -523,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")) || + 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) - ] + ])) { + 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 @@ -568,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, @@ -602,38 +658,45 @@ 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 ", sQuote(attribute), + "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 ", 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: ", 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 ", sQuote(attribute), " are incorrect." + # "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 ", sQuote(attribute), " are incorrect." + "Nodes labels for the attribute ", dQuote(attribute), " are incorrect." ) + } return(TRUE) } @@ -646,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( @@ -657,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"), @@ -687,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 ) ) } @@ -704,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")) || @@ -717,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 @@ -738,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.", @@ -753,6 +830,7 @@ checkEvents.network.goldfish <- function( paste(class(eventUpdate), collapse = ", "), "\n\tmode network: ", paste(mode(object), collapse = ", ") ) + } return(TRUE) } @@ -764,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)) { @@ -786,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 @@ -797,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 + ) + } } } } @@ -827,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 ae13cf1..2dc5740 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,8 +40,10 @@ #' 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"))) +#' updateStates <- as.data.frame( +#' states, +#' time = as.numeric(as.POSIXct("1965-12-31")) +#' ) #' #' #' updateNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1965-12-31"))) @@ -51,8 +55,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") @@ -63,8 +69,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)) { @@ -331,7 +337,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 +349,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 +429,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 +468,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 +489,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 +578,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 +627,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 +656,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 +690,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 +703,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) } @@ -788,21 +835,33 @@ 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.") + 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.") + } # 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 @@ -810,24 +869,32 @@ 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.") - 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) } @@ -837,19 +904,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)) 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).") - 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 @@ -857,28 +943,42 @@ 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.") - 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) } #' @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 "nodes.goldfish" or a "network.goldfish" object.') +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." + ) + } +} diff --git a/R/functions_diagnostics.R b/R/functions_diagnostics.R index 7d4b5e7..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) @@ -120,8 +123,11 @@ 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.")) } @@ -130,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") } @@ -170,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) } @@ -206,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 4b838de..8fa7cbe 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( @@ -10,45 +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 } @@ -56,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 } @@ -148,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)) } @@ -177,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) { @@ -228,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) @@ -265,28 +286,35 @@ 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) } # 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.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 @@ -315,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 + ) } @@ -362,21 +393,22 @@ 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, 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 @@ -406,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 + ) } @@ -453,22 +488,22 @@ 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, 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 @@ -496,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) #' } @@ -509,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 @@ -561,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, @@ -569,7 +607,6 @@ update_DyNAM_choice_recip <- function( weighted = FALSE, isTwoMode = FALSE, transformFun = identity) { - # init res res <- list(changes = NULL) @@ -601,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) @@ -613,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( @@ -624,12 +665,14 @@ 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") + transformFun = transformFun, type = "alter" + ) +} # Closure effects -------------------------------------------------------------- # trans ------------------------------------------------------------------- @@ -658,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) { @@ -670,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 @@ -679,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) @@ -727,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) @@ -768,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( @@ -815,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) { @@ -827,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 @@ -884,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) @@ -975,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, @@ -990,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) { @@ -1005,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 @@ -1059,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) { @@ -1148,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) { @@ -1211,20 +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) -#' 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, - 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) { @@ -1305,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) @@ -1321,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) @@ -1393,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]] @@ -1527,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) @@ -1544,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) @@ -1614,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]] @@ -1747,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 @@ -1761,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) @@ -1830,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]] @@ -1883,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( @@ -1914,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( @@ -1967,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 @@ -1981,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) @@ -2050,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]] @@ -2103,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( @@ -2134,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( @@ -2176,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) { @@ -2266,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, @@ -2292,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, @@ -2373,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)) @@ -2385,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( @@ -2402,7 +2530,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 +2544,8 @@ update_DyNAM_choice_tertius <- function( transformFun = transformFun, aggregateFun = aggregateFun, type = "alter" ) +} + # tertiusDiff ---------------------------------------------------------------- #' init stat matrix tertius-diff using cache #' @@ -2446,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, @@ -2468,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) @@ -2536,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, @@ -2546,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, @@ -2600,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) @@ -2628,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 @@ -2648,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( @@ -2657,15 +2798,17 @@ update_DyNAM_choice_tertiusDiff <- function( rbind, lapply( nodesChange, - function(x) + \(x) { cbind( node1 = if (isTwoMode) seq_len(n1) else third(n1, x), node2 = x, replace = forceAndCall( 1, transformFun, - (if (isTwoMode) attribute else attribute[-x]) - cache[x]) + (if (isTwoMode) attribute else attribute[-x]) - cache[x] + ) ) + } ) ) ) @@ -2677,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) @@ -2689,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)) @@ -2746,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)) @@ -2806,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 @@ -2856,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 @@ -2887,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]] @@ -2908,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 13d12d0..366f3d2 100644 --- a/R/functions_effects_DyNAM_choice_coordination.R +++ b/R/functions_effects_DyNAM_choice_coordination.R @@ -1,47 +1,49 @@ # 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 --------------------------------------------------------------------- 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, weighted = weighted, transformFun = transformFun ) - +} # 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, weighted = weighted, transformFun = transformFun ) - +} # 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, n1 = n1, n2 = n2, isTwoMode = isTwoMode, weighted = weighted, transformFun = transformFun ) +} # outdeg ------------------------------------------------------------------- # update_DyNAM_choice_coordination_outdeg <- function( @@ -59,41 +61,42 @@ 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, isTwoMode = isTwoMode, transformFun = transformFun ) - +} # 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, netUpdate = netUpdate, cache = cache, isTwoMode = isTwoMode, transformFun = transformFun ) +} # 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, @@ -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 @@ -171,8 +176,9 @@ update_DyNAM_choice_tertius( #' 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, @@ -181,84 +187,88 @@ update_DyNAM_choice_tertius( #' 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, n1 = n1, n2 = n2, isTwoMode = isTwoMode ) - +} # 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, isTwoMode = isTwoMode ) - +} # 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, @@ -266,15 +276,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) + attribute, node, replace, + n1, n2, + isTwoMode = FALSE, + transformFun = abs) { update_DyNAM_choice_sim( attribute = attribute, node = node, replace = replace, @@ -282,6 +291,7 @@ update_DyNAM_choice_coordination_sim <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} # ego alter interaction --------------------------------------------------- update_DyNAM_choice_coordination_egoAlterInt <- function( @@ -289,7 +299,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 +308,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..3eed22e 100644 --- a/R/functions_effects_DyNAM_rate.R +++ b/R/functions_effects_DyNAM_rate.R @@ -1,32 +1,37 @@ # 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 #' -#' @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 @@ -41,8 +46,10 @@ init_DyNAM_rate.default <- function(effectFun, #' ), #' 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( #' c( @@ -54,19 +61,26 @@ init_DyNAM_rate.default <- function(effectFun, #' ), #' 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) #' } 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 @@ -100,83 +114,98 @@ 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) { 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 + ) } -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) { 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(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) + 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 +219,26 @@ 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_REM_choice.ego(effectFun = effectFun, attribute = attribute, - n1 = n1, n2 = 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..7df5b4b 100644 --- a/R/functions_effects_DyNAMi_choice.R +++ b/R/functions_effects_DyNAMi_choice.R @@ -1,30 +1,33 @@ # 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 ----------------------------------------------------------------- -#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 - 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. @@ -34,13 +37,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 @@ -49,7 +57,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) } @@ -98,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 { @@ -144,17 +157,16 @@ 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 for (i in seq.int(n1)) { for (j in seq.int(n2)) { - members <- which(groupsNetwork[, j] == 1) nmembers <- length(members) @@ -168,8 +180,9 @@ update_DyNAMi_choice_tie <- function(network, 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 } @@ -205,17 +218,16 @@ 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 for (i in seq.int(n1)) { for (j in seq.int(n2)) { - members <- which(groupsNetwork[, j] == 1) nmembers <- length(members) @@ -270,12 +282,12 @@ 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)) sddeg <- sd(rowSums(network)) @@ -308,7 +320,11 @@ 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, ]) @@ -324,7 +340,11 @@ 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, ])) @@ -337,9 +357,7 @@ update_DyNAMi_choice_alterdeg <- function(network, if (statistics[i, j] != rep) { reptotal <- rbind(reptotal, cbind(node1 = i, node2 = j, replace = rep)) } - } - } return(reptotal) @@ -349,28 +367,31 @@ 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 for (i in seq.int(n1)) { @@ -407,12 +428,12 @@ 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 for (i in seq.int(n1)) { @@ -449,13 +470,13 @@ 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) sdatt <- sd(attribute) @@ -493,7 +514,11 @@ 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]) @@ -535,12 +560,13 @@ 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)) { @@ -585,12 +611,13 @@ 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)) { @@ -648,12 +675,13 @@ 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)) { @@ -703,12 +731,13 @@ 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)) { @@ -732,7 +761,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]) @@ -754,15 +784,16 @@ 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)) { @@ -816,12 +847,13 @@ 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) @@ -856,7 +888,11 @@ 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) { @@ -870,12 +906,13 @@ 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 74c4585..7d83c6b 100644 --- a/R/functions_effects_DyNAMi_rate.R +++ b/R/functions_effects_DyNAMi_rate.R @@ -1,48 +1,59 @@ # 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, - 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 # JOINING RATE if (joining == 1) { - 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) + ) } } } @@ -50,20 +61,27 @@ update_DyNAMi_rate_intercept <- function(network, # LEAVING RATE if (joining == -1) { - 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) + ) } } } @@ -76,32 +94,33 @@ 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 # LEAVING MODEL @@ -109,11 +128,16 @@ 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 } @@ -143,7 +167,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) + ) } } } @@ -151,17 +178,16 @@ 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)) sddeg <- sd(rowSums(network)) @@ -171,9 +197,11 @@ update_DyNAMi_rate_egodeg <- function(network, reptotal <- NULL for (i in seq.int(n1)) { - owngroup <- which(groupsNetwork[i,] == 1) + 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") { @@ -183,16 +211,26 @@ 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) + ) } } } @@ -205,7 +243,9 @@ 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") { @@ -215,16 +255,26 @@ 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) + ) } } } @@ -237,30 +287,33 @@ 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)) maxdeg <- max(rowSums(network)) @@ -268,17 +321,21 @@ update_DyNAMi_rate_alterdeg <- function(network, # LEAVING MODEL if (joining == -1) { - reptotal <- NULL 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 } @@ -296,7 +353,11 @@ 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, ]) @@ -312,7 +373,11 @@ 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 @@ -323,10 +388,12 @@ 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) + ) } } - } return(reptotal) @@ -335,45 +402,52 @@ 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 # LEAVING MODEL if (joining == -1) { - reptotal <- NULL 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 } @@ -392,10 +466,12 @@ 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) + ) } } - } return(reptotal) @@ -405,28 +481,32 @@ 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 # LEAVING MODEL if (joining == -1) { - reptotal <- NULL 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 } @@ -443,10 +523,12 @@ 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) + ) } } - } return(reptotal) @@ -459,14 +541,14 @@ 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) sdatt <- sd(attribute) @@ -478,7 +560,9 @@ 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") { @@ -491,20 +575,29 @@ 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) + ) } } } - } # LEAVING RATE @@ -514,7 +607,9 @@ 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") { @@ -527,20 +622,29 @@ 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) + ) } } } - } return(reptotal) @@ -549,31 +653,35 @@ 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) 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) 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 } @@ -596,7 +704,11 @@ 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]) @@ -627,41 +739,47 @@ 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) + ) } } - } return(reptotal) - } # 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 if (joining == -1) { - reptotal <- NULL 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 } @@ -682,10 +800,12 @@ 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) + ) } } - } return(reptotal) @@ -694,28 +814,33 @@ 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 if (joining == -1) { - reptotal <- NULL 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 } @@ -748,10 +873,12 @@ 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) + ) } } - } return(reptotal) @@ -761,28 +888,33 @@ 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 if (joining == -1) { - reptotal <- NULL 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 } @@ -806,10 +938,12 @@ 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) + ) } } - } return(reptotal) @@ -821,28 +955,33 @@ 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 if (joining == -1) { - reptotal <- NULL 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 } @@ -853,7 +992,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]) @@ -866,10 +1006,12 @@ 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) + ) } } - } return(reptotal) @@ -879,28 +1021,33 @@ 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 if (joining == -1) { - reptotal <- NULL 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 } @@ -930,10 +1077,12 @@ 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) + ) } } - } return(reptotal) @@ -942,14 +1091,14 @@ 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) sdatt <- sd(attribute) @@ -961,7 +1110,9 @@ 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) @@ -979,16 +1130,26 @@ 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) + ) } } } @@ -1001,14 +1162,14 @@ 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) sdatt <- sd(attribute) @@ -1020,7 +1181,9 @@ 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) @@ -1044,16 +1207,26 @@ 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 2cfd1dd..e7cf025 100644 --- a/R/functions_effects_REM.R +++ b/R/functions_effects_REM.R @@ -1,8 +1,9 @@ # 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( @@ -14,55 +15,64 @@ 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_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.tie(effectFun = effectFun, network = network, - window = window, n1 = n1, n2 = 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) + 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 +80,7 @@ update_REM_choice_recip <- function( weighted = weighted, transformFun = transformFun ) +} # indeg ------------------------------------------------------------------- #' init stat matrix indegree using cache @@ -98,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( @@ -112,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) { @@ -133,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) @@ -197,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, @@ -238,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, @@ -248,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, @@ -288,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( @@ -302,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) { @@ -325,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)) { @@ -336,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) @@ -387,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, @@ -429,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, @@ -439,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, @@ -452,11 +491,13 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_trans <- function( network, @@ -464,20 +505,23 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_cycle <- function( network, @@ -485,20 +529,23 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_commonReceiver <- function( network, @@ -506,20 +553,23 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_commonSender <- function( network, @@ -527,21 +577,23 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_mixedTrans <- function( network, @@ -549,20 +601,23 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_mixedCycle <- function( network, @@ -570,21 +625,24 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_mixedCommonReceiver <- function( network, @@ -592,21 +650,24 @@ 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) + n1 = n1, n2 = n2 + ) +} update_REM_choice_mixedCommonSender <- function( network, @@ -614,27 +675,30 @@ 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) + 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 +706,8 @@ update_REM_choice_four <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} + # tertius ---------------------------------------------------------------- #' init stat matrix tertius using cache #' @@ -672,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, @@ -688,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 @@ -701,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 @@ -762,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)) { @@ -831,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() @@ -857,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 @@ -877,12 +955,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 +970,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 +993,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 +1011,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) ) + } ) ) ) @@ -973,17 +1055,20 @@ 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, - window, n1, n2) + window, n1, n2) { init_DyNAM_choice.tertiusDiff( effectFun = effectFun, network = network, attribute = attribute, window = window, - n1 = n1, n2 = n2) + n1 = n1, n2 = n2 + ) +} #' update stat transitivity using cache #' @@ -1026,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, @@ -1036,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, @@ -1062,20 +1149,24 @@ update_REM_choice_tertiusDiff <- function( isTwoMode = isTwoMode, n1 = n1, n2 = n2, transformFun = transformFun, - aggregateFun = aggregateFun) - + aggregateFun = aggregateFun + ) +} # nodeTrans ------------------------------------------------------------------ #' node trans init -#' number of transitive triangles i->j->k;i->k where node i is embedded. Source node -#' @param effectFun function with additional parameters isTwoMode, transformFun, type +#' 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 @@ -1092,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) { @@ -1120,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 @@ -1135,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 @@ -1234,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 } @@ -1250,7 +1351,7 @@ update_REM_choice_nodeTrans <- function( rbind, lapply( seq_along(commonSenders), - function(x) + \(x) { if (type == "ego") { cbind( node1 = commonSenders[x], @@ -1264,6 +1365,7 @@ update_REM_choice_nodeTrans <- function( replace = replaceValues[x] ) } + } ) ) ) @@ -1321,45 +1423,51 @@ 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) + 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, 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 +1475,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 +1494,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 +1515,4 @@ update_REM_choice_egoAlterInt <- function( isTwoMode = isTwoMode, transformFun = transformFun ) +} diff --git a/R/functions_estimation.R b/R/functions_estimation.R index f449e35..49be059 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 @@ -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 @@ -201,24 +203,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,30 +265,33 @@ #' } #' 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, + envir = new.env(), + progress = getOption("progress"), + verbose = getOption("verbose") +) { UseMethod("estimate", x) - +} # First estimation from a formula: can return either a preprocessed object or a # result object #' @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, + envir = new.env(), + progress = getOption("progress"), + verbose = getOption("verbose")) { # Steps: # 1. Parse the formula # 2. Initialize additional objects @@ -295,7 +306,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"), @@ -338,43 +350,45 @@ 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)) { - if (estimationInit["returnEventProbabilities"] == TRUE && - engine != "default") { + "returnEventProbabilities" %in% names(estimationInit)) { + if (isTRUE(estimationInit["returnEventProbabilities"]) && + 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" } } ### 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 @@ -386,29 +400,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) - hasIntercept <- FALSE + " ignores the time intercept.", + call. = FALSE, immediate. = TRUE + ) + parsedformula$hasIntercept <- 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.") @@ -429,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) { @@ -444,8 +462,10 @@ 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) @@ -453,12 +473,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 = envir + )[[1]] + # moved cleanInteractionEvents in getEventsAndObjectsLink eventsObjectsLink <- getEventsAndObjectsLink( - depName, rhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[2]] + depName, rhsNames, .nodes, .nodes2, + envir = envir + )[[2]] eventsEffectsLink <- getEventsEffectsLink( - events, rhsNames, eventsObjectsLink) + events, rhsNames, eventsObjectsLink + ) } # DyNAM-i ONLY: extra cleaning step @@ -467,7 +492,9 @@ estimate.formula <- function( if (model == "DyNAMi") { events <- cleanInteractionEvents( events, eventsEffectsLink, windowParameters, subModel, depName, - eventsObjectsLink, envir = PreprocessEnvir) + eventsObjectsLink, + envir = envir + ) } ### 3. PREPROCESS statistics---- @@ -475,7 +502,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 +513,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 = envir + ) # Get links between objects and effects for printing results newobjectsEffectsLink <- getObjectsEffectsLink(newrhsNames) @@ -505,11 +534,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 = envir + )[[1]] neweventsObjectsLink <- getEventsAndObjectsLink( - depName, newrhsNames, .nodes, .nodes2, envir = PreprocessEnvir)[[2]] + depName, newrhsNames, .nodes, .nodes2, + envir = envir + )[[2]] neweventsEffectsLink <- getEventsEffectsLink( - newevents, newrhsNames, neweventsObjectsLink) + newevents, newrhsNames, neweventsObjectsLink + ) # Preprocess the new effects if (progress) cat("Pre-processing additional effects.\n") @@ -531,28 +565,29 @@ 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 # 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 @@ -560,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) ) ) @@ -582,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) @@ -608,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) @@ -639,12 +674,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 +699,8 @@ estimate.formula <- function( rightCensored = rightCensored, progress = progress, groupsNetwork = parsedformula$defaultNetworkName, - prepEnvir = PreprocessEnvir) + prepEnvir = envir + ) } else { prep <- preprocess( model = model, @@ -684,17 +720,17 @@ 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 # 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 +742,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))) @@ -721,7 +759,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") { @@ -732,17 +770,20 @@ 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 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, @@ -758,7 +799,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))] ) @@ -769,28 +810,39 @@ 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("For ", model, " ", subModel, + " estimation:\n\t", e$message, + 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("For ", model, " ", subModel, + " estimation:\n\t", e$message, + call. = FALSE + ) + } ) } ### 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 2b88645..bf71915 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,24 +133,25 @@ 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 + ] + 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 - 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 } @@ -163,12 +169,14 @@ 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 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 +292,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 +312,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 +372,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 +444,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 +468,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 +487,15 @@ 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) score <- firstDerivatives[activeDyad[2], ] informationMatrix <- getMultinomialInformationMatrixM( - eventProbabilities, firstDerivatives) + eventProbabilities, firstDerivatives + ) pMatrix <- eventProbabilities } @@ -474,12 +503,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 +534,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 +578,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 @@ -569,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, @@ -667,9 +704,10 @@ getInformationMatrixREM <- function(eventProbabilities, firstDerivatives) { values <- colSums(apply( indexes, 1, - function(ind) + \(ind) { firstDerivatives[, , ind[1]] * firstDerivatives[, , ind[2]] * - eventProbabilities + eventProbabilities + } )) information <- matrix(values, nParams, nParams) # symmetrize @@ -707,9 +745,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] @@ -719,10 +755,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)) { @@ -757,12 +795,18 @@ 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) # 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) } @@ -785,12 +829,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]] @@ -827,10 +872,11 @@ 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]) } + } statsArrayComp <- statsArray # Handle the ignoreRep option @@ -845,17 +891,16 @@ 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 } # 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 @@ -866,44 +911,69 @@ 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 + # 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)) - if (length(position) == 0) + position <- which(activeDyad[1] == which(keepIn)) + if (length(position) == 0) { stop("Active node ", activeDyad[1], " not present in event ", i, - call. = FALSE) + call. = FALSE + ) + } + posSender <- activeDyad[1] activeDyad[1] <- position } + } else { + posSender <- activeDyad[1] } - if (updatepresence2 || updateopportunities) { - subset <- presence2 & opportunities - statsArrayComp <- statsArrayComp[, subset, , drop = TRUE] + 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)) { + if (!isTwoMode) keepIn[posSender] <- FALSE + allowReflexiveCorrected <- TRUE + } else { + allowReflexiveCorrected <- FALSE + } + statsArrayComp <- statsArrayComp[, keepIn, , drop = FALSE] if (isDependent) { - position <- which(activeDyad[2] == which(subset)) - if (length(position) == 0) + position <- which(activeDyad[2] == which(keepIn)) + if (length(position) == 0) { stop("Active node ", activeDyad[2], " not available in event ", i, - call. = FALSE) + call. = FALSE + ) + } activeDyad[2] <- position } + } else { + allowReflexiveCorrected <- allowReflexive } # TEMPORARY: handle the reductions here for now @@ -912,17 +982,19 @@ 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, 3, \(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(stat, na.rm = TRUE) / (dim(stat)[2] - 1) + } else { + rowMeans(stat, na.rm = TRUE) + } } ) statsArrayComp <- arr # statsArrayComp: n_nodes*n_effects matrix @@ -948,7 +1020,7 @@ getIterationStepState <- function( modelType = modelType, isRightCensored = isRightCensored, timespan = timespan, - allowReflexive = allowReflexive, + allowReflexive = allowReflexiveCorrected, isTwoMode = isTwoMode ) @@ -1029,9 +1101,10 @@ getMultinomialInformationMatrix <- function(likelihoods, derivatives) { values <- apply( indexes, 1, - function(ind) + \(ind) { sum(derivatives[, , ind[1]] * derivatives[, , ind[2]] * - likelihoodsTriangle) + likelihoodsTriangle) + } ) informationMatrix <- matrix(values, nParams, nParams, byrow = FALSE) @@ -1050,9 +1123,10 @@ getMultinomialInformationMatrixM <- function( temp <- apply( indexes, 1, - function(ind) + \(ind) { firstDerivatives[, ind[1]] * firstDerivatives[, ind[2]] * - eventProbabilities + eventProbabilities + } ) if (!is.null(dim(temp))) { values <- colSums(temp) @@ -1074,16 +1148,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] @@ -1122,18 +1196,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] } @@ -1201,7 +1275,7 @@ reduceStatisticsList <- function( if (statsList$orderEvents[[i]] > 1) { newintervals[[length(newintervals)]] <- newintervals[[length(newintervals)]] + - statsList$rightCensoredIntervals[[irc]] + statsList$rightCensoredIntervals[[irc]] irc <- irc + 1 } } @@ -1213,7 +1287,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) { @@ -1253,7 +1328,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..fe01a40 100644 --- a/R/functions_estimation_engine_c.r +++ b/R/functions_estimation_engine_c.r @@ -7,47 +7,46 @@ # 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) nParams <- dim(statsList$initialStats)[3] - length(excludeParameters) + hasIntercept # + parameters <- initialParameters if (is.null(initialParameters)) parameters <- numeric(nParams) # deal with fixedParameters @@ -55,7 +54,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 +62,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 +76,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 +93,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 @@ -140,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 @@ -152,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 @@ -178,9 +181,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 +265,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 +393,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 +417,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 +430,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 +465,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 +522,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,19 +546,13 @@ 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 } - - -########################################################################################### ### -# different implementation for different modelTypeCall - - - ## ESTIMATE FOR DIFFERENT MODELS estimate_ <- function( modelTypeCall, @@ -570,8 +574,7 @@ estimate_ <- function( n_actors1, n_actors2, twomode_or_reflexive, - impute -) { + impute) { if (modelTypeCall == "DyNAM-MM") { res <- estimate_DyNAM_MM( parameters, @@ -725,9 +728,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. @@ -812,17 +813,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, @@ -831,8 +832,9 @@ compute_ <- function( timespan, is_dependent ) + } - if (modelTypeCall == "DyNAM-MM") + if (modelTypeCall == "DyNAM-MM") { res <- compute_coordination_selection( parameters, stat_all_events, @@ -844,6 +846,7 @@ compute_ <- function( selected_actor2, twomode_or_reflexive ) + } return(res) } diff --git a/R/functions_gather.R b/R/functions_gather.R index 2aae50e..41ea974 100644 --- a/R/functions_gather.R +++ b/R/functions_gather.R @@ -1,25 +1,94 @@ -# # 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 #' -#' 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()]. #' -#' @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 preprocessArgs Additional preprocess arguments like `startTime`, -#' `endTime` and `opportunitiesList`. -#' @param progress Default `FALSE`. +#' 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. #' -#' @return a list with the data and relevant information. -#' @noRd +#' @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{ +#' \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 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 #' data("Fisheries_Treaties_6070") @@ -42,16 +111,30 @@ #' gatheredData <- GatherPreprocessing( #' 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")) { - - model <- match.arg(model) + formula, + model = c("DyNAM", "REM"), + subModel = c("choice", "choice_coordination", "rate"), + preprocessArgs = NULL, + 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% c( @@ -68,31 +151,47 @@ 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" + ) + } } + if (is.null(progress)) progress <- FALSE + ### 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 windowParameters <- parsedformula$windowParameters + ignoreRepParameter <- unlist(parsedformula$ignoreRepParameter) # # 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 == "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) { + 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 @@ -107,7 +206,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) { @@ -121,10 +220,10 @@ 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) + parsedformula$rhsNames, model, subModel, + envir = envir + ) # Get links between objects and effects for printing results objectsEffectsLink <- getObjectsEffectsLink(parsedformula$rhsNames) @@ -133,13 +232,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( @@ -148,6 +252,7 @@ GatherPreprocessing <- function( events = events, effects = effects, windowParameters = parsedformula$windowParameters, + ignoreRepParameter = ignoreRepParameter, eventsObjectsLink = eventsObjectsLink, # for data update eventsEffectsLink = eventsEffectsLink, objectsEffectsLink = objectsEffectsLink, # for parameterization @@ -158,18 +263,17 @@ GatherPreprocessing <- function( startTime = preprocessArgs[["startTime"]], endTime = preprocessArgs[["endTime"]], rightCensored = rightCensored, - progress = progress + progress = progress, + prepEnvir = envir ) # # 3.3 additional processing to flat array objects allowReflexive <- isTwoMode - dimensions <- dim(preprocessingStat$initialStats) - - nParams <- dimensions[3] + parsedformula$hasIntercept reduceMatrixToVector <- FALSE reduceArrayToMatrix <- FALSE - modelTypeCall <- "NON-VALID" + + if (!is.null(altModel) && subModel == "choice") model <- "DyNAM" if (model == "REM") { if (!parsedformula$hasIntercept) { @@ -192,8 +296,6 @@ GatherPreprocessing <- function( } } - if (modelTypeCall == "NON-VALID") stop("Invalid model", modelTypeCall) - # from estimate_c_init preprocessingStat <- modifyStatisticsList( preprocessingStat, modelTypeCall, @@ -203,16 +305,17 @@ GatherPreprocessing <- function( addInterceptEffect = parsedformula$hasIntercept ) - nEvents <- length(preprocessingStat$orderEvents) # number of events - nodes <- get(.nodes) - nodes2 <- get(.nodes2) + # nEvents <- length(preprocessingStat$orderEvents)# number of events + nodes <- get(.nodes, envir = envir) + nodes2 <- get(.nodes2, envir = envir) ## 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) @@ -249,8 +352,8 @@ GatherPreprocessing <- function( hasCompChange2 <- !is.null(compChangeName2) && length(compChangeName2) > 0 if (hasCompChange1) { - temp <- get(compChangeName1) - temp <- sanitizeEvents(temp, nodes) + temp <- get(compChangeName1, envir = envir) + temp <- sanitizeEvents(temp, nodes, envir = envir) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence1_update <- temp$presenceUpdate presence1_update_pointer <- temp$presenceUpdatePointer @@ -260,8 +363,8 @@ GatherPreprocessing <- function( } if (hasCompChange2) { - temp <- get(compChangeName2) - temp <- sanitizeEvents(temp, nodes2) + temp <- get(compChangeName2, envir = envir) + temp <- sanitizeEvents(temp, nodes2, envir = envir) temp <- C_convert_composition_change(temp, preprocessingStat$eventTime) presence2_update <- temp$presenceUpdate presence2_update_pointer <- temp$presenceUpdatePointer @@ -284,11 +387,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 } @@ -330,6 +435,21 @@ 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] + } else if (model == "DyNAM" && subModel == "rate" && + parsedformula$hasIntercept) { + gatheredData$timespan <- timespan + gatheredData$isDependent <- is_dependent + } + gatheredData$hasIntercept <- parsedformula$hasIntercept + + gatheredData$selected <- gatheredData$selected + + if (parsedformula$hasIntercept) (1 * is_dependent) else 1 + ### 4. PREPARE PRINTING---- # functions_utility.R effectDescription <- @@ -340,6 +460,7 @@ GatherPreprocessing <- function( gatheredData$namesEffects <- namesEffects colnames(gatheredData$stat_all_events) <- namesEffects + gatheredData$effectDescription <- effectDescription return(gatheredData) } @@ -357,21 +478,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 +506,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 1b8ec0d..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"), @@ -134,7 +133,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 @@ -153,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)) @@ -168,7 +166,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 } } @@ -182,13 +181,13 @@ 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 # 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 +207,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 +240,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 +250,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 +293,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 +314,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]) @@ -322,11 +331,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 +371,44 @@ defineGroups_interaction <- function(records, actors, seed.randomization, toberemovedgroups <- toberemovedgroups[toberemovedgroups != keptg] if (newkeptg) { - for (g2 in seq.int(numpreviousgroups)) { - - # we check whether there are some other actors in the previous group + for (g2 in seq_len(numpreviousgroups)) { + # 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 +419,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 +493,27 @@ 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")) } } } @@ -470,20 +525,27 @@ 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 + # 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))) { - # 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 @@ -600,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) @@ -672,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) @@ -817,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 @@ -879,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, @@ -908,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 @@ -971,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 cdfb05a..df890e2 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,20 +142,20 @@ 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) { - 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( @@ -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") @@ -239,16 +251,19 @@ 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 = " "), - "\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 @@ -309,8 +327,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 +340,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 ) @@ -353,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) } @@ -361,15 +393,14 @@ 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 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") @@ -383,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 + 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, ] } @@ -426,7 +460,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_parsing.R b/R/functions_parsing.R index 522ed96..19022fc 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 @@ -19,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()) { @@ -33,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) @@ -70,9 +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 ", 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) { @@ -82,16 +90,17 @@ 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) { 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") @@ -127,43 +136,59 @@ 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.") + 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.") + 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." + ) } # 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("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 +210,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 +230,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()) { @@ -216,26 +244,32 @@ 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 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 +277,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,37 +293,50 @@ 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) { + 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("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 @@ -303,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 @@ -347,12 +396,13 @@ 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) @@ -369,7 +419,7 @@ getEventsAndObjectsLink <- function(depName, rhsNames, nodes = NULL, nodes2 = NU ) # 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) @@ -397,7 +447,8 @@ getEventsAndObjectsLink <- function(depName, rhsNames, nodes = NULL, nodes2 = NU ) evs <- lapply( evName, - function(x) sanitizeEvents(get(x), nodeSet) + function(x) + sanitizeEvents(get(x, envir = envir), nodeSet, envir = envir) ) events <- append(events, evs) @@ -421,7 +472,7 @@ getEventsAndObjectsLink <- function(depName, rhsNames, nodes = NULL, nodes2 = NU # 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, @@ -443,8 +494,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 @@ -488,7 +541,7 @@ parseIntercept <- function(rhsNames) { tryCatch( v <- as.numeric(rhsNames[[1]][[1]]), warning = function(x) { - } + } ) if (!is.na(v) && v == 1) { intercept <- TRUE @@ -502,7 +555,8 @@ 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)) { @@ -510,26 +564,30 @@ parseMultipleEffects <- function(rhsNames, default = FALSE, envir = environment( 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))) - # 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 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) @@ -547,7 +605,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 @@ -557,7 +615,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) } ) @@ -568,18 +627,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", @@ -604,19 +666,21 @@ 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 - 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" + ) + } } @@ -632,13 +696,14 @@ 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 = "_" ) 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 @@ -650,8 +715,8 @@ 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 + # 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_postestimate.R b/R/functions_postestimate.R index d88b180..e8fe94a 100644 --- a/R/functions_postestimate.R +++ b/R/functions_postestimate.R @@ -1,9 +1,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 @@ -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 b23e420..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 @@ -208,12 +213,13 @@ 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) { if (isValidEvent && nextEventTime <= endTime) { - interval <- nextEventTime - time + interval <- nextEventTime - time } else if (isValidEvent && nextEventTime > endTime) { interval <- endTime - time nextEventTime <- endTime @@ -259,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 @@ -276,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 @@ -326,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")) { @@ -375,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 + ) + } } } } @@ -493,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) @@ -507,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" )) } @@ -542,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( @@ -583,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, @@ -621,7 +644,7 @@ initializeCacheStat <- function( #' network = m, #' n1 = 5, n2 = 5, #' sender = 1, receiver = 5, replace = 0 -#' ) +#' ) #' effects <- list(list(effect = out)) #' #' ver2 <- callFUN( @@ -638,7 +661,7 @@ initializeCacheStat <- function( #' effects = effects, effectPos = effectPos, effectType = "effect", #' .argsFUN = .argsFUN, textMss = " ver ", #' effectLabel = "out" -#' ) +#' ) #' } callFUN <- function( effects, effectPos, effectType, .argsFUN, textMss, @@ -647,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 ", sQuote(effectLabel), - " (", effectPos, ") ", textMss, e$message) + "Effect ", dQuote(effectLabel), + " (", 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) @@ -712,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() #' @@ -723,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))) { @@ -745,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 150a146..6b20c3d 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 @@ -122,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 @@ -136,15 +142,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 +162,25 @@ 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, + 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) if (all(get(dname, envir = prepEnvir) == - get(groupsupdates[1], envir = prepEnvir))) { + get(groupsupdates[1], envir = prepEnvir))) { depn <- groupsupdates[1] exon <- groupsupdates[2] } else { @@ -194,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( @@ -229,8 +248,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,16 +279,9 @@ preprocessInteraction <- function( # iterate over all event lists 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 +295,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 { @@ -305,7 +323,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 @@ -315,7 +333,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) { @@ -336,7 +354,6 @@ preprocessInteraction <- function( # 1. store statistic updates for DEPENDENT events if (isDependent) { - # first store statistics iDependentEvents <- 1 + iDependentEvents dependentStatistics[[iDependentEvents]] <- updatesDependent @@ -424,8 +441,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) @@ -436,11 +453,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]) { @@ -451,8 +470,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 { @@ -463,9 +483,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 @@ -501,8 +521,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) @@ -559,27 +579,28 @@ 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) { 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..02f82c8 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) @@ -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 @@ -248,7 +243,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 +336,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 +370,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 +390,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 +447,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 +492,7 @@ GetDetailPrint <- function( if (!is.null(fixedParameters)) { effectDescription <- cbind(effectDescription, - fixed = !is.na(fixedParameters) + fixed = !is.na(fixedParameters) ) } @@ -502,11 +501,17 @@ 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)) + } +} + +checkArgsEstimation <- function(variables) { + } 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/R/testthat-helpers.R b/R/testthat-helpers.R index 4cf9d35..0f583e4 100644 --- a/R/testthat-helpers.R +++ b/R/testthat-helpers.R @@ -1,10 +1,3 @@ -##################### ## -# -# Goldfish package -# Helper data testing ----------------------------------------------- -# -#################### ### - # DyNAM ------------------------------------------------------------- # Networks --------------------------------------------------------- @@ -23,11 +16,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 +76,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 = 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), @@ -91,38 +87,45 @@ 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 +134,66 @@ 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,30 +201,20 @@ 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 -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), @@ -224,69 +228,179 @@ 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, + 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 -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( 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) - -# 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)), - increment = - c(1, 1, 3, 1, -1, 2, 3), - stringsAsFactors = FALSE + defaultNetwork = networkState ) +# exogenous network 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) + ) +) + +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) + ), + increment = + c(1, 1, 3, 1, -1, 2, 3), + stringsAsFactors = FALSE ) # 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 +) +# 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 -------------------------------------------------------- @@ -313,78 +427,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( @@ -394,9 +518,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, @@ -407,7 +534,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/README.md b/README.md index 1f4f8d5..d90c4cc 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,14 @@ 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..ce84b99 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: @@ -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/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 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/GatherPreprocessing.Rd b/man/GatherPreprocessing.Rd new file mode 100644 index 0000000..bb291b7 --- /dev/null +++ b/man/GatherPreprocessing.Rd @@ -0,0 +1,154 @@ +% 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"), + envir = new.env() +) +} +\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{ +\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{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{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 +objects are available.} +} +\value{ +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{ +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") +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/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/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 1960696..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.} @@ -206,24 +210,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{ @@ -244,7 +254,7 @@ createBilat <- defineDependentEvents( events = bilatchanges[bilatchanges$increment == 1, ], nodes = states, defaultNetwork = bilatnet ) - + partnerModel <- estimate( createBilat ~ inertia(bilatnet) + 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/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 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/man/update-method.Rd b/man/update-method.Rd index 6293c96..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,8 +51,10 @@ states <- linkEvents(states, gdpchanges, attribute = "gdp") 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"))) +updateStates <- as.data.frame( + states, + time = as.numeric(as.POSIXct("1965-12-31")) +) updateNet <- as.matrix(bilatnet, time = as.numeric(as.POSIXct("1965-12-31"))) diff --git a/src/DyNAM_rate_default.cpp b/src/DyNAM_rate_default.cpp index d5bdfd6..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 @@ -201,4 +213,3 @@ inline arma::mat reduce_mat_to_vector( } return reduced_data_mat; } - \ 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 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.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_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_DyNAM_rate.R b/tests/testthat/test-effects_preprocessing_DyNAM_rate.R index 6e6d182..6b7ef14 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( @@ -148,59 +152,65 @@ 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)), 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( @@ -224,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( @@ -261,59 +273,65 @@ 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)), 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( @@ -337,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( diff --git a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R index bf3d462..a2fbcac 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_choice.R @@ -3,11 +3,11 @@ # 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 ~ - 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,7 +24,9 @@ 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 +128,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 +282,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 +291,9 @@ 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 +388,36 @@ 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 +531,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,18 +651,20 @@ 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 ~ - 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)) stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + if (!is.null(change)) { + stat[cbind(change[, "node1"], change[, "node2"])] <- change[, "replace"] + } return(stat) } @@ -745,11 +764,11 @@ 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") - + 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") @@ -760,7 +779,9 @@ 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 +890,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,11 +984,12 @@ 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") - + same(actors_DyNAMi$attr2, subType = "count") + 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") @@ -981,7 +1004,9 @@ 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-effects_preprocessing_DyNAMi_rate.R b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R index 067ff7b..01493f2 100644 --- a/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R +++ b/tests/testthat/test-effects_preprocessing_DyNAMi_rate.R @@ -3,16 +3,19 @@ # 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 +115,54 @@ 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 +352,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 +371,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 +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, 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 +677,54 @@ 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 +1146,48 @@ 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,11 +1505,11 @@ 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 ~ - 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) + @@ -1435,7 +1522,9 @@ 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,11 +1846,11 @@ 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 ~ - 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) + @@ -1772,7 +1861,9 @@ 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,11 +2060,11 @@ 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 ~ - 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", @@ -1981,7 +2072,9 @@ 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,11 +2207,11 @@ 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 ~ - 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), @@ -2127,7 +2220,9 @@ 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..3d807ed 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,45 @@ 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 +66,11 @@ 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..7c3bfd3 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,41 @@ 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_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 44c7521..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( @@ -42,7 +41,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( 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] + ) +}) + diff --git a/tests/testthat/test-functions_estimation_engine_c.R b/tests/testthat/test-functions_estimation_engine_c.R index daf2b21..7758e5f 100644 --- a/tests/testthat/test-functions_estimation_engine_c.R +++ b/tests/testthat/test-functions_estimation_engine_c.R @@ -10,14 +10,23 @@ 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, model = model, subModel = subModel, - estimationInit = list(startTime = 0, engine = "default_c", - returnIntervalLogL = TRUE) + estimationInit = list( + startTime = 0, engine = "default_c", + # fixedParameters = c(offsetInt, 0, 0), + returnIntervalLogL = TRUE + ) ) modCgc <- estimate( formula, diff --git a/tests/testthat/test-functions_gather.R b/tests/testthat/test-functions_gather.R new file mode 100644 index 0000000..2911b7a --- /dev/null +++ b/tests/testthat/test-functions_gather.R @@ -0,0 +1,40 @@ +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, 8) +}) 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) +}) 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/dynami-example.R b/vignettes/dynami-example.R index 3e51ccf..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 3da8884..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 @@ -636,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/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} 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 28d7eab..43d7b07 100644 Binary files a/vignettes/teaching/plot-teaching1-1.png and b/vignettes/teaching/plot-teaching1-1.png differ diff --git a/vignettes/teaching/plot-teaching1-2.png b/vignettes/teaching/plot-teaching1-2.png index 87b8710..c1076aa 100644 Binary files a/vignettes/teaching/plot-teaching1-2.png and b/vignettes/teaching/plot-teaching1-2.png differ diff --git a/vignettes/teaching/plot-teaching1-3.png b/vignettes/teaching/plot-teaching1-3.png index a614a26..c2b6c98 100644 Binary files a/vignettes/teaching/plot-teaching1-3.png and b/vignettes/teaching/plot-teaching1-3.png differ diff --git a/vignettes/teaching/plot-teaching2-1.png b/vignettes/teaching/plot-teaching2-1.png index a181c04..0b71bdc 100644 Binary files a/vignettes/teaching/plot-teaching2-1.png and b/vignettes/teaching/plot-teaching2-1.png differ diff --git a/vignettes/teaching1.R b/vignettes/teaching1.R index bface6f..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,8 @@ callsDependent <- defineDependentEvents( callsDependent -## ----plot-teaching1, message=FALSE, warning=FALSE---------------------------------------------------------------------- +## ----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") + @@ -119,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" @@ -135,7 +140,7 @@ mod01Choice <- estimate( summary(mod01Choice) -## ----complex-choice---------------------------------------------------------------------------------------------------- +## ----complex-choice------------------------------------------------------------------------- complexFormulaChoice <- callsDependent ~ inertia(callNetwork) + recip(callNetwork) + tie(friendshipNetwork) + recip(friendshipNetwork) + @@ -148,7 +153,7 @@ mod02Choice <- estimate( summary(mod02Choice) -## ----simple-rate------------------------------------------------------------------------------------------------------- +## ----simple-rate---------------------------------------------------------------------------- simpleFormulaRate <- callsDependent ~ indeg(friendshipNetwork) mod01Rate <- estimate( simpleFormulaRate, @@ -156,7 +161,7 @@ mod01Rate <- estimate( ) -## ----estimate-init----------------------------------------------------------------------------------------------------- +## ----estimate-init-------------------------------------------------------------------------- mod01Rate <- estimate( simpleFormulaRate, model = "DyNAM", subModel = "rate", @@ -165,7 +170,7 @@ mod01Rate <- estimate( summary(mod01Rate) -## ----complex-rate------------------------------------------------------------------------------------------------------ +## ----complex-rate--------------------------------------------------------------------------- complexFormulaRate <- callsDependent ~ indeg(callNetwork) + outdeg(callNetwork) + indeg(friendshipNetwork) @@ -174,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) @@ -183,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: @@ -204,7 +209,7 @@ mod03RateCoef <- coef(mod03Rate) ) / 3600 -## ----windows-rate------------------------------------------------------------------------------------------------------ +## ----windows-rate--------------------------------------------------------------------------- windowFormulaRate <- callsDependent ~ 1 + indeg(callNetwork) + outdeg(callNetwork) + indeg(callNetwork, window = 300) + @@ -215,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) + @@ -228,7 +233,7 @@ mod03Choice <- estimate(windowFormulaChoice, summary(mod03Choice) -## ----aic--------------------------------------------------------------------------------------------------------------- +## ----aic------------------------------------------------------------------------------------ # Compare different specifications of the subModel = "choice" AIC(mod02Choice, mod03Choice) @@ -236,23 +241,25 @@ AIC(mod02Choice, mod03Choice) AIC(mod03Rate, mod04Rate) -## ----rem--------------------------------------------------------------------------------------------------------------- +## ----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-------------------------------------------------------------------------------------------- +## ----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..1b358d3 100644 --- a/vignettes/teaching1.Rmd +++ b/vignettes/teaching1.Rmd @@ -56,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. @@ -359,6 +359,7 @@ for additional information about network visualization. ```r +library(igraph) library(ggraph) library(migraph) # The network at the beginning @@ -371,8 +372,11 @@ 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") + @@ -385,6 +389,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") + @@ -819,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 @@ -829,15 +835,20 @@ 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 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 @@ -869,42 +880,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.R b/vignettes/teaching2.R index bf588df..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,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..0e69622 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,13 +404,16 @@ 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 +
+plot of chunk plot-teaching2 +

plot of chunk plot-teaching2

+
What can we observe? @@ -459,7 +464,7 @@ system.time( ) ) #> user system elapsed -#> 155.92 5.78 162.42 +#> 194.74 9.31 206.95 ``` Did the model converge? If not, you can restart the estimation process using @@ -551,7 +556,7 @@ system.time( ) ) #> user system elapsed -#> 109.36 0.82 109.22 +#> 125.22 1.61 126.84 ``` # Extensions... @@ -570,6 +575,7 @@ Here is an example on the current results object: ```r library(broom) 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))) @@ -604,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. 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?