Refactor rdiffnet

R/adjmat.r

@@ -462,31 +462,52 @@ adjmat_to_edgelist.list <- function(graph, undirected, keep.isolates) {
 #' @keywords manip
 #' @include graph_data.r
 #' @author George G. Vega Yon & Thomas W. Valente
-toa_mat <- function(obj, labels=NULL, t0=NULL, t1=NULL) {
+toa_mat <- function(obj, num_of_behaviors=1, labels=NULL, t0=NULL, t1=NULL) {
 
   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) {
+      cls <- class(obj[,q])
+      ans[[q]] <- if ("numeric" %in% cls) { # Why included?
+              toa_mat.numeric(obj[,q], labels, t0, t1)
+            } else if ("integer" %in% cls) {
+              toa_mat.integer(obj[,q], labels, t0, t1)
+            } else if  ("diffnet" %in% cls) { # Why included?
+              with(obj[,q], list(adopt=adopt,cumadopt=cumadopt))
+            } 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) {

R/diffnet-class.r

@@ -547,7 +547,8 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm
                        self       = getOption("diffnet.self"),
                        multiple   = getOption("diffnet.multiple"),
                        name       = "Diffusion Network",
-                       behavior   = "Unspecified"
+                       behavior   = "Unspecified",
+                       num_of_behaviors = 1
                        ) {
 
   # Step 0.0: Check if its diffnet! --------------------------------------------
@@ -563,42 +564,84 @@ new_diffnet <- function(graph, toa, t0=min(toa, na.rm = TRUE), t1=max(toa, na.rm
 
 
   # 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).")
+  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 necesary -------------------
-  if (!inherits(toa, "integer")) {
-    warning("Coercing -toa- into integer.")
-    toa <- as.integer(toa)
+  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)
+  mat <- toa_mat(toa, num_of_behaviors, 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 {
+
+      # This should be reviewed !! (here the graph becomes 'dynamic')
+
+      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 ------------------------------------------
 
@@ -629,21 +672,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
+
+  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,