Merge pull request #165 from alan-turing-institute/dev

Added c.Distribution

Author: Raphael Sonabend

.appveyor.yml

@@ -56,11 +56,11 @@ environment:
     - R_VERSION: release
       R_ARCH: x64
 
-    - R_VERSION: devel
-      R_ARCH: x64
+ #   - R_VERSION: devel
+ #     R_ARCH: x64
 
-    - R_VERSION: oldrel
-      R_ARCH: x64
+ #   - R_VERSION: oldrel
+ #     R_ARCH: x64
 
 cache:
   - C:\RLibrary\

.travis.yml

@@ -7,16 +7,16 @@ branches:
 
 matrix:
   include:
+#    - os: linux
+#      r: oldrel
     - os: linux
-      r: oldrel
-    - os: linux
-      r: release
-    - os: linux
-      r: devel
-    - os: osx
-      r: oldrel
-    - os: osx
       r: release
+#    - os: linux
+#      r: devel
+#    - os: osx
+#      r: oldrel
+#    - os: osx
+#      r: release
 #    - os: osx
 #      r: devel
 

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: distr6
 Title: The Complete R6 Probability Distributions Interface
-Version: 1.3.0
+Version: 1.3.1
 Authors@R: 
       c(person(given = "Raphael",
              family = "Sonabend",
@@ -170,6 +170,7 @@ Collate:
     'Wrapper_TruncatedDistribution.R'
     'Wrapper_VectorDistribution.R'
     'assertions.R'
+    'c.Distribution.R'
     'decomposeMixture.R'
     'decorate.R'
     'distr6-deprecated.R'

NAMESPACE

@@ -7,6 +7,7 @@ S3method("[",VectorDistribution)
 S3method("^",SetInterval)
 S3method(as.ParameterSet,data.table)
 S3method(as.ParameterSet,list)
+S3method(c,Distribution)
 S3method(huberize,Distribution)
 S3method(lines,Distribution)
 S3method(mean,Distribution)

NEWS.md

@@ -1,3 +1,29 @@
+# distr6 1.3.1
+
+## Major Updates
+
+- None
+
+## Minor Updates
+
+### Added Functions and Classes
+
+- None
+
+### Deprecated Functions
+
+- None
+
+### Updated Functions
+
+- None
+
+## Patches
+
+- Added wrapper for VectorDistribution for quick concatenation of constructed distributions, `c.Distribution`
+- `VectorDistribution` `print` method more in line with base R vectors
+
+
 # distr6 1.3.0
 
 ## Major Updates

R/Wrapper_VectorDistribution.R

@@ -257,6 +257,14 @@ VectorDistribution$set("public","modelTable", function(){
   private$.wrappedModels
 })
 
+VectorDistribution$set("public", "strprint", function(n = 100){
+  names <- as.character(self$modelTable()$shortname)
+  lng <- length(names)
+  if(lng >(2*n))
+    names = c(names[1:n], "...", names[(lng-n+1):lng])
+
+  return(names)
+})
 VectorDistribution$set("public", "getParameterValue", function(...){
   message("Vector Distribution should not be used to get/set parameters. Try to use '[' first.")
   return(NULL)

R/c.Distribution.R

@@ -0,0 +1,49 @@
+#' @title Combine Distributions into a VectorDistribution
+#' @description Helper function for quickly combining distributions into a \code{\link{VectorDistribution}}.
+#' @param ... distributions to be concatenated.
+#' @param name,short_name,description,decorators See \code{\link{VectorDistribution}}
+#' @return A VectorDistribution
+#' @seealso \code{\link{VectorDistribution}}
+#' @examples
+#' # Construct and combine
+#' c(Binomial$new(), Normal$new())
+#'
+#' # More complicated distributions
+#' b = truncate(Binomial$new(), 2, 6)
+#' n = huberize(Normal$new(), -1, 1)
+#' c(b, n)
+#'
+#' # Concatenate VectorDistributions
+#' v1 = VectorDistribution$new(list(Binomial$new(), Normal$new()))
+#' v2 = VectorDistribution$new(distribution = "Gamma",
+#'              params  = data.table::data.table(shape = 1:2, rate = 1:2))
+#' c(v1, v2)
+#'
+#' @export
+c.Distribution <- function(..., name = NULL, short_name = NULL, description = NULL, decorators = NULL){
+  # Get list of inputs and assert all distributions
+  distlist = list(...)
+  assertDistributionList(distlist)
+
+  # If all distributions in the list are VectorDistributions then try and return a VectorDistribution
+  # with distribution/params constructor.
+  if (all(sapply(distlist, getR6Class) %in% "VectorDistribution")) {
+    if (any(sapply(distlist, function(x) x$distlist)))
+      return(VectorDistribution$new(unlist(lapply(distlist, function(x) x$wrappedModels()))))
+    else {
+      distribution = unlist(lapply(distlist, function(x) as.character(unlist(x$modelTable()$distribution))))
+      params = lapply(distlist, function(x) x$modelTable()$params)
+      if (length(params) != length(distribution))
+        params = unlist(params, FALSE)
+      return(VectorDistribution$new(distribution = distribution, params = params))
+    }
+  }
+
+  # If any are VectorDistributions then get the wrapped list
+  distlist = unlist(lapply(distlist, function(x)
+    ifelse(getR6Class(x) == "VectorDistribution", list(x$wrappedModels()), list(x))))
+
+  # Create VectorDistribution
+  return(VectorDistribution$new(distlist, name = name, short_name = short_name,
+                                description = description, decorators = decorators))
+}

man/c.Distribution.Rd

@@ -138,3 +138,12 @@ test_that("shared d/p/q/r",{
                                                 Binom3 = qbinom(0.42,6,0.2)))
 })
 
+test_that("print",{
+  a = VectorDistribution$new(distribution = "Binomial", params = list(list(prob = 0.1, size = 2),
+                                                                      list(prob = 0.6, size = 4),
+                                                                      list(prob = 0.2, size = 6)))
+  expect_equal(a$strprint(), c("Binom1","Binom2","Binom3"))
+  expect_equal(a$strprint(1), c("Binom1","...","Binom3"))
+  expect_output(a$print(), "Binom1")
+})
+

tests/testthat/test-VectorDistribution.R

@@ -0,0 +1,54 @@
+library(testthat)
+
+context("c.Distribution")
+
+test_that("non-distlist",{
+  expect_error(c(Binomial$new(), Binomial), "One or more...")
+  expect_silent(expect_length(c(Binomial, Binomial$new()), 2))
+})
+
+test_that("SDistributions",{
+  expect_silent(c(Binomial$new(), Normal$new()))
+  expect_equal(getR6Class(c(Binomial$new(), Normal$new())), "VectorDistribution")
+  expect_equal(c(Binomial$new(), Normal$new())$short_name, "BinomVecNorm")
+})
+
+test_that("VectorDistributions",{
+  v1 = VectorDistribution$new(list(Binomial$new(), Normal$new()))
+  v2 = VectorDistribution$new(distribution = "Gamma", params  = data.table::data.table(shape = 1:2, rate = 1:2))
+  expect_silent(c(v1, v2))
+  expect_silent(c(v1, v2, Normal$new(), truncate(Binomial$new(), 2, 6)))
+})
+
+test_that("distribution/param VectorDistributions",{
+  v1 = VectorDistribution$new(distribution = c("Binomial","Normal"),
+                              params = list(list(size = 2), list(mean = 0, var = 2)))
+  v2 = VectorDistribution$new(distribution = "Gamma", params  = data.table::data.table(shape = 1:2, rate = 1:2))
+  expect_silent(c(v1, v2))
+  v3 = c(v1, v2)
+  expect_false(v3$distlist)
+  expect_equal(v3$modelTable()$distribution, c("Binomial","Normal","Gamma","Gamma"))
+  expect_equal(v3$modelTable()$shortname, c("Binom1","Norm1","Gamma1","Gamma2"))
+  expect_equal(v3$modelTable()$params, list(list(size = 2), list(mean = 0, var = 2),
+                                            list(shape = 1, rate = 1), list(shape = 2, rate = 2)))
+})
+
+test_that("weighteddiscrete vec",{
+  v1 = VectorDistribution$new(distribution = "WeightedDiscrete",
+                              params = list(data = data.frame(x = 1, pdf = 1),
+                                            data = data.frame(x = 2, pdf = 1)))
+  v2 = VectorDistribution$new(distribution = "WeightedDiscrete",
+                              params = list(data = data.frame(x = 3, pdf = 1),
+                                            data = data.frame(x = 4, pdf = 1)))
+  expect_silent(c(v1, v2))
+})
+
+test_that("different lengths",{
+  v1 = VectorDistribution$new(distribution = "WeightedDiscrete",
+                              params = list(list(data = data.frame(x = 1, pdf = 1),
+                                            data = data.frame(x = 2, pdf = 1))))
+  v2 = VectorDistribution$new(distribution = "WeightedDiscrete",
+                              params = list(data = data.frame(x = 3, pdf = 1),
+                                            data = data.frame(x = 4, pdf = 1)))
+  expect_silent(c(v1, v2))
+})