Skip to content

Commit 8455333

Browse files
author
Raphael Sonabend
committed
add rep.Distribution
 Branch: master
1 parent 567720a commit 8455333

22 files changed

+273
-52
lines changed

‎DESCRIPTION

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,8 @@ Suggests:
8282
actuar,
8383
plotly,
8484
pracma
85+
Remotes:
86+
xoopR/set6
8587
License: MIT + file LICENSE
8688
LazyData: true
8789
URL: https://alan-turing-institute.github.io/distr6/, https://github.com/alan-turing-institute/distr6/
@@ -198,6 +200,7 @@ Collate:
198200
'plot_multivariate.R'
199201
'plot_vectordistribution.R'
200202
'qqplot.R'
203+
'rep.Distribution.R'
201204
'sets.R'
202205
'simulateEmpiricalDistribution.R'
203206
'skewType.R'

‎NAMESPACE

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ S3method(plot,Distribution)
2020
S3method(plot,VectorDistribution)
2121
S3method(print,ParameterSet)
2222
S3method(quantile,Distribution)
23+
S3method(rep,Distribution)
2324
S3method(summary,Distribution)
2425
S3method(truncate,Distribution)
2526
export(Arcsine)

‎NEWS.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,8 @@
11
# distr6 1.4.7
22

33
* Patch for set6
4+
* Add `rep.Distribution` for replicating distributions into vectors, mixtures, or products
5+
* Kernels can now be used with vectors/mixtures/products
46

57
# distr6 1.4.6
68

‎R/Distribution_Kernel.R

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -33,7 +33,7 @@ Kernel <- R6Class("Kernel",
3333
},
3434

3535
#' @description
36-
#' Calculates the mode of the distibution.
36+
#' Calculates the mode of the distribution.
3737
mode = function(which = "all") {
3838
return(0)
3939
},
@@ -67,7 +67,15 @@ Kernel <- R6Class("Kernel",
6767
#' are the distribution support limits.
6868
cdfSquared2Norm = function(x = 0, upper = Inf) {
6969
return(NULL)
70-
}
70+
},
71+
72+
#' @description
73+
#' The skewness of a distribution is defined by the third standardised moment,
74+
#' \deqn{sk_X = E_X[\frac{x - \mu}{\sigma}^3]}{sk_X = E_X[((x - \mu)/\sigma)^3]}
75+
#' where \eqn{E_X} is the expectation of distribution X, \eqn{\mu} is the mean of the
76+
#' distribution and \eqn{\sigma} is the standard deviation of the distribution.
77+
#' @param ... Unused.
78+
skewness = function(...) return(0)
7179
),
7280

