Merge branch 'development'

.Rbuildignore

@@ -6,3 +6,6 @@
 ^\.github$
 ^README\.Rmd$
 ^vignettes/articles$
+^_pkgdown\.yml$
+^docs$
+^pkgdown$

.gitignore

@@ -3,3 +3,4 @@
 .RData
 .Ruserdata
 .WIP/simulation.data/
+docs

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: SimuNet
 Title: Network simulation framework, with a zest of empiricism
-Version: 2.0.2
+Version: 2.1.0
 Authors@R: 
     person(given = "Kenneth",
            family = "Keuk",
@@ -20,7 +20,9 @@ Imports:
     httr,
     magrittr,
     purrr,
-    scales
+    scales,
+    Matrix,
+    methods
 URL: https://github.com/R-KenK/SimuNet
 BugReports: https://github.com/R-KenK/SimuNet/issues
 Suggests: 

NAMESPACE

@@ -10,14 +10,16 @@ S3method(count_nonNA,empirical)
 S3method(count_nonNA,sLlist)
 S3method(count_nonNA,scanList)
 S3method(print,matList)
+S3method(print,scaled)
 S3method(print,scanList)
+S3method(print,weightedAdj)
 S3method(rbind,scanList)
 S3method(remove_mostPeripheral,sLlist)
 S3method(remove_mostPeripheral,scanList)
 S3method(scale_scans,empirical)
 S3method(scale_scans,sLlist)
 S3method(scale_scans,scanList)
-S3method(scale_scans,sum)
+S3method(scale_scans,weightedAdj)
 S3method(sum_scans,empirical)
 S3method(sum_scans,sLlist)
 S3method(sum_scans,scanList)
@@ -59,17 +61,20 @@ export(remove_mostPeripheral)
 export(resolve_NA)
 export(sLapply)
 export(sLlapply)
+export(sLvapply)
 export(scale_scans)
 export(scanList2matList)
 export(simunet)
 export(sum_scans)
+importFrom(Matrix,printSpMatrix)
 importFrom(httr,GET)
 importFrom(httr,content)
 importFrom(httr,stop_for_status)
 importFrom(igraph,get.adjacency)
 importFrom(igraph,read_graph)
 importFrom(igraph,vertex_attr)
 importFrom(magrittr,"%>%")
+importFrom(methods,as)
 importFrom(purrr,compose)
 importFrom(scales,rescale_max)
 importFrom(stats,rbeta)

NEWS.md

@@ -1,3 +1,13 @@
+# SimuNet 2.1.0
+* `print` methods are cleaner for SimuNet specific objects:
+    *`scanList` objects printing now relies on Matrix `sparseMatrix` class
+    * so do their "collapsed" weighted adjacency relative: `weightedAdj` (see below).
+* class `sum` (obtained via `sum_scans()`) has been renamed to `weightedAdj`:
+    * `Adj` stored in `attrs` (and created by `generate_edgeProb()`) are now of class `weightedAdj`.
+    * This change allows for homogeneous printing of weighted adjacency matrices
+* pkgdown is now used to update the website's package. Related files are in master branch's `docs/`
+folder
+
 # SimuNet 2.0.2
 * enclosed asnr related example in \dontrun{} because some example were sometime not passing on unix
 systems

R/edgeProb.R

@@ -19,6 +19,7 @@
 generate_edgeProb <- function(Adj,samp.effort,mode,
                                   Adj.subfun = NULL){
   Adj[] <- as.integer(Adj)
+  class(Adj) <- "weightedAdj"
   if (is.null(Adj.subfun)) {
     Adj.subfun <- determine_Adj.subfun(mode = mode)
   }

R/expDesign_building.blocks.R

@@ -19,9 +19,9 @@
 #'   `scanList`s)
 #'   * `"raw"`: sum the `raw.scanList` (useful to see the impact of chosen `mode`)
 #'
-#' @return a `sum` object, or list of such, consisting mainly on a weighted adjacency matrix where
-#'   each edge weight is equal to the sum of all binary edges. Inherits from the previous `scanList`
-#'   class (theoretical or empirical, inheriting from `scanList`), and keeps track of the
+#' @return a `weightedAdj` object, or list of such, consisting mainly on a weighted adjacency matrix
+#'   where each edge weight is equal to the sum of all binary edges. Inherits from the previous
+#'   `scanList` class (theoretical or empirical, inheriting from `scanList`), and keeps track of the
 #'   `scan.list`'s list of attributes `attrs`.
 #'
 #'   Also adds these attributes to `attrs`:
@@ -79,7 +79,7 @@ sum_scans.scanList <- function(scan.list,which = c("auto","theoretical","raw"),.
   summed <- copy_attrs_to(sL.ori,summed)
   attrs(summed,"summed.scanList") <- without_attrs(sL.ori)
   attrs(summed,"sampled") <- scan.list |> count_nonNA()
-  class(summed) <- c("sum",class(scan.list))
+  class(summed) <- c("weightedAdj",class(scan.list))
   summed
 }
 
@@ -113,9 +113,9 @@ sum_scans.empirical <- function(scan.list,which = c("auto","theoretical","raw"),
 #'
 #' @return a `scaled` object, or list of such, consisting mainly on a weighted adjacency matrix
 #'   where each edge weight is equal to the sum of all binary edges divided by the number of times
-#'   they have been sampled (determined via [`count_nonNA()`][count_nonNA()]). Inherits from `sum`
-#'   and the previous `scanList` class (theoretical or empirical, inheriting from `scanList`), and
-#'   keeps track of the `scan.list`'s list of attributes `attrs`
+#'   they have been sampled (determined via [`count_nonNA()`][count_nonNA()]). Inherits from
+#'   `weightedAdj` and the previous `scanList` class (theoretical or empirical, inheriting from
+#'   `scanList`), and keeps track of the `scan.list`'s list of attributes `attrs`
 #'
 #' @export
 #'
@@ -137,11 +137,11 @@ sum_scans.empirical <- function(scan.list,which = c("auto","theoretical","raw"),
 #' ## theoretical scans
 #' sL <- simunet(Adj = Adj,samp.effort = samp.effort,mode = "directed",n.scans = 120L)
 #' sL
-#' # scale_scans() can scale sum objects...
+#' # scale_scans() can scale `weightedAdj` objects...
 #' sL |> sum_scans() |> scale_scans()
 #'
 #'
-#' # ... or scanList object directly
+#' # ... or `scanList` object directly
 #' ## group-scan sampling
 #' sL |> perform_exp(design_exp(customize_sampling("group",.6))) |> scale_scans()
 #'
@@ -153,10 +153,10 @@ scale_scans <- function(scan.list,...) {
   UseMethod("scale_scans")
 }
 
-#' scale_scans method for `sum` objects
+#' scale_scans method for `weightedAdj` objects
 #' @export
 #' @noRd
-scale_scans.sum <- function(scan.list,...) {
+scale_scans.weightedAdj <- function(scan.list,...) {
   sf <- attrs(scan.list,"Adj.subfun")
   sampled <- attrs(scan.list,"sampled")
   scaled <- scan.list
@@ -204,9 +204,9 @@ scale_scans.sLlist <- function(scan.list,...) {
 #' At the moment `count_NA()` does not use additional argument, arguments passed will be ignored.
 #'
 #' @return an integer matrix, or list of such, representing how many time each edge has been
-#'   unobserved (i.e. was `NA`). Inherits from the previous `scanList` class (theoretical or
-#'   empirical, inheriting from `scanList`), and keeps track of the `scan.list`'s list of attributes
-#'   `attrs`.
+#'   unobserved (i.e. was `NA`). Inherits from `weightedAdj` and the previous `scanList` class (theoretical
+#'   or empirical, inheriting from `scanList`), and keeps track of the `scan.list`'s list of
+#'   attributes `attrs`.
 #' @export
 #'
 #' @seealso [simunet()], [design_exp()], [perform_exp()], [count_nonNA()].
@@ -242,6 +242,8 @@ count_NA.scanList <- function(scan.list,...) {
   scan.sampled <- scan.list |> is.na() |> ifelse(1L,0L) %>% copy_attrs_to(from = scan.list)
   scan.sampled <- scan.sampled |> rowSums(na.rm = TRUE,dims = 2L)
   scan.sampled[!sf(scan.sampled)] <- 0L
+  scan.sampled <- copy_attrs_to(scan.list,scan.sampled)
+  class(scan.sampled) <- c("weightedAdj",class(scan.list))
   scan.sampled
 }
 
@@ -275,8 +277,9 @@ count_NA.sLlist <- function(scan.list,...) {
 #' At the moment `count_nonNA()` does not use additional argument, arguments passed will be ignored.
 #'
 #' @return an integer matrix, or list of such, representing how many time each edge has been sampled
-#'   (i.e. was *not* `NA`).Inherits from the previous `scanList` class (theoretical or empirical,
-#'   inheriting from `scanList`), and keeps track of the `scan.list`'s list of attributes `attrs`.
+#'   (i.e. was *not* `NA`). Inherits from `weightedAdj` and the previous `scanList` class (theoretical or
+#'   empirical, inheriting from `scanList`), and keeps track of the `scan.list`'s list of attributes
+#'   `attrs`.
 #' @export
 #'
 #' @seealso [simunet()], [design_exp()], [perform_exp()]], [count_NA()].
@@ -312,6 +315,8 @@ count_nonNA.scanList <- function(scan.list,...) {
   scan.sampled <- scan.list |> is.na() |> ifelse(0L,1L) %>% copy_attrs_to(from = scan.list)
   scan.sampled <- scan.sampled |> rowSums(na.rm = TRUE,dims = 2L)
   scan.sampled[!sf(scan.sampled)] <- 0L
+  scan.sampled <- copy_attrs_to(scan.list,scan.sampled)
+  class(scan.sampled) <- c("weightedAdj",class(scan.list))
   scan.sampled
 }
 

R/expDesign_sampling.R

@@ -239,7 +239,7 @@ group_sample <- function(scan.list,sampling = c("constant","matrix","random","fu
   obs.P <- determine_obsProb(scan.list = scan.list,sampling = sampling,all.sampled = all.sampled)
 
   groupSampled <-
-    sLapply(scan.list,
+    sLvapply(scan.list,
             \(s) {
               s[sf(s)] <-
                 s[sf(s)] |>

R/scanList_tools.R

@@ -109,7 +109,7 @@ draw_raw_scanList <- function(edge.Prob,n.scans) {
       stats::rbinom(edge.Prob$P,1L,edge.Prob$P)
     },edge.Prob$Adj
   )
-  class(sL) <- "scanList"
+  class(sL) <- c("raw","scanList")
   sL
 }
 
@@ -236,6 +236,38 @@ copy_attrs_to <- function(from,to) {
   to
 }
 
+#' Shortcut to a `lapply` equivalent to apply a function to each 2D matrix contained in a `scanList`
+#' Written analogously to [vapply()]. Values returned by `.f` should be a similarly dimensionned
+#' matrix as the first one contained in the 3D array
+#'
+#' @param sL a `scanList` object (see [`simunet()`][simunet()])
+#' @param FUN a function,to apply a function to each 2D matrix contained in `sL`
+#' @param ... extra argument to be passed, notably named arguments used by `.f` (see [lapply()])
+#'
+#' @return a 3D array onto which the function has been applied to each scan
+#'
+#' @export
+#'
+#' @examples
+#' set.seed(42)
+#' n <- 5L
+#' samp.effort <- 100L
+#'
+#' # Adjacency matrix import
+#' ## random directed adjacency matrix
+#' Adj <- sample(1:samp.effort,n * n) |>
+#'   matrix(nrow = 5,dimnames = list(letters[1:n],letters[1:n]))
+#' Adj[lower.tri(Adj,diag = TRUE)] <- 0L
+#' Adj
+#'
+#' sL <- simunet(Adj = Adj,samp.effort = samp.effort,mode = "upper",n.scans = 120L)
+#' sL |> sLapply(\(scan) {scan[1,2] <- NA;scan})
+sLapply <- function(sL,FUN,...) {
+  lapply(
+    X = 1:(dim(sL)[3]),
+    FUN = function(x) FUN(sL[,,x],...)
+  )
+}
 #' Shortcut to a `lapply` equivalent to apply a function to each 2D matrix contained in a `scanList`
 #' Written analogously to [vapply()]. Values returned by `.f` should be a similarly dimensionned
 #' matrix as the first one contained in the 3D array
@@ -264,7 +296,7 @@ copy_attrs_to <- function(from,to) {
 #'
 #' sL <- simunet(Adj = Adj,samp.effort = samp.effort,mode = "upper",n.scans = 120L)
 #' sL |> sLapply(\(scan) {scan[1,2] <- NA;scan})
-sLapply <- function(sL,.f,...,USE.NAMES = TRUE) {
+sLvapply <- function(sL,.f,...,USE.NAMES = TRUE) {
   vapply(
     X = 1:(dim(sL)[3]),
     FUN = function(x) .f(sL[,,x]),
@@ -315,14 +347,6 @@ sLlapply <- function(sLlist,FUN,...) {
   sLlist
 }
 
-#' Print method for `scanList` objects
-#' @export
-#' @noRd
-print.scanList <- function(x,...) {
-  print.default(without_attrs(x))
-  cat("\n\nHidden attributes:",names(get_attrs(x)))
-}
-
 #' transpose method for `scanList` objects
 #' @export
 #' @noRd
@@ -353,3 +377,110 @@ rbind_2scanList <- function(sL1,sL2) {
 rbind.scanList <- function(...,deparse.level = 1) {
   Reduce(rbind_2scanList,list(...))
 }
+
+# printing related functions ----
+
+## printing methods ----
+#' Print method for `scanList` objects
+#' @export
+#' @noRd
+print.scanList <- function(x,...) {
+  print_sLarray(x)
+  format_attributes(x,...)
+  invisible(x)
+}
+
+#' Print method for `weightedAdj` objects
+#' @export
+#' @noRd
+print.weightedAdj <- function(x,...) {
+  to.print <- without_attrs(x)
+  class(to.print) <- NULL
+  print_clean_scan(to.print,"Weighted adjacency matrix",...)
+  format_attributes(x,...)
+  invisible(x)
+}
+
+#' Print method for `scaled` objects
+#' @export
+#' @noRd
+print.scaled <- function(x,digits = 2,...) {
+  to.print <- without_attrs(x) |> round(digits = digits)
+  class(to.print) <- NULL
+  print_clean_scan(to.print,"Weighted adjacency matrix",...)
+  format_attributes(x,...)
+  invisible(x)
+}
+
+## printing tools ----
+
+#' Cleaner 3D array print
+#'
+#' @param sL a `scanList` object
+#' @param ... additional arguments to be passed to `Matrix::printSpMatrix()`
+#'
+#' @return `sL` invisibly, but print a cleaner 3D array via `Matrix::printSpMatrix()`
+#' @noRd
+print_sLarray <- function(sL,...) {
+  scan.ind <- choose_scan_to_print(sL)
+  truncated <- attr(scan.ind,"truncated")
+  # prints all but the last
+  lapply(scan.ind,\(s) print_clean_scan(sL[,,s],s,...))
+  if (truncated) cat("\n... (",dim(sL)[3] - 3," more scans)\n")
+  print_clean_scan(sL[,,dim(sL)[3]],dim(sL)[3],...)
+  invisible(sL)
+}
+
+#' Choose what scan index to display, truncate if too many
+#'
+#' @param sL a `scanList` object
+#'
+#' @return integer vector, indices of scan to print
+#' @noRd
+choose_scan_to_print <- function(sL) {
+  truncated <- dim(sL)[3] > 5
+  scan.ind <-
+    if (truncated) c(1,2) else scan.ind <- 1:(dim(sL)[3] - 1)
+  attr(scan.ind,"truncated") <- truncated
+  attr(scan.ind,"last.scan") <- dim(sL)[3]
+  scan.ind
+}
+
+#' Cleaner adjacency matrix print
+#'
+#' @param scan numeric matrix, a scan
+#' @param s integer, scan index
+#' @param ... additional arguments to be passed to
+#'   [`Matrix::printSpMatrix()`][Matrix::printSpMatrix()]
+#' @param mode character, igraph's mode
+#' @param col.names logical, see [`Matrix::printSpMatrix()`][Matrix::printSpMatrix()]
+#' @param note.dropping.colnames logical, see [`Matrix::printSpMatrix()`][Matrix::printSpMatrix()]
+#'
+#' @return `scan` invisibly, but print a cleaner scan via
+#'   [`Matrix::printSpMatrix()`][Matrix::printSpMatrix()]
+#'
+#' @importFrom Matrix printSpMatrix
+#' @importFrom methods as
+#'
+#' @noRd
+print_clean_scan <- function(scan,s,
+                             col.names = FALSE,
+                             note.dropping.colnames = FALSE,
+                             ...) {
+  cat("\nscan: ",s,sep = "")
+  methods::as(scan,"dgCMatrix") |>
+    Matrix::printSpMatrix(col.names = col.names,note.dropping.colnames = note.dropping.colnames,
+                          ...)
+  invisible(scan)
+}
+
+#' Display and format attribute names in attrs if they exist
+#'
+#' @param x a `scanList` or `weightedAdj` object
+#' @param ... ignored
+#'
+#' @noRd
+format_attributes <- function(x,...) {
+  if (!is.null(get_attrs(x))) cat("\n\nHidden attributes:",names(get_attrs(x)))
+  invisible(x)
+}