advances in summary.diffnet() for multi-diff, but this will be change…

… to something more simple later

R/diffnet-methods.r

@@ -218,7 +218,6 @@ summary.diffnet <- function(
 
   # Computing moran's I
   if (single) {
-
     if (!skip.moran) {
       m <- matrix(NA, nrow=length(slices), ncol=4,
                   dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval")))
@@ -257,10 +256,49 @@ summary.diffnet <- function(
     }
 
   } else {
+    if (!skip.moran) {
+      out_list <- list()
+      data_beh_list <- list()
+      for (q in 1:length(object$cumadopt)) {
+        m <- matrix(NA, nrow=length(slices), ncol=4,
+                    dimnames = list(NULL, c("moran_obs", "moran_exp", "moran_sd", "moran_pval")))
+
+        for (i in 1:length(slices)) {
+
+          g <- approx_geodesic(object$graph[[slices[i]]], ...)
+          g@x <- 1/g@x
+
+          m[i,] <- unlist(moran(object$cumadopt[[q]][,slices[i]], g))
+        }
 
-    message("Multiple in summary.diffnet -borrar-")
+        # Computing new adopters, cumadopt and hazard rate
+        ad <- colSums(object$adopt[[q]][,slices,drop=FALSE])
+        ca <- t(cumulative_adopt_count(object$cumadopt[[q]]))[slices,-3, drop=FALSE]
+        hr <- t(hazard_rate(object$cumadopt[[q]], no.plot = TRUE))[slices,,drop=FALSE]
 
+        # Left censoring
+        lc <- sum(object$toa[,q] == meta$pers[1], na.rm = TRUE)
+        rc <- sum(is.na(object$toa[,q]), na.rm=TRUE)
 
+        #data_beh_list[[q]] <- list(ad, ca, hr, lc, rc)
+
+        out <- data.frame(
+          adopt = ad,
+          cum_adopt = ca[,1],
+          cum_adopt_pcent = ca[,2],
+          hazard = hr,
+          density=d
+        )
+
+        if (!skip.moran) {
+          out <- cbind(out, m)
+        }
+
+        if (no.print) return(out)
+
+        out_list[[q]] <- out
+      }
+    }
   }
 
   # Function to print data.frames differently
@@ -283,31 +321,14 @@ summary.diffnet <- function(
       rule,"\n",sep="")
   cat(header,"\n")
   cat(hline, "\n")
-  for (i in 1:nrow(out)) {
-    cat(sprintf(
-      paste0("%",slen,"s", collapse=" "),
-      qf(meta$pers[slices[i]],0), qf(out[i,1],0),
-      sprintf("%s (%s)",
-        qf(out$cum_adopt[i],0),
-        qf(out$cum_adopt_pcent[i])
-        ),
-      ifelse(i==1, "-",qf(out$hazard[i])), qf(out$density[i]),
-      if (!skip.moran) {
-        if (is.nan(out$moran_sd[i]))
-          " - "
-        else
-          sprintf("%s (%s) %-3s",
-                  qf(out$moran_obs[i]),
-                  qf(out$moran_sd[i]),
-                  ifelse(out$moran_pval[i] <= .01, "***",
-                         ifelse(out$moran_pval[i] <= .05, "**",
-                                ifelse(out$moran_pval[i] <= .10, "*", ""
-                              )))
-                )
-      } else ""
-    ), "\n")
-  }
 
+  if (single) {
+    summary_diffnet_out_display(out, slen, meta, slices, qf, skip.moran)
+  } else {
+    for (q in 1:length(object$cumadopt)) {
+      summary_diffnet_out_display(out_list[[q]], slen, meta, slices, qf, skip.moran)
+    }
+  }
 
   # print(out, digits=2)
 
@@ -324,6 +345,32 @@ summary.diffnet <- function(
   invisible(out)
 }
 
+summary_diffnet_out_display <- function(out, slen, meta, slices, qf, skip.moran) {
+  for (i in 1:nrow(out)) {
+    cat(sprintf(
+      paste0("%",slen,"s", collapse=" "),
+      qf(meta$pers[slices[i]],0), qf(out[i,1],0),
+      sprintf("%s (%s)",
+              qf(out$cum_adopt[i],0),
+              qf(out$cum_adopt_pcent[i])
+      ),
+      ifelse(i==1, "-",qf(out$hazard[i])), qf(out$density[i]),
+
+      if (!skip.moran) {
+        if (is.nan(out$moran_sd[i])) {" - "}
+        else {sprintf("%s (%s) %-3s",
+                      qf(out$moran_obs[i]),
+                      qf(out$moran_sd[i]),
+                      ifelse(out$moran_pval[i] <= .01, "***",
+                             ifelse(out$moran_pval[i] <= .05, "**",
+                                    ifelse(out$moran_pval[i] <= .10, "*", ""
+                                    )))
+        )}
+      } else {""}
+    ), "\n")
+  }
+}
+
 #' Plot the diffusion process
 #'
 #' Creates a colored network plot showing the structure of the graph through time

tests/testthat/test-rdiffnet.R

@@ -129,3 +129,36 @@ test_that("All should be equal! (multiple)", {
 
   expect_equal(net1, net2)
 })
+
+
+#single
+rdiffnet(100, 5)
+rdiffnet(100, 5, seed.p.adopt = 0.1)
+rdiffnet(100, 5, seed.p.adopt = 0.1, seed.nodes = 'random')
+rdiffnet(100, 5, seed.nodes = c(1,3,5))
+net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5))
+summary(net_1)
+
+#multi
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), behavior = c('tabacco', 'alcohol'))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = 'random')
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), seed.nodes = c('random', 'central'))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = 0.3)
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(0.1,0.2))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = rexp(100))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(rexp(100),runif(100)))
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = function(x) 0.3)
+rdiffnet(100, 5, seed.p.adopt = list(0.1,0.08), threshold.dist = list(function(x) 0.3, function(x) 0.2))
+
+net_1 <- rdiffnet(100, 5, seed.nodes = c(1,3,5))
+summary(net_1)
+net_2 <- rdiffnet(100, 5, seed.p.adopt = list(0.05,0.05), seed.nodes = c(1,3,5))
+summary(net_2)
+
+#rdiffnet(100, 5, seed.p.adopt = 0.9, threshold.dist = 2, exposure.args = list(normalized=FALSE))
+
+# set.seed(1234)
+# net1 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = c(1,3,5))
+# net2 <- rdiffnet(100, 5, rewire = FALSE, seed.p.adopt = list(0.1,0.08), seed.nodes = list(c(1,3,5),c(1,3,5)))
+# expect_equal(net1, net2)