Skip to content

Commit

Permalink
Refactor rdiffnet (#46)
Browse files Browse the repository at this point in the history 
* Adding myself to the project

* Some discussion about the dimensions of ans (exposure calculation)

* just fixing a paragraph in Ego exposure

* looking as.vector things

* out object from exposure_for()

* More dimensional analysis. Changes to avoid ambiguous names

* stats.R fixed

* out object (in exposure_for() function) now allows q diff processes

* Working forms of .exposure,  exposure_for, and exposure.list

* updates for .exposure and exposure.list functions

* correcting labels of variables

* Fixing tests of diffnet

* changes to exposure.list() to allow arrays of cumadopt. Add multidiff-test-discussion too.

* aditional test -multidiffusion exposure calculations-

* updating to Steps 1.1 (initial adopters) and  1.2 (finding seed nodes) in rdiffnet function

* updating cumadopt, exposure simulation, and toa for multi-diff processes

* adding a set of tests for rdiffnet_validate_args function

* rdiffnet function updated to allow multi-diff. An small error in rdiffnet_check_seed_graph fixed.

* generalization of rdiffnet_make_threshold function. Some others modification following the merge of the 41... branch

* lot of work in new_diffnet and toa_mat functions. New tests for rdiffnet_make_threshold. Some modification in rdiffnet too. Not expecting to work yet.

* changes in new_diffnet and toa_mat. Now all the original tests for those functions are pass.

* updating rdiffnet_validate_args to allow objects seed.nodes different from -list-. For example: rdiffnet(100,10, seed.p.adopt = list(.1, .05)), or adding seed.nodes=c(1,2,3,4), seed.nodes=random, or seed.nodes=c(random,central). Respective tests added.

* rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function.

* rdiffnet now allow multiple diff, showing the results. There is still work to be done to display a line saying 'number of behaviors', and to fix the summary() function.

* Now rdiffnet allow multiple diff, and shows the name -Behavior-, -Num of behaviors-, and

* some minor changes in summary.diffnet

* advances in summary.diffnet() for multi-diff, but this will be change to something more simple later

* changes in exposure.list and exposure_for to allow personalized attrs in multi-diff

* minor changes in toa_mat

* now new_diffnet sets the num_of behavior internally

* more changes to toa_mat to compute num_of_adoption on  more classes

* now toa_mat can compute adopt and cumadopt from diffnet (multiple) and matrix objects. The same tests for single behavior were adapted.

* all comments were addressed, except -behavior- as a vector.

* checking the status of "dynamic" and "static" graphs.

---------

Co-authored-by: Anibal Olivera Morales <[email protected]>
Co-authored-by: Aníbal Olivera M. <[email protected]>
  • Loading branch information
@gvegayon @aoliveram
3 people authored Nov 22, 2024
1 parent 7bd4c98 commit 78e2a44
Show file tree
Hide file tree
Showing 9 changed files with 883 additions and 290 deletions.
60 changes: 45 additions & 15 deletions R/adjmat.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -464,29 +464,59 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) {
#' @author George G. Vega Yon & Thomas W. Valente
toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) {

if (inherits(obj, "matrix")) {
num_of_behaviors <- dim(obj)[2]
} else if (inherits(obj, "diffnet")){
if (inherits(obj$toa, "matrix")) {
num_of_behaviors <- dim(obj$toa)[2]}
else {num_of_behaviors <- 1}
} else {num_of_behaviors <- 1}

if (!inherits(obj, "diffnet")) {
if (!length(t0)) t0 <- min(obj, na.rm = TRUE)
if (!length(t1)) t1 <- max(obj, na.rm = TRUE)
}

cls <- class(obj)
ans <- if ("numeric" %in% cls) {
toa_mat.numeric(obj, labels, t0, t1)
} else if ("integer" %in% cls) {
toa_mat.integer(obj, labels, t0, t1)
} else if ("diffnet" %in% cls) {
with(obj, list(adopt=adopt,cumadopt=cumadopt))
} else
stopifnot_graph(obj)


if (inherits(obj, "diffnet")) {
dimnames(ans$adopt) <- with(obj$meta, list(ids,pers))
dimnames(ans$cumadopt) <- with(obj$meta, list(ids,pers))
ans <- list()
if (num_of_behaviors == 1) {
cls <- class(obj)
ans[[1]] <- if ("numeric" %in% cls) {
toa_mat.numeric(obj, labels, t0, t1)
} else if ("integer" %in% cls) {
toa_mat.integer(obj, labels, t0, t1)
} else if ("diffnet" %in% cls) {
with(obj, list(adopt=adopt,cumadopt=cumadopt))
} else {
stopifnot_graph(obj)
}
} else {
for (q in 1:num_of_behaviors) {
ans[[q]] <- if ("matrix" %in% class(obj)) {
if ("integer" %in% class(obj[,q])){
toa_mat.integer(obj[,q], labels, t0, t1)
} else if ("numeric" %in% class(obj[,q])) { # Why included?
toa_mat.numeric(obj[,q], labels, t0, t1)
}
} else if ("diffnet" %in% class(obj)) { # Why included?
with(obj, list(adopt=adopt[[q]],cumadopt=cumadopt[[q]]))
} else {
stopifnot_graph(obj[,q])
}
}
}

for (q in 1:num_of_behaviors) {
if (inherits(obj, "diffnet")) {
dimnames(ans[[q]]$adopt) <- with(obj$meta, list(ids,pers))
dimnames(ans[[q]]$cumadopt) <- with(obj$meta, list(ids,pers))
}
}

return(ans)
if (num_of_behaviors==1) {
return(ans[[1]])
} else {
return(ans)
}
}

toa_mat.default <- function(per, t0, t1) {
Expand Down
126 changes: 95 additions & 31 deletions R/diffnet-class.r
View file
Original file line number Diff line number Diff line change
Expand Up @@ -556,49 +556,94 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm
return(graph)
}

# Step 0.1: Setting num_of_behavior ------------------------------------------

if (inherits(toa, "matrix")) {
num_of_behaviors <- dim(toa)[2]
} else {num_of_behaviors <- 1}

# Step 1.1: Check graph ------------------------------------------------------
meta <- classify_graph(graph)
if (meta$type=="static")
warning("-graph- is static and will be recycled (see ?new_diffnet).")


# Step 1.2: Checking that lengths fit
if (length(toa)!=meta$n) stop("-graph- and -toa- have different lengths (",
meta$n, " and ", length(toa), " respectively). ",
"-toa- should be of length n (number of vertices).")

# Step 2.1: Checking class of TOA and coercing if necesary -------------------
if (!inherits(toa, "integer")) {
warning("Coercing -toa- into integer.")
toa <- as.integer(toa)
if (num_of_behaviors == 1) {
if (length(toa)!=meta$n){ stop("-graph- and -toa- have different lengths (", meta$n, " and ", length(toa),
" respectively). ", "-toa- should be of length n (number of vertices).") }
} else {
if (length(toa[,1])!=meta$n) {stop("-graph- and -toa[,1]- have different lengths (", meta$n, " and ", length(toa[,1]),
" respectively). ", "-toa- should be of length n (number of vertices).") }
}

# Step 2.1: Checking class of TOA and coercing if necessary -------------------
if (num_of_behaviors==1) {
if (!inherits(toa, "integer")) {
warning("Coercing -toa- into integer.")
toa <- as.integer(toa)
}
} else {
for (q in 1:num_of_behaviors) {
if (!inherits(toa[,q], "integer")) {
warning("Coercing -toa- into integer.")
toa[,q] <- as.integer(toa[,q])
}
}
}

# Step 2.2: Checking names of toa
if (!length(names(toa)))
names(toa) <- meta$ids
if (num_of_behaviors==1) {
if (!length(names(toa))) {names(toa) <- meta$ids}
} else {
if (!length(rownames(toa))) { # Not necessary? toa_mat(toa, labels = meta$ids, t0=t0, t1=t1) already has labels
rownames(toa) <- meta$ids
}
}

# Step 3.1: Creating Time of adoption matrix ---------------------------------
mat <- toa_mat(toa, labels = meta$ids, t0=t0, t1=t1)

# Step 3.2: Verifying dimensions and fixing meta$pers

if (meta$type != "static") {
tdiff <- meta$nper - ncol(mat[[1]])
if (tdiff < 0)
stop("Range of -toa- is bigger than the number of slices in -graph- (",
ncol(mat[[1]]), " and ", length(graph) ," respectively). ",
"There must be at least as many slices as range of toa.")
else if (tdiff > 0)
stop("Range of -toa- is smaller than the number of slices in -graph- (",
ncol(mat[[1]]), " and ", length(graph) ," respectively). ",
"Please provide lower and upper boundaries for the values in -toa- ",
"using -t0- and -t- (see ?toa_mat).")
if (num_of_behaviors==1) {
if (meta$type != "static") {
tdiff <- meta$nper - ncol(mat$adopt)
if (tdiff < 0)
stop("Range of -toa- is bigger than the number of slices in -graph- (",
ncol(mat$adopt), " and ", length(graph) ," respectively). ",
"There must be at least as many slices as range of toa.")
else if (tdiff > 0)
stop("Range of -toa- is smaller than the number of slices in -graph- (",
ncol(mat$adopt), " and ", length(graph) ," respectively). ",
"Please provide lower and upper boundaries for the values in -toa- ",
"using -t0- and -t- (see ?toa_mat).")
} else {
graph <- lapply(1:ncol(mat$adopt), function(x) methods::as(graph, "dgCMatrix"))
meta <- classify_graph(graph)
}
} else {
graph <- lapply(1:ncol(mat[[1]]), function(x) methods::as(graph, "dgCMatrix"))
meta <- classify_graph(graph)
if (meta$type != "static") {
tdiff <- meta$nper - ncol(mat[[1]]$adopt)
if (tdiff < 0)
stop("Range of -toa- is bigger than the number of slices in -graph- (",
ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ",
"There must be at least as many slices as range of toa.")
else if (tdiff > 0)
stop("Range of -toa- is smaller than the number of slices in -graph- (",
ncol(mat[[1]]$adopt), " and ", length(graph) ," respectively). ",
"Please provide lower and upper boundaries for the values in -toa- ",
"using -t0- and -t- (see ?toa_mat).")
} else {
graph <- lapply(1:ncol(mat[[1]]$adopt), function(x) methods::as(graph, "dgCMatrix"))
meta <- classify_graph(graph)
}
}

meta$pers <- as.integer(colnames(mat$adopt))
# labels of the time periods
if (num_of_behaviors==1) {
meta$pers <- as.integer(colnames(mat$adopt))
} else {meta$pers <- as.integer(colnames(mat[[1]]$adopt))} # same for all behaviors

# Step 4.0: Checking the attributes ------------------------------------------

Expand Down Expand Up @@ -629,21 +674,40 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm
meta$multiple <- multiple
meta$name <- ifelse(!length(name), "", ifelse(is.na(name), "",
as.character(name)))
meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "",
as.character(behavior)))
meta$version <- utils::packageVersion("netdiffuseR")

# Removing dimnames
graph <- Map(function(x) Matrix::unname(x), x=graph)
dimnames(toa) <- NULL
dimnames(mat$adopt) <- NULL
dimnames(mat$cumadopt) <- NULL
#dimnames(toa) <- NULL

if (num_of_behaviors==1) {
meta$behavior <- ifelse(!length(behavior), "", ifelse(is.na(behavior), "",
as.character(behavior)))
dimnames(mat$adopt) <- NULL
dimnames(mat$cumadopt) <- NULL

adopt <- mat$adopt
cumadopt <- mat$cumadopt
} else {
meta$behavior <- paste(unlist(behavior), collapse = ", ")

for (q in 1:num_of_behaviors) {
dimnames(mat[[q]]$adopt) <- NULL
dimnames(mat[[q]]$cumadopt) <- NULL
}
adopt <- list()
cumadopt <- list()
for (q in 1:num_of_behaviors) {
adopt[[q]] <- mat[[q]]$adopt
cumadopt[[q]] <- mat[[q]]$cumadopt
}
}

return(structure(list(
graph = graph,
toa = toa,
adopt = mat$adopt,
cumadopt = mat$cumadopt,
adopt = adopt,
cumadopt = cumadopt,
# Attributes
vertex.static.attrs = vertex.static.attrs,
vertex.dyn.attrs = vertex.dyn.attrs,
Expand Down
Loading

0 comments on commit 78e2a44

Please sign in to comment.