fix printing issues for rpacontrol XPtr

DESCRIPTION

 Package: wdnet
 Title: Weighted and Directed Networks
 Version: 1.1.1
-Date: 2023-05-17
+Date: 2023-06-26
 Authors@R: c(
     person("Yelie", "Yuan", email = "yelie.yuan@uconn.edu",
            role = c("aut", "cre")),

NAMESPACE

@@ -46,6 +46,7 @@ importFrom(igraph,distances)
 importFrom(igraph,edge.attributes)
 importFrom(igraph,graph_from_adjacency_matrix)
 importFrom(igraph,graph_from_edgelist)
+importFrom(igraph,indent_print)
 importFrom(igraph,is.directed)
 importFrom(igraph,is.igraph)
 importFrom(igraph,plot.igraph)
@@ -56,6 +57,7 @@ importFrom(stats,rgamma)
 importFrom(stats,rpois)
 importFrom(stats,runif)
 importFrom(stats,weighted.mean)
+importFrom(utils,capture.output)
 importFrom(utils,head)
 importFrom(utils,modifyList)
 importFrom(wdm,wdm)

R/assortativity.R

@@ -119,8 +119,7 @@ dw_assort <- function(adj, type = c("outin", "inin", "outout", "inout")) {
 #' @examples
 #' set.seed(123)
 #' control <- rpa_control_edgeweight(
-#'   distribution = rgamma,
-#'   dparams = list(shape = 5, scale = 0.2), shift = 0
+#'   sampler = function(n) rgamma(n, shape = 5, scale = 0.2)
 #' )
 #' netwk <- rpanet(nstep = 10^4, control = control)
 #' ret <- assortcoef(netwk)

R/cls_rpacontrol.R

@@ -16,55 +16,170 @@
 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 ##
 
-#' Checks if the input is a \code{rpacontrol} object
+#' @importFrom igraph indent_print
+#' @importFrom utils capture.output
+NULL
+
+
+#' Checks whether the input is a \code{rpacontrol} object
 #'
-#' @param control An \code{rpacontrol} object.
+#' @param control A \code{rpacontrol} object.
 #' @return Logical, \code{TRUE} if the input is a \code{rpacontrol} object.
 #' @keywords internal
-#' 
+#'
 is_rpacontrol <- function(control) {
     return(inherits(control, "rpacontrol"))
 }
 
-#' Prints preference functions in terminal
-#' 
-#' @param control An object of class \code{rpacontrol}.
+
+#' Prints \code{rpa_control_scenario()} in terminal
+#'
+#' @param control A list of control parameters for
+#'   \code{rpa_control_scenario()}.
+#'
+#' @return Returns \code{NULL} invisibly.
+#' @keywords internal
+#'
+print_control_scenario <- function(control) {
+    cat("Edge scenarios:\n")
+    cat(" - alpha: ", control$alpha, "\n", sep = "")
+    cat(" - beta: ", control$beta, "\n", sep = "")
+    cat(" - gamma: ", control$gamma, "\n", sep = "")
+    cat(" - xi: ", control$xi, "\n", sep = "")
+    cat(" - rho: ", control$rho, "\n", sep = "")
+    cat(" - beta.loop: ", control$beta.loop, "\n", sep = "")
+    cat(" - source.first: ", control$source.first, "\n", sep = "")
+    invisible(NULL)
+}
+
+
+#' Prints \code{rpa_control_edgeweight()} in terminal
+#'
+#' @param control A list of control parameters for
+#'   \code{rpa_control_edgeweight()}.
+#'
+#' @return Returns \code{NULL} invisibly.
+#' @keywords internal
+#'
+print_control_edgeweight <- function(control) {
+    cat("Edge weights:\n")
+
+    cat(" - sampler: ")
+    if (is.null(control$sampler)) {
+        cat("NULL; all new edges have weight 1\n")
+    } else {
+        cat("\n")
+        igraph::indent_print(control$sampler, .indent = "   ")
+    }
+
+    invisible(NULL)
+}
+
+
+#' Prints \code{rpa_control_newedge()} in terminal
+#'
+#' @param control A list of control parameters for
+#'   \code{rpa_control_newedge()}.
+#'
 #' @return Returns \code{NULL} invisibly.
 #' @keywords internal
-#' 
-print_control_preference <- function(control, directed = NULL) {
+#'
+print_control_newedge <- function(control) {
+    cat("New edges in each step:\n")
+
+    cat(" - sampler: ")
+    if (is.null(control$sampler)) {
+        cat("NULL; add one new edge at each step\n")
+    } else {
+        cat("\n")
+        igraph::indent_print(control$sampler, .indent = "   ")
+    }
+
+    cat(" - snode.replace: ", control$snode.replace, "\n", sep = "")
+    cat(" - tnode.replace: ", control$tnode.replace, "\n", sep = "")
+    cat(" - node.replace: ", control$node.replace, "\n", sep = "")
+    invisible(NULL)
+}
+
+
+#' Prints \code{rpa_control_reciprocal()} in terminal
+#'
+#' @param control A list of control parameters for
+#'   \code{rpa_control_reciprocal()}.
+#' @return Returns \code{NULL} invisibly.
+#' @keywords internal
+#'
+print_control_reciprocal <- function(control) {
+    cat("Reciprocal edges:\n")
+
+    cat(" - group.prob: ")
+    if (is.null(control$group.prob)) {
+        cat("NULL\n")
+    } else {
+        cat(control$group.prob, "\n", sep = " ")
+    }
+
+    cat(" - recip.prob: ")
+    if (is.null(control$recip.prob)) {
+        cat("NULL; no immediate reciprocal edges\n")
+    } else {
+        cat("\n")
+        igraph::indent_print(control$recip.prob, .indent = "   ")
+    }
+    invisible(NULL)
+}
+
+
+#' Prints \code{rpa_control_preference()} in terminal
+#'
+#' @param control A list of control parameters for
+#'   \code{rpa_control_preference()}.
+#' @param directed Logical, whether to print preference functions for directed
+#'   networks only. If missing, print preference functions for both directed
+#'   and undirected networks.
+#'
+#' @return Returns \code{NULL} invisibly.
+#' @keywords internal
+#'
+print_control_preference <- function(control, directed) {
     cat("Preference functions:\n")
-    cat(" - ftype: ", control$preference$ftype, "\n", sep = "")
-    if (control$preference$ftype == "default") {
+    cat(" - ftype: ", control$ftype, "\n", sep = "")
+    if (control$ftype == "default") {
         spref <- paste0(
             " - sparams: ",
-            paste(control$preference$sparams, collapse  = " ")
+            paste(control$sparams, collapse = " ")
         )
         tpref <- paste0(
             " - tparams: ",
-            paste(control$preference$tparams, collapse  = " ")
+            paste(control$tparams, collapse = " ")
         )
         pref <- paste0(
             " - params: ",
-            paste(control$preference$params, collapse  = " ")
-        )
-    } else if (control$preference$ftype == "customized") {
-        spref <- paste0(
-            " - spref: ",
-            control$preference$spref
-        )
-        tpref <- paste0(
-            " - tpref: ",
-            control$preference$tpref
-        )
-        pref <- paste0(
-            " - pref: ",
-            control$preference$pref
+            paste(control$params, collapse = " ")
         )
+    } else if (control$ftype == "customized") {
+        my_print <- function(pref, type) {
+            if (inherits(pref, "XPtr")) {
+                tmp <- utils::capture.output(pref)
+                if (grepl("pointer:\\ \\(nil\\)", tmp)) {
+                    pref <- paste0(" - ", type,
+                        ": XPtr; nolonger valid, please re-compile",
+                        sep = ""
+                    )
+                } else {
+                    pref <- paste0(" - ", type, ": XPtr;", tmp, sep = "")
+                }
+            } else {
+                pref <- paste0(" - ", type, ": ", pref)
+            }
+        }
+        spref <- my_print(control$spref, "spref")
+        tpref <- my_print(control$tpref, "tpref")
+        pref <- my_print(control$pref, "pref")
     } else {
         stop("Preference function type is not valid.")
     }
-    if (is.null(directed)) {
+    if (missing(directed)) {
         cat(spref, tpref, pref, sep = "\n")
     } else if (directed) {
         cat(spref, tpref, sep = "\n")
@@ -75,35 +190,23 @@ print_control_preference <- function(control, directed = NULL) {
     invisible(NULL)
 }
 
+
 #' Prints \code{rpacontrol} in terminal
 #'
 #' @param x An object of class \code{rpacontrol}.
-#' @param control_name A string of control name.
-#' @param control_description A list of control descriptions.
+#' @param control_name A string, the name of the control component.
+#'
 #' @return Returns \code{NULL} invisibly.
 #' @keywords internal
-#' 
-print_control_details <- function(x, control_name, control_description) {
-    if (control_name == "preference") {
-        print_control_preference(control = x, directed = NULL)
-        cat("\n")
-        return(invisible(NULL))
-    }
-    cat(control_description[[control_name]], ":\n", sep = "")
-    for (name in names(x[[control_name]])) {
-        value <- x[[control_name]][[name]]
-        if (is.function(value)) {
-            value <- x[[control_name]][["distname"]]
-        } else if (name == "distname") {
-            next
-        } else if (length(value) > 0 && is.list(value)) {
-            value <- sapply(
-                seq_along(value),
-                function(i) paste0(names(value)[i], "=", value[i], " ")
-            )
-        }
-        cat(paste0(" - ", name, ": "), value, "\n", sep = "")
-    }
+#'
+print_control_details <- function(x, control_name) {
+    switch(control_name,
+        "scenario" = print_control_scenario(control = x$scenario),
+        "edgeweight" = print_control_edgeweight(control = x$edgeweight),
+        "newedge" = print_control_newedge(control = x$newedge),
+        "reciprocal" = print_control_reciprocal(control = x$reciprocal),
+        "preference" = print_control_preference(control = x$preference)
+    )
     cat("\n")
     invisible(NULL)
 }
@@ -127,15 +230,12 @@ print_control_details <- function(x, control_name, control_description) {
 #'
 #' control <- rpa_control_scenario()
 #' print(control)
-#' 
+#'
 print.rpacontrol <- function(x, ...) {
-    tmp <- rpa_control_list()
     control_names <- names(x)
-    control_descriptions <- tmp$control_descriptions
-    rm(tmp)
 
     for (each in control_names) {
-        print_control_details(x, each, control_descriptions)
+        print_control_details(x, each)
     }
     invisible(x)
 }
@@ -143,22 +243,19 @@ print.rpacontrol <- function(x, ...) {
 #' @rdname print.rpacontrol
 #' @method summary rpacontrol
 #' @export
-#' 
+#'
 summary.rpacontrol <- function(object, ...) {
     control_default <- rpa_control_default()
     object <- control_default + object
 
-    tmp <- rpa_control_list()
-    control_names <- tmp$control_names
-    control_descriptions <- tmp$control_descriptions
-    rm(tmp)
+    control_names <- names(rpa_control_default())
 
     count <- 0
     cat("Specified control(s):\n")
     cat("--------------------\n")
     for (each in control_names) {
         if (!identical(control_default[[each]], object[[each]])) {
-            print_control_details(object, each, control_descriptions)
+            print_control_details(object, each)
             count <- 1
         }
     }
@@ -169,7 +266,7 @@ summary.rpacontrol <- function(object, ...) {
     cat("------------------------------\n")
     for (each in control_names) {
         if (identical(control_default[[each]], object[[each]])) {
-            print_control_details(object, each, control_descriptions)
+            print_control_details(object, each)
             count <- 1
         }
     }

R/compile_pref.R

@@ -22,62 +22,105 @@ NULL
 #' Compile preference functions via \code{Rcpp}.
 #'
 #' @param preference A list for defining the preference functions.
+#' @param directed Logical, whether to compile the preference functions for
+#'   directed networks. If missing, the preference functions 
+#'   for both directed and undirected networks will be compiled.
 #'
 #' @return Returns the input list and their corresponding external pointers.
 #'
 #' @keywords internal
-#' 
-compile_pref_func <- function(preference) {
-  if (inherits(preference$spref, "character")) {
-    temp <- paste("double spref(double outs, double ins) { return ",
-      preference$spref, ";}",
-      sep = ""
-    )
-    preference$spref.pointer <- RcppXPtrUtils::cppXPtr(code = temp)
-    rm(temp)
-  } else if (inherits(preference$spref, "XPtr")) {
-    RcppXPtrUtils::checkXPtr(
-      ptr = preference$spref,
-      type = "double",
-      args = c("double", "double")
-    )
-    preference$spref.pointer <- preference$spref
-  } else {
-    stop('The class of "spref" must be either "XPtr" or "character".')
-  }
-  if (inherits(preference$tpref, "character")) {
-    temp <- paste("double tpref(double outs, double ins) { return ",
-      preference$tpref, ";}",
-      sep = ""
-    )
-    preference$tpref.pointer <- RcppXPtrUtils::cppXPtr(code = temp)
-    rm(temp)
-  } else if (inherits(preference$tpref, "XPtr")) {
-    RcppXPtrUtils::checkXPtr(
-      ptr = preference$tpref,
-      type = "double",
-      args = c("double", "double")
-    )
-    preference$tpref.pointer <- preference$tpref
-  } else {
-    stop('The class of "tpref" must be either "XPtr" or "character".')
+#'
+compile_pref_func <- function(preference, directed) {
+  if (missing(directed) || directed) {
+    if (inherits(preference$spref, "character")) {
+      tmp <- paste("double spref(double outs, double ins) { return ",
+        preference$spref, ";}",
+        sep = ""
+      )
+      preference$spref.pointer <- RcppXPtrUtils::cppXPtr(code = tmp)
+      rm(tmp)
+    } else if (inherits(preference$spref, "XPtr")) {
+      tryCatch(
+        {
+          RcppXPtrUtils::checkXPtr(
+            ptr = preference$spref,
+            type = "double",
+            args = c("double", "double")
+          )
+        },
+        error = function(e) {
+          stop('Incorrect argument or return type for "spref"; all should be "double".')
+        }
+      )
+      preference$spref.pointer <- preference$spref
+      tmp <- utils::capture.output(preference$spref.pointer)
+      if (grepl("pointer:\\ \\(nil\\)", tmp)) {
+          stop('"XPtr" for "spref" is nolonger valid, please re-compile.')
+      }
+      rm(tmp)
+    } else {
+      stop('The class of "spref" must be either "XPtr" or "character".')
+    }
+    if (inherits(preference$tpref, "character")) {
+      tmp <- paste("double tpref(double outs, double ins) { return ",
+        preference$tpref, ";}",
+        sep = ""
+      )
+      preference$tpref.pointer <- RcppXPtrUtils::cppXPtr(code = tmp)
+      rm(tmp)
+    } else if (inherits(preference$tpref, "XPtr")) {
+      tryCatch(
+        {
+          RcppXPtrUtils::checkXPtr(
+            ptr = preference$tpref,
+            type = "double",
+            args = c("double", "double")
+          )
+        },
+        error = function(e) {
+          stop('Incorrect argument or return type for "tpref"; all should be "double".')
+        }
+      )
+      preference$tpref.pointer <- preference$tpref
+      tmp <- utils::capture.output(preference$tpref.pointer)
+      if (grepl("pointer:\\ \\(nil\\)", tmp)) {
+          stop('"XPtr" for "tpref" is nolonger valid, please re-compile.')
+      }
+      rm(tmp)
+    } else {
+      stop('The class of "tpref" must be either "XPtr" or "character".')
+    }
   }
-  if (inherits(preference$pref, "character")) {
-    temp <- paste("double pref(double s) { return ",
-      preference$pref, ";}",
-      sep = ""
-    )
-    preference$pref.pointer <- RcppXPtrUtils::cppXPtr(code = temp)
-    rm(temp)
-  } else if (inherits(preference$pref, "XPtr")) {
-    RcppXPtrUtils::checkXPtr(
-      ptr = preference$pref,
-      type = "double",
-      args = "double"
-    )
-    preference$pref.pointer <- preference$pref
-  } else {
-    stop('The class of "pref" must be either "XPtr" or "character".')
+  if (missing(directed) || !directed) {
+    if (inherits(preference$pref, "character")) {
+      tmp <- paste("double pref(double s) { return ",
+        preference$pref, ";}",
+        sep = ""
+      )
+      preference$pref.pointer <- RcppXPtrUtils::cppXPtr(code = tmp)
+      rm(tmp)
+    } else if (inherits(preference$pref, "XPtr")) {
+      tryCatch(
+        {
+          RcppXPtrUtils::checkXPtr(
+            ptr = preference$pref,
+            type = "double",
+            args = "double"
+          )
+        },
+        error = function(e) {
+          stop('Incorrect argument or return type for "pref"; all should be "double".')
+        }
+      )
+      preference$pref.pointer <- preference$pref
+      tmp <- utils::capture.output(preference$pref.pointer)
+      if (grepl("pointer:\\ \\(nil\\)", tmp)) {
+          stop('"XPtr" for "pref" is nolonger valid, please re-compile.')
+      }
+      rm(tmp)
+    } else {
+      stop('The class of "pref" must be either "XPtr" or "character".')
+    }
   }
   return(preference)
 }

R/rpa_control.R

@@ -72,9 +72,7 @@ NULL
 #'
 #' control <- rpa_control_scenario(alpha = 1) +
 #'   rpa_control_edgeweight(
-#'     distribution = rgamma,
-#'     dparams = list(shape = 5, scale = 0.2),
-#'     shift = 1
+#'     sampler = function(n) rgamma(n, shape = 5, scale = 0.2)
 #'   )
 "+.rpacontrol" <- function(e1, e2) {
   e1 <- structure(
@@ -139,56 +137,28 @@ rpa_control_scenario <- function(
 
 #' Control weight of new edges. Defined for \code{rpanet}.
 #'
-#' @param distribution Distribution for drawing edge weights. Default is
-#'   \code{NULL}. If specified, its first argument must be the number of
-#'   observations.
-#' @param dparams A list of parameters passed on to \code{distribution}. The
-#'   names of parameters must be specified.
-#' @param shift A constant added to the values sampled from \code{distribution}.
-#'   Default value is 1.
+#' @param sampler A function used for sampling edge weights. If \code{NULL}, all
+#'   new edges will default to a weight of 1. If a function is provided, it must
+#'   accept a single argument, \code{n}, and return a vector of length \code{n}
+#'   that represents the sampled edge weights.
 #'
-#' @return A list of class \code{rpacontrol} with components
-#'   \code{distribution}, \code{dparams}, and \code{shift} with meanings as
-#'   explained under 'Arguments'.
+#' @return A list of class \code{rpacontrol} containing the \code{sampler}
+#'   function.
 #'
 #' @export
 #'
 #' @examples
-#' # Edge weight follows Gamma(5, 0.2).
+#' # Sample edge weights from Gamma(5, 0.2).
+#' my_gamma <- function(n) rgamma(n, shape = 5, scale = 0.2)
 #' control <- rpa_control_edgeweight(
-#'   distribution = rgamma,
-#'   dparams = list(shape = 5, scale = 0.2),
-#'   shift = 0
+#'   sampler = my_gamma
 #' )
-#'
-#' # Constant edge weight
-#' control <- rpa_control_edgeweight(shift = 2)
 #' 
 rpa_control_edgeweight <- function(
-    distribution = NULL,
-    dparams = NULL,
-    shift = 1) {
+    sampler = NULL) {
   edgeweight <- list(
-    "distribution" = distribution,
-    "dparams" = dparams,
-    "shift" = shift
+    "sampler" = sampler
   )
-  if (!is.null(edgeweight$dparams)) {
-    stopifnot(
-      '"dparams" must be a list.' = is.list(edgeweight$dparams)
-    )
-    stopifnot(
-      "Please specify the name of distribution parameters." =
-        all(!is.null(names(edgeweight$dparams)))
-    )
-    stopifnot(
-      "Please provide the distribution function." =
-        is.function(distribution)
-    )
-  }
-  if (is.function(distribution)) {
-    edgeweight$distname <- deparse(substitute(distribution))
-  }
   structure(list("edgeweight" = edgeweight),
     class = "rpacontrol"
   )
@@ -196,13 +166,11 @@ rpa_control_edgeweight <- function(
 
 #' Control new edges in each step. Defined for \code{rpanet}.
 #'
-#' @param distribution Distribution for drawing number of new edges. Default is
-#'   \code{NULL}. If specified, its first argument must be the number of
-#'   observations.
-#' @param dparams A list of parameters passed on to \code{distribution}. The
-#'   name of parameters must be specified.
-#' @param shift A constant added to the values sampled from \code{distribution}.
-#'   Default value is 1.
+#' @param sampler A function used for sampling the number of new edges to be
+#'   added at each step. If \code{NULL}, one new edge will be added at each
+#'   step. If a function is provided, it must accept a single argument,
+#'   \code{n}, and return a vector of length \code{n} that represents the
+#'   sampled number of new edges.
 #' @param snode.replace Logical. Determines whether the source nodes in the same
 #'   step should be sampled with replacement. Defined for directed networks.
 #' @param tnode.replace Logical. Determines whether the target nodes in the same
@@ -211,47 +179,29 @@ rpa_control_edgeweight <- function(
 #'   should be sampled with replacement. Defined for undirected networks. If
 #'   FALSE, self-loops will not be allowed under beta scenario.
 #'
-#' @return A list of class \code{rpacontrol} with components
-#'   \code{distribution}, \code{dparams}, \code{shift}, \code{snode.replace},
-#'   \code{tnode.replace} and \code{node.replace} with meanings as explained
-#'   under 'Arguments'.
+#' @return A list of class \code{rpacontrol} with components \code{sampler},
+#'   \code{snode.replace}, \code{tnode.replace} and \code{node.replace} with
+#'   meanings as explained under 'Arguments'.
 #'
 #' @export
 #'
 #' @examples
+#' my_rpois <- function(n) rpois(n, lambda = 2) + 1
 #' control <- rpa_control_newedge(
-#'   distribution = rpois,
-#'   dparams = list(lambda = 2),
-#'   shift = 1,
+#'   sampler = my_rpois,
 #'   node.replace = FALSE
 #' )
 rpa_control_newedge <- function(
-    distribution = NULL,
-    dparams = NULL,
-    shift = 1,
+    sampler = NULL,
     snode.replace = TRUE,
     tnode.replace = TRUE,
     node.replace = TRUE) {
   newedge <- list(
-    "distribution" = distribution,
-    "dparams" = dparams,
-    "shift" = shift,
+    "sampler" = sampler,
     "snode.replace" = snode.replace,
     "tnode.replace" = tnode.replace,
     "node.replace" = node.replace
   )
-  if (!is.null(newedge$dparams)) {
-    stopifnot(
-      '"dparams" must be a list.' = is.list(newedge$dparams)
-    )
-    stopifnot(
-      "Please specify the names of distribution parameters" =
-        all(!is.null(names(newedge$dparams)))
-    )
-  }
-  if (is.function(distribution)) {
-    newedge$distname <- deparse(substitute(distribution))
-  }
   structure(list("newedge" = newedge), class = "rpacontrol")
 }
 
@@ -326,12 +276,12 @@ rpa_control_newedge <- function(
 #' # Set source preference as out-strength^2 + in-strength + 1,
 #' # target preference as out-strength + in-strength^2 + 1.
 #' # 1. use default preference functions
-#' control1 <- rpa_control_preference(
+#' ctr1 <- rpa_control_preference(
 #'   ftype = "default",
 #'   sparams = c(1, 2, 1, 1, 1), tparams = c(1, 1, 1, 2, 1)
 #' )
 #' # 2. use character expressions
-#' control2 <- rpa_control_preference(
+#' ctr2 <- rpa_control_preference(
 #'   ftype = "customized",
 #'   spref = "pow(outs, 2) + ins + 1", tpref = "outs + pow(ins, 2) + 1"
 #' )
@@ -344,12 +294,12 @@ rpa_control_newedge <- function(
 #'   code =
 #'     "double tpref(double outs, double ins) {return outs + pow(ins, 2) + 1;}"
 #' )
-#' control3 <- rpa_control_preference(
+#' ctr3 <- rpa_control_preference(
 #'   ftype = "customized",
 #'   spref = spref.pointer,
 #'   tpref = tpref.pointer
 #' )
-#' ret <- rpanet(1e5, control = control3)
+#' ret <- rpanet(1e5, control = ctr3)
 #' }
 rpa_control_preference <- function(
     ftype = c("default", "customized"),
@@ -475,30 +425,3 @@ rpa_control_default <- function() {
     rpa_control_reciprocal() +
     rpa_control_preference()
 }
-
-#' Names and descriptions of controls for \code{rpanet()}
-#'
-#' @return Returns a list of control names and descriptions.
-#' @keywords internal
-#' 
-rpa_control_list <- function() {
-  control_names <- c(
-    "scenario",
-    "edgeweight",
-    "newedge",
-    "preference",
-    "reciprocal"
-  )
-
-  control_descriptions <- list(
-    scenario = "Edge scenarios",
-    edgeweight = "Edge weights",
-    newedge = "New edges in each step",
-    preference = "Preference functions",
-    reciprocal = "Reciprocal edges"
-  )
-  return(list(
-    control_names = control_names,
-    control_descriptions = control_descriptions
-  ))
-}

R/rpanet.R

@@ -16,9 +16,7 @@
 ## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 ##
 
-#' @importFrom utils modifyList
 #' @importFrom stats rgamma rpois
-#' @importFrom RcppXPtrUtils checkXPtr
 NULL
 
 #' Generate PA networks.
@@ -98,8 +96,7 @@ NULL
 #' set.seed(123)
 #' control <- rpa_control_scenario(alpha = 0.5, beta = 0.5) +
 #'   rpa_control_edgeweight(
-#'     distribution = rgamma,
-#'     dparams = list(shape = 5, scale = 0.2), shift = 0
+#'     sampler = function(n) rgamma(n, shape = 5, scale = 0.2)
 #'   )
 #' ret1 <- rpanet(nstep = 1e3, control = control)
 #'
@@ -113,11 +110,10 @@ NULL
 #' # Further, set the number of new edges in each step as Poisson(2) + 1 and use
 #' # ret2 as a seed network.
 #' control <- control + rpa_control_newedge(
-#'   distribution = rpois,
-#'   dparams = list(lambda = 2), shift = 1
+#'   sampler = function(n) rpois(n, lambda = 2) + 1
 #' )
 #' ret3 <- rpanet(nstep = 1e3, initial.network = ret2, control = control)
-#' 
+#'
 rpanet <- function(
     nstep, initial.network = list(
       edgelist = matrix(c(1, 2), nrow = 1),
@@ -163,40 +159,28 @@ rpanet <- function(
   }
   if (length(control$reciprocal$group.prob) > 0) {
     stopifnot(
-      'Length of "group.prob" in the control list in not valid.' =
+      'Length of "group.prob" is not valid.' =
         max(initial.network$node.attr$group) <= length(control$reciprocal$group.prob)
     )
   }
   if (control$preference$ftype == "customized") {
-    control$preference <- compile_pref_func(control$preference)
-    if (initial.network$directed) {
-      RcppXPtrUtils::checkXPtr(
-        ptr = control$preference$spref.pointer,
-        type = "double",
-        args = c("double", "double")
-      )
-      RcppXPtrUtils::checkXPtr(
-        ptr = control$preference$tpref.pointer,
-        type = "double",
-        args = c("double", "double")
-      )
-    } else {
-      RcppXPtrUtils::checkXPtr(
-        ptr = control$preference$pref.pointer,
-        type = "double",
-        args = "double"
-      )
-    }
+    control$preference <- compile_pref_func(
+      control$preference,
+      directed = initial.network$directed
+    )
   }
 
-  if (is.function(control$newedge$distribution)) {
-    m <- do.call(
-      control$newedge$distribution,
-      c(nstep, control$newedge$dparams)
-    ) + control$newedge$shift
+  if (is.null(control$newedge$sampler)) {
+    m <- rep(1, nstep)
+  } else if (is.function(control$newedge$sampler)) {
+    m <- do.call(control$newedge$sampler, list(nstep))
   } else {
-    m <- rep(control$newedge$shift, nstep)
+    stop('Invalid "sampler" for rpa_control_newedge().')
   }
+  stopifnot(
+    'Invalid "sampler" for rpa_control_newedge().' =
+      length(m) == nstep
+  )
   stopifnot(
     "Number of new edges per step must be positive integers." =
       all(m %% 1 == 0, m > 0)
@@ -204,18 +188,22 @@ rpanet <- function(
 
   sum_m <- sum(m)
   sample.recip <- TRUE
-  if (identical(control$reciprocal, rpa_control_reciprocal()$reciprocal)) {
+  if (is.null(control$reciprocal$recip.prob)) {
     sample.recip <- FALSE
   }
-  if (is.function(control$edgeweight$distribution)) {
-    w <- do.call(
-      control$edgeweight$distribution,
-      c(sum_m * (1 + sample.recip), control$edgeweight$dparams)
-    ) + control$edgeweight$shift
+
+  if (is.null(control$edgeweight$sampler)) {
+    w <- rep(1, sum_m * (1 + sample.recip))
+  } else if (is.function(control$edgeweight$sampler)) {
+    w <- do.call(control$edgeweight$sampler, list(sum_m * (1 + sample.recip)))
   } else {
-    w <- rep(control$edgeweight$shift, sum_m * (1 + sample.recip))
+    stop('Invalid "sampler" for rpa_control_edgeweight().')
   }
-  stopifnot("Edgeweight must be greater than 0." = w > 0)
+  stopifnot(
+    'Invalid "sampler" for rpa_control_edgeweight().' =
+      length(w) == sum_m * (1 + sample.recip)
+  )
+  stopifnot("Edge weights must be greater than 0." = w > 0)
 
   if ((!initial.network$directed) &&
     ((!control$newedge$snode.replace) || (!control$newedge$tnode.replace))) {
@@ -304,7 +292,7 @@ rpanet <- function(
   }
   if ((!control$newedge$node.replace) && control$scenario$beta.loop) {
     control$scenario$beta.loop <- FALSE
-    warning('"beta.loop" is set as FALSE since "node.replace" is FALSE.')
+    cat('"beta.loop" is set to FALSE since "node.replace" is FALSE.')
   }
   return(rpanet_general(
     nstep = nstep, initial.network = initial.network,

tests/testthat/test-rpanet.R

@@ -2,6 +2,9 @@ test_that("rpanet with default preference functions", {
   # sample PA networks
   set.seed(1234)
   nstep <- 1e3
+  my_weight_sampler <- function(n) {
+    rgamma(n, shape = 5, scale = 0.2)
+  }
   for (method in c("linear", "binary", "bag", "bagx")) {
     if (method == "linear" | method == "binary") {
       control <- rpa_control_preference(
@@ -13,9 +16,7 @@ test_that("rpanet with default preference functions", {
         rpa_control_scenario(
           alpha = 0.2, beta = 0.4, gamma = 0.2, xi = 0.1, rho = 0.1
         ) +
-        rpa_control_edgeweight(
-          distribution = rgamma, dparams = list(shape = 5, scale = 0.2)
-        )
+        rpa_control_edgeweight(sampler = my_weight_sampler)
     } else if (method == "bag") {
       control <- rpa_control_preference(
         ftype = "default",
@@ -36,9 +37,7 @@ test_that("rpanet with default preference functions", {
         rpa_control_scenario(
           alpha = 0.2, beta = 0.4, gamma = 0.2, xi = 0.1, rho = 0.1
         ) +
-        rpa_control_edgeweight(
-          distribution = rgamma, dparams = list(shape = 5, scale = 0.2)
-        )
+        rpa_control_edgeweight(sampler = my_weight_sampler)
     }
     initial.network1 <- rpanet(1e3,
       initial.network = list(
@@ -121,7 +120,7 @@ test_that("rpanet with customized preference functions", {
         alpha = 0.2, beta = 0.4, gamma = 0.2, xi = 0.1, rho = 0.1
       ) +
       rpa_control_edgeweight(
-        distribution = rgamma, dparams = list(shape = 5, scale = 0.2)
+        sampler = function(n) rgamma(n, shape = 5, scale = 0.2)
       )
     initial.network1 <- rpanet(1e3,
       initial.network = list(
@@ -191,9 +190,9 @@ test_that("rpanet initial network", {
   ) + rpa_control_scenario(
     alpha = 0.2, beta = 0.4, gamma = 0.2, xi = 0.1, rho = 0.1
   ) + rpa_control_edgeweight(
-    distribution = rgamma, dparams = list(shape = 5, scale = 0.2)
+    sampler = function(n) rgamma(n, shape = 5, scale = 0.2)
   ) + rpa_control_newedge(
-    distribution = rpois, dparams = list(lambda = 1), shift = 1
+    sampler = function(n) rpois(n, lambda = 2) + 1
   ) + rpa_control_reciprocal(
     group.prob = c(0.2, 0.4, 0.4),
     recip.prob = matrix(rep(0.5, 9), nrow = 3)