7381
private = list(
@@ -77,7 +85,7 @@ Kernel <- R6Class("Kernel",
7785
.isRand = 1L,
7886
.log = TRUE,
7987
.traits = list(valueSupport = "continuous", variateForm = "univariate"),
80-
.properties = list(kurtosis = NULL, skewness = NULL, symmetric = "symmetric"),
88+
.properties = list(kurtosis = NULL, skewness = 0, symmetric = "symmetric"),
8189
.rand = function(n) {
8290
if (!is.null(private$.quantile)) {
8391
return(self$quantile(runif(n)))

‎R/ParameterSetCollection.R

Lines changed: 24 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -34,15 +34,18 @@ ParameterSetCollection <- R6Class("ParameterSetCollection",
3434
if (is.null(lst)) {
3535
lst <- list(...)
3636
}
37-
checkmate::assertNames(names(lst), type = "strict")
38-
assertParameterSetList(lst)
39-
private$.parametersets <- lst
40-
if (!is.null(.checks)) {
41-
private$.checks <- .checks
42-
}
43-
if (!is.null(.supports)) {
44-
private$.supports <- .supports
37+
if (length(lst)) {
38+
checkmate::assertNames(names(lst), type = "strict")
39+
assertParameterSetList(lst)
40+
private$.parametersets <- lst
41+
if (!is.null(.checks)) {
42+
private$.checks <- .checks
43+
}
44+
if (!is.null(.supports)) {
45+
private$.supports <- .supports
46+
}
4547
}
48+
4649
invisible(self)
4750
},
4851

@@ -262,15 +265,20 @@ ParameterSetCollection <- R6Class("ParameterSetCollection",
262265
as.data.table.ParameterSetCollection <- function(x, ...) {
263266
paramsets <- x$.__enclos_env__$private$.parametersets
264267

265-
lst <- unlist(lapply(paramsets, function(.x) {
266-
r = as.data.table(.x)
267-
list(r, nrow(r))
268-
}), recursive = FALSE)
268+
if (length(paramsets)) {
269+
lst <- unlist(lapply(paramsets, function(.x) {
270+
r = as.data.table(.x)
271+
list(r, nrow(r))
272+
}), recursive = FALSE)
269273

270-
dt <- data.table::rbindlist(lst[seq.int(1, length(lst), 2)])
271-
dt$id <- paste(rep(names(paramsets),
272-
times = as.numeric(lst[seq.int(2, length(lst), 2)])),
273-
dt$id, sep = "_")
274+
dt <- data.table::rbindlist(lst[seq.int(1, length(lst), 2)])
275+
dt$id <- paste(rep(names(paramsets),
276+
times = as.numeric(lst[seq.int(2, length(lst), 2)])),
277+
dt$id, sep = "_")
278+
} else {
279+
dt <- data.table::data.table(id = character(), value = numeric(), support= list(),
280+
description = character())
281+
}
274282

275283
return(dt)
276284
}

‎R/Wrapper.R

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -75,6 +75,7 @@ DistributionWrapper <- R6Class("DistributionWrapper",
7575
names(params) <- names(distlist)
7676
paramlst <- c(paramlst, params)
7777
}
78+
if (is.null(unlist(paramlst))) paramlst <- NULL
7879

7980
if (!is.null(private$.outerParameters)) {
8081
outerlst <- list(private$.outerParameters)

‎R/Wrapper_VectorDistribution.R

Lines changed: 114 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -149,7 +149,8 @@ VectorDistribution <- R6Class("VectorDistribution",
149149
stop("Either distlist or distribution and params must be provided.")
150150
}
151151

152-
distribution <- match.arg(distribution, listDistributions(simplify = TRUE))
152+
distribution <- match.arg(distribution, c(listDistributions(simplify = TRUE),
153+
listKernels(simplify = TRUE)))
153154

154155
if (grepl("Empirical", distribution)) {
155156
stop("Empirical and EmpiricalMV not currently available for `distribution/params`
@@ -183,36 +184,44 @@ or `distlist` should be used.")
183184
}
184185

185186
# create wrapper parameters by cloning distribution parameters and setting by given params
187+
# skip if no parameters
186188
pdist <- get(distribution)
187-
p <- do.call(paste0("getParameterSet.", distribution), c(params[[1]], shared_params))
188-
189-
paramlst <- vector("list", length(params))
190-
for (i in seq_along(params)) {
191-
paramlst[[i]] <- p$clone(deep = TRUE)
192-
}
193-
194-
names(paramlst) <- makeUniqueNames(rep(pdist$public_fields$short_name, length(params)))
195-
names(params) <- names(paramlst)
196-
params <- unlist(params, recursive = FALSE)
197-
names(params) <- gsub(".", "_", names(params), fixed = TRUE)
198-
if (!is.null(shared_params)) {
199-
if (distribution == "Geometric") {
200-
shared_params <- shared_params[!(names(shared_params) %in% "trials")]
189+
p <- try(do.call(paste0("getParameterSet.", distribution), c(params[[1]], shared_params)),
190+
silent = TRUE)
191+
if (class(p)[[1]] != "try-error") {
192+
paramlst <- vector("list", length(params))
193+
for (i in seq_along(params)) {
194+
paramlst[[i]] <- p$clone(deep = TRUE)
201195
}
202-
if (distribution == "NegativeBinomial") {
203-
shared_params <- shared_params[!(names(shared_params) %in% "form")]
196+
197+
names(paramlst) <- makeUniqueNames(rep(pdist$public_fields$short_name, length(params)))
198+
names(params) <- names(paramlst)
199+
params <- unlist(params, recursive = FALSE)
200+
names(params) <- gsub(".", "_", names(params), fixed = TRUE)
201+
if (!is.null(shared_params)) {
202+
if (distribution == "Geometric") {
203+
shared_params <- shared_params[!(names(shared_params) %in% "trials")]
204+
}
205+
if (distribution == "NegativeBinomial") {
206+
shared_params <- shared_params[!(names(shared_params) %in% "form")]
207+
}
208+
shared_params <- rep(list(shared_params), length(params))
209+
names(shared_params) <- names(paramlst)
210+
shared_params <- unlist(shared_params, recursive = FALSE)
211+
names(shared_params) <- gsub(".", "_", names(shared_params), fixed = TRUE)
212+
params <- c(params, shared_params)
204213
}
205-
shared_params <- rep(list(shared_params), length(params))
206-
names(shared_params) <- names(paramlst)
207-
shared_params <- unlist(shared_params, recursive = FALSE)
208-
names(shared_params) <- gsub(".", "_", names(shared_params), fixed = TRUE)
209-
params <- c(params, shared_params)
214+
215+
support <- subset(as.data.table(p), select = c(id, support))
216+
support[, support := sapply(support, set6::setpower, power = length(paramlst))]
217+
parameters <- ParameterSetCollection$new(lst = paramlst, .checks = p$checks,
218+
.supports = support)$setParameterValue(lst = params)
219+
} else {
220+
paramlst <- vector("list", length(params))
221+
names(paramlst) <- makeUniqueNames(rep(pdist$public_fields$short_name, length(params)))
222+
parameters <- ParameterSetCollection$new()
210223
}
211224

212-
support <- subset(as.data.table(p), select = c(id, support))
213-
support[, support := sapply(support, set6::setpower, power = length(paramlst))]
214-
parameters <- ParameterSetCollection$new(lst = paramlst, .checks = p$checks,
215-
.supports = support)$setParameterValue(lst = params)
216225
shortname <- get(distribution)$public_fields$short_name
217226

218227
# modelTable is for reference and later
@@ -223,8 +232,16 @@ or `distlist` should be used.")
223232

224233
# set univariate flag for calling d/p/q/r
225234
private$.univariate <- pdist$private_fields$.traits$variateForm == "univariate"
235+
# inheritance catch
236+
if (!length(private$.univariate)) {
237+
private$.univariate <- pdist$get_inherit()$private_fields$.trait$variateForm == "univariate"
238+
}
226239
# set valueSupport
227240
valueSupport <- pdist$private_fields$.traits$valueSupport
241+
# inheritance catch
242+
if (!length(valueSupport)) {
243+
valueSupport <- pdist$get_inherit()$private_fields$.trait$valueSupport
244+
}
228245

229246
# set d/p/q/r if non-NULL
230247
pdist_pri <- pdist[["private_methods"]]
@@ -369,16 +386,22 @@ or `distlist` should be used.")
369386
stopifnot(distlist[[i]]$traits$variateForm == vf)
370387
shortname <- c(shortname, distlist[[i]]$short_name)
371388
distribution <- c(distribution, distlist[[i]]$name)
372-
paramlst[[i]] <- distlist[[i]]$parameters()
389+
if (!is.null(distlist[[i]]$parameters()))
390+
paramlst[[i]] <- distlist[[i]]$parameters()
373391
vs <- c(vs, distlist[[i]]$traits$valueSupport)
374392
}
375393
valueSupport <- if (length(unique(vs)) == 1) vs[[1]] else "mixture"
376394
shortname <- makeUniqueNames(shortname)
377-
names(paramlst) <- shortname
378-
names(distlist) <- shortname
379395

380-
# create parameterset
381-
parameters <- ParameterSetCollection$new(lst = paramlst)
396+
if (is.null(unlist(paramlst))) {
397+
parameters <- ParameterSetCollection$new()
398+
paramlst <- NULL
399+
} else {
400+
names(paramlst) <- shortname
401+
parameters <- ParameterSetCollection$new(lst = paramlst)
402+
}
403+
404+
names(distlist) <- shortname
382405

383406
private$.univariate <- vf == "univariate"
384407

@@ -451,7 +474,8 @@ or `distlist` should be used.")
451474

452475
# create name, short_name, description, type, support
453476
dst <- unique(self$modelTable$Distribution)
454-
if (length(dst) == 1 & dst[[1]] %in% listDistributions(simplify = TRUE)) {
477+
if (length(dst) == 1 & dst[[1]] %in% c(listDistributions(simplify = TRUE),
478+
listKernels(simplify = TRUE))) {
455479
distribution <- get(as.character(unlist(self$modelTable[1, 1])))
456480
if (is.null(name)) {
457481
name <- paste0(
@@ -498,6 +522,7 @@ or `distlist` should be used.")
498522
parameters = parameters,
499523
...
500524
)
525+
501526
}
502527
},
503528

@@ -566,8 +591,18 @@ or `distlist` should be used.")
566591
})
567592
} else {
568593
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$mean
594+
if (is.null(f)) {
595+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
596+
public_methods$mean
597+
}
598+
if (is.null(f)) {
599+
stop("Not implemented for this distribution.")
600+
}
569601
formals(f) <- c(list(self = self), alist(... = ))
570602
ret <- f()
603+
if (length(ret) == 1) {
604+
ret <- rep(ret, nrow(self$modelTable))
605+
}
571606
}
572607

573608
if (is.null(dim(ret))) {
@@ -589,8 +624,18 @@ or `distlist` should be used.")
589624
})
590625
} else {
591626
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$mode
627+
if (is.null(f)) {
628+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
629+
public_methods$mode
630+
}
631+
if (is.null(f)) {
632+
stop("Not implemented for this distribution.")
633+
}
592634
formals(f) <- list(self = self, which = which)
593635
ret <- f()
636+
if (length(ret) == 1) {
637+
ret <- rep(ret, nrow(self$modelTable))
638+
}
594639
}
595640

596641
if (is.null(dim(ret))) {
@@ -624,8 +669,18 @@ or `distlist` should be used.")
624669
})
625670
} else {
626671
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$variance
672+
if (is.null(f)) {
673+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
674+
public_methods$variance
675+
}
676+
if (is.null(f)) {
677+
stop("Not implemented for this distribution.")
678+
}
627679
formals(f) <- c(list(self = self), alist(... = ))
628680
ret <- f()
681+
if (length(ret) == 1) {
682+
ret <- rep(ret, nrow(self$modelTable))
683+
}
629684
}
630685

631686
if (is.null(dim(ret))) {
@@ -648,8 +703,18 @@ or `distlist` should be used.")
648703
})
649704
} else {
650705
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$skewness
706+
if (is.null(f)) {
707+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
708+
public_methods$skewness
709+
}
710+
if (is.null(f)) {
711+
stop("Not implemented for this distribution.")
712+
}
651713
formals(f) <- c(list(self = self), alist(... = ))
652714
ret <- f()
715+
if (length(ret) == 1) {
716+
ret <- rep(ret, nrow(self$modelTable))
717+
}
653718
}
654719

655720
names(ret) <- as.character(unlist(private$.modelTable[, "shortname"]))
@@ -668,8 +733,18 @@ or `distlist` should be used.")
668733
})
669734
} else {
670735
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$kurtosis
736+
if (is.null(f)) {
737+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
738+
public_methods$kurtosis
739+
}
740+
if (is.null(f)) {
741+
stop("Not implemented for this distribution.")
742+
}
671743
formals(f) <- c(list(self = self, excess = excess), alist(... = ))
672744
ret <- f()
745+
if (length(ret) == 1) {
746+
ret <- rep(ret, nrow(self$modelTable))
747+
}
673748
}
674749

675750
names(ret) <- as.character(unlist(private$.modelTable[, "shortname"]))
@@ -687,8 +762,15 @@ or `distlist` should be used.")
687762
})
688763
} else {
689764
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$public_methods$entropy
765+
if (is.null(f)) {
766+
f <- get(as.character(unlist(self$modelTable$Distribution[[1]])))$get_inherit()$
767+
public_methods$entropy
768+
}
690769
formals(f) <- c(list(self = self, base = base), alist(... = ))
691770
ret <- f()
771+
if (length(ret) == 1) {
772+
ret <- rep(ret, nrow(self$modelTable))
773+
}
692774
}
693775

694776
names(ret) <- as.character(unlist(private$.modelTable[, "shortname"]))

0 commit comments

Comments
 (0)