Merge pull request #252 from alan-turing-institute/as_distribution

add as.Distribution.matrix

Author: Raphael Sonabend

.gitignore

@@ -10,3 +10,7 @@ Meta
 docs/
 revdep/
 CRAN-RELEASE
+.vscode/
+*.o
+*.so
+*.dll

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: distr6
 Title: The Complete R6 Probability Distributions Interface
-Version: 1.5.3
+Version: 1.5.4
 Authors@R:
       c(person(given = "Raphael",
              family = "Sonabend",
@@ -172,6 +172,7 @@ Collate:
     'Wrapper_Scale.R'
     'Wrapper_TruncatedDistribution.R'
     'Wrapper_VectorDistribution.R'
+    'as.Distribution.R'
     'assertions.R'
     'c.Distribution.R'
     'decomposeMixture.R'

NAMESPACE

@@ -5,6 +5,7 @@ S3method("+",Distribution)
 S3method("-",Distribution)
 S3method("[",ParameterSet)
 S3method("[",VectorDistribution)
+S3method(as.Distribution,matrix)
 S3method(as.ParameterSet,data.table)
 S3method(as.ParameterSet,list)
 S3method(as.data.table,ParameterSet)
@@ -96,6 +97,7 @@ export(VectorDistribution)
 export(Wald)
 export(Weibull)
 export(WeightedDiscrete)
+export(as.Distribution)
 export(as.MixtureDistribution)
 export(as.ParameterSet)
 export(as.ProductDistribution)

NEWS.md

@@ -1,3 +1,12 @@
+# distr6 1.5.4
+
+* Added `as.Distribution.matrix` for converting matrices to a `VectorDistribution` of `WeightedDiscrete` distributions
+* Added `...` to `dstrs` to allow decorator argument to be passed through
+
+# distr6 1.5.3
+
+* Internal changes only
+
 # distr6 1.5.2
 
 * Fixed bug in extracting distributions from vector distributions

R/Distribution.R

@@ -451,7 +451,7 @@ Distribution <- R6Class("Distribution",
         if (private$.log) {
           pdqr <- private$.pdf(data, log = log)
         } else {
-          if (!("CoreStatistics" %in% self$decorators)) {
+          if ("CoreStatistics" %nin% self$decorators) {
             stop("No analytical method for log available.
 Use CoreStatistics decorator to numerically estimate this.")
           } else {
@@ -522,7 +522,7 @@ Use CoreStatistics decorator to numerically estimate this.")
         if (private$.log) {
           pdqr <- private$.cdf(data, log.p = log.p, lower.tail = lower.tail)
         } else {
-          if (!("CoreStatistics" %in% self$decorators)) {
+          if ("CoreStatistics" %nin% self$decorators) {
             stop("No analytical method for log.p or lower.tail available. Use CoreStatistics
 decorator to numerically estimate this.")
           } else {
@@ -589,7 +589,7 @@ decorator to numerically estimate this.")
         if (private$.log) {
           pdqr <- private$.quantile(data, log.p = log.p, lower.tail = lower.tail)
         } else {
-          if (!("CoreStatistics" %in% self$decorators)) {
+          if ("CoreStatistics" %nin% self$decorators) {
             stop("No analytical method for log.p or lower.tail available. Use CoreStatistics
 decorator to numerically estimate this.")
           } else {

R/ParameterSet.R

@@ -128,7 +128,7 @@ ParameterSet <- R6Class("ParameterSet",
     print = function(hide_cols = c("settable"), ...) {
       ps <- private$.parameters
       ps$support <- lapply(ps$support, function(x) x$strprint())
-      print(subset(ps, select = !(names(ps) %in% hide_cols)))
+      print(subset(ps, select = names(ps) %nin% hide_cols))
     },
 
     #' @description

R/ParameterSetCollection.R

@@ -58,7 +58,7 @@ ParameterSetCollection <- R6Class("ParameterSetCollection",
     print = function(hide_cols = c("settable"), ...) {
       psc <- as.data.table(self)
       psc$support <- lapply(psc$support, function(x) x$strprint())
-      print(subset(psc, select = !(names(psc) %in% hide_cols)))
+      print(subset(psc, select = names(psc) %nin% hide_cols))
     },
 
     #' @description

R/Wrapper_VectorDistribution.R

@@ -223,10 +223,10 @@ or `distlist` should be used.")
 
             if (!is.null(shared_params)) {
               if (distribution == "Geometric") {
-                shared_params <- shared_params[!(names(shared_params) %in% "trials")]
+                shared_params <- shared_params[names(shared_params) %nin% "trials"]
               }
               if (distribution == "NegativeBinomial") {
-                shared_params <- shared_params[!(names(shared_params) %in% "form")]
+                shared_params <- shared_params[names(shared_params) %nin% "form"]
               }
               shared_params <- rep(list(shared_params), length(params))
               names(shared_params) <- names(paramlst)

R/as.Distribution.R

@@ -0,0 +1,50 @@
+#' @title Coerce matrix to vector of WeightedDiscrete
+#' @description Coerces matrices to a [VectorDistribution] containing
+#' [WeightedDiscrete] distributions. Number of distributions are the number
+#' of rows in the matrix, number of `x` points are number of columns in the
+#' matrix.
+#' @param obj [matrix]. Column names correspond to `x` in [WeightedDiscrete],
+#' so this method only works if all distributions (rows in the matrix) have the
+#' same points to be evaluated on. Elements correspond to either the pdf
+#' or cdf of the distribution (see below).
+#' @param fun Either `"pdf"` or `"cdf"`, passed to [WeightedDiscrete] and tells
+#' the constructor if the elements in `obj` correspond to the pdf or cdf of
+#' the distribution.
+#' @param decorators Passed to [VectorDistribution].
+#' @return A [VectorDistribution]
+#' @export
+#' @examples
+#' pdf <- runif(200)
+#' mat <- matrix(pdf, 20, 10)
+#' mat <- t(apply(mat, 1, function(x) x / sum(x)))
+#' colnames(mat) <- 1:10
+#' as.Distribution(mat, fun = "pdf")
+as.Distribution <- function(obj, fun, decorators = NULL) {
+  UseMethod("as.Distribution")
+}
+
+#' @rdname as.Distribution
+#' @export
+as.Distribution.matrix <- function(obj, fun, decorators = NULL) {
+  if (is.null(colnames(obj))) {
+    stop("'obj' must have column names")
+  }
+
+  if (fun %nin% c("pdf", "cdf")) {
+    stop("'fun' should be one of 'pdf', 'cdf'")
+  }
+
+  x <- as.numeric(colnames(obj))
+  obj <- apply(obj, 1, function(.x) {
+    out <- list(.x)
+    names(out) <- fun
+    out
+  })
+
+  VectorDistribution$new(
+    distribution = "WeightedDiscrete",
+    params = obj,
+    shared_params = list(x = x),
+    decorators = decorators
+  )
+}

R/helpers.R

@@ -1,3 +1,7 @@
+`%nin%` <- function(x, table) {
+  !(x %in% table)
+}
+
 assertThat <- function(x, cond, errormsg) {
   if (cond) {
     invisible(x)
@@ -215,7 +219,7 @@ getR6Call <- function() {
   calls <- as.list(match.call(definition = sys.function(sys.parent(2L)),
                  call = sys.call(sys.parent(3L)),
                  envir = parent.frame(4L)))[-1]
-  calls <- calls[!(names(calls) %in% "decorators")]
+  calls <- calls[names(calls) %nin% "decorators"]
   # prevent lazy evaluation
   lapply(calls, eval.parent, n = 5)
 }

R/helpers_pdq.R

@@ -64,7 +64,7 @@ pdqr_returner <- function(pdqr, simplify, name) {
 call_C_base_pdqr <- function(fun, x, args, lower.tail = TRUE, log = FALSE, vec) {
   type <- substr(fun, 1, 1)
 
-  if (!(type %in% c("d", "p", "q", "r"))) {
+  if (type %nin% c("d", "p", "q", "r")) {
     stop("Function must start with one of: {d, p, q, r}.")
   }
 

R/lines.R

@@ -63,19 +63,19 @@ lines.Distribution <- function(x, fun, npoints = 3000, ...) {
   if ("cdf" %in% fun & is.null(x$.__enclos_env__$private$.cdf)) {
     message("This distribution does not have a cdf expression. Use the
             FunctionImputation decorator to impute a numerical cdf.")
-    fun <- fun[!(fun %in% c("cdf", "survival", "hazard", "cumhazard"))]
+    fun <- fun[fun %nin% c("cdf", "survival", "hazard", "cumhazard")]
   }
 
   if ("pdf" %in% fun & is.null(x$.__enclos_env__$private$.pdf)) {
     message("This distribution does not have a pdf expression. Use the
             FunctionImputation decorator to impute a numerical pdf.")
-    fun <- fun[!(fun %in% c("pdf", "hazard"))]
+    fun <- fun[fun %nin% c("pdf", "hazard")]
   }
 
   if ("quantile" %in% fun & is.null(x$.__enclos_env__$private$.quantile)) {
     message("This distribution does not have a quantile expression. Use the
             FunctionImputation decorator to impute a numerical quantile.")
-    fun <- fun[!(fun %in% c("quantile"))]
+    fun <- fun[fun %nin% c("quantile")]
   }
 
   if (length(fun) == 0) {

R/plot_distribution.R

@@ -83,19 +83,19 @@ plot.Distribution <- function(x, fun = c("pdf", "cdf"), npoints = 3000,
   if (any(c("cdf", "survival", "hazard", "cumhazard") %in% fun) & !isCdf(x)) {
     message("This distribution does not have a cdf expression.
 Use the FunctionImputation decorator to impute a numerical cdf.")
-    fun <- fun[!(fun %in% c("cdf", "survival", "hazard", "cumhazard"))]
+    fun <- fun[fun %nin% c("cdf", "survival", "hazard", "cumhazard")]
   }
 
   if (any(c("pdf", "hazard") %in% fun) & !isPdf(x)) {
     message("This distribution does not have a pdf expression.
 Use the FunctionImputation decorator to impute a numerical pdf.")
-    fun <- fun[!(fun %in% c("pdf", "hazard"))]
+    fun <- fun[fun %nin% c("pdf", "hazard")]
   }
 
   if (("quantile" %in% fun) & !isQuantile(x)) {
     message("This distribution does not have a quantile expression.
 Use the FunctionImputation decorator to impute a numerical quantile.")
-    fun <- fun[!(fun %in% c("quantile"))]
+    fun <- fun[fun %nin% c("quantile")]
   }
 
   if (length(fun) == 0) {
@@ -132,7 +132,7 @@ Use the FunctionImputation decorator for better accuracy.")
     }
 
     if (any(c("cdf", "survival", "hazard", "cumhazard", "quantile") %in% fun) &
-      !("cdf" %in% colnames(plotStructure))) {
+      "cdf" %nin% colnames(plotStructure)) {
       plotStructure$cdf <- x$cdf(plotStructure$points)
     }
     if (any(c("pdf", "hazard") %in% fun)) {

R/simulateEmpiricalDistribution.R

@@ -19,7 +19,7 @@
 #' @export
 simulateEmpiricalDistribution <- function(EmpiricalDist, n, seed = NULL) {
 
-  if (!(getR6Class(EmpiricalDist) %in% c("Empirical", "EmpiricalMV"))) {
+  if (getR6Class(EmpiricalDist) %nin% c("Empirical", "EmpiricalMV")) {
     stop("For Distributions that are not Empirical use $rand.")
   }
 

R/sugar.R

@@ -59,18 +59,18 @@ dstr <- function(d, ..., pars = NULL) {
 
 #' @rdname dstr
 #' @export
-dstrs <- function(d, pars = NULL) {
+dstrs <- function(d, pars = NULL, ...) {
 
   if (length(d) == 1) {
     if (is.null(pars)) {
       stop("pars' cannot be NULL if 'd' is length 1.")
     } else {
-      VectorDistribution$new(distribution = d, params = pars)
+      VectorDistribution$new(distribution = d, params = pars, ...)
     }
   } else {
     if (is.null(pars)) {
       pars <- vector("list", length(d))
     }
-    VectorDistribution$new(mapply(dstr, d, pars = pars))
+    VectorDistribution$new(mapply(dstr, d, pars = pars, ...))
   }
 }

man/as.Distribution.Rd

@@ -258,11 +258,11 @@ autotest_vec_sdistribution <- function(sdist, pars) {
   } else {
     if (sdist$name == "Geometric" & !is.null(pars$trials)) {
       vdist <- VectorDistribution$new(distribution = sdist$name,
-                                      params = rep(list(pars[!(names(pars) %in% "trials")]), 3),
+                                      params = rep(list(pars[names(pars) %nin% "trials"]), 3),
                                       shared_params = list(trials = pars$trials))
     } else if (sdist$name == "NegativeBinomial" & !is.null(pars$form)) {
       vdist <- VectorDistribution$new(distribution = sdist$name,
-                                      params = rep(list(pars[!(names(pars) %in% "form")]), 3),
+                                      params = rep(list(pars[names(pars) %nin% "form"]), 3),
                                       shared_params = list(form = pars$form))
     } else {
       vdist <- VectorDistribution$new(distribution = sdist$name,
@@ -476,3 +476,8 @@ expect_equal_distribution <- function(d1, d2) {
   p2$support <- rsapply(p2$support, "strprint")
   expect_equal(p1, p2)
 }
+
+expect_distribution <- function(d, class) {
+  expect_is(d, "Distribution")
+  expect_is(d, "Distribution")
+}