-
Notifications
You must be signed in to change notification settings - Fork 2
/
s4-ConvexCombinationOfBernsteinFunctions.R
176 lines (168 loc) · 4.69 KB
/
s4-ConvexCombinationOfBernsteinFunctions.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
#' Class for convex combinations of Bernstein functions
#'
#' Bernstein functions are stable under convex combinations, i.e. if
#' \eqn{\psi_1, \ldots, \psi_n} are Bernstein functions and
#' \eqn{c_1, \ldots, c_n > 0} are positive real values,
#' \deqn{
#' x \mapsto c_1 \psi_1(x) + \cdots + c_n \psi_n(x) , x>0,
#' }
#' is also a Bernstein function.
#'
#' @slot coefficients Numeric vector of positive real values.
#' @slot points List of Bernstein functions.
#'
#' @seealso [calcIterativeDifference()], [calcShockArrivalIntensities()],
#' [calcExShockArrivalIntensities()], [calcExShockSizeArrivalIntensities()],
#' [calcMDCMGeneratorMatrix()], [rextmo()], [rpextmo()]
#'
#' @docType class
#' @name ConvexCombinationOfBernsteinFunctions-class
#' @rdname ConvexCombinationOfBernsteinFunctions-class
#' @aliases ConvexCombinationOfBernsteinFunctions
#' @include s4-BernsteinFunction.R
#' @family Bernstein function classes
#' @family Bernstein function transformer classes
#' @export ConvexCombinationOfBernsteinFunctions
#' @examples
#' # Create an object of class ConvexCombinationOfBernsteinFunctions
#' ConvexCombinationOfBernsteinFunctions()
#' ConvexCombinationOfBernsteinFunctions(
#' coefficients = c(0.2, 0.5, 0.1),
#' points = list(
#' LinearBernsteinFunction(scale = 0.2),
#' ConstantBernsteinFunction(constant = 0.5),
#' AlphaStableBernsteinFunction(alpha = 0.5))
#' )
ConvexCombinationOfBernsteinFunctions <- setClass( # nolint
"ConvexCombinationOfBernsteinFunctions",
contains = "BernsteinFunction",
slots = c(
coefficients = "numeric",
points = "list"
)
)
#' @rdname hidden_aliases
#'
#' @inheritParams methods::initialize
#' @param coefficients Derives from
#' [ConvexCombinationOfBernsteinFunctions-class].
#' @param points Derives from [ConvexCombinationOfBernsteinFunctions-class].
setMethod(
"initialize",
"ConvexCombinationOfBernsteinFunctions",
function(.Object, coefficients, points) { # nolint
if (!(missing(coefficients) || missing(points))) {
.Object@coefficients <- coefficients # nolint
.Object@points <- points # nolint
validObject(.Object)
}
invisible(.Object)
}
)
#' @include error.R
#' @importFrom checkmate qtest test_list
setValidity(
"ConvexCombinationOfBernsteinFunctions",
function(object) {
if (!qtest(object@coefficients, "R+(0,)")) {
return(error_msg_domain("coefficients", "R+(0,)"))
}
if (!(
test_list(
object@points,
types = "BernsteinFunction",
any.missing = FALSE,
len = length(object@coefficients)
) &&
all(
sapply(
object@points,
function(object) {
isTRUE(
validObject(
object,
test = TRUE, complete = TRUE
)
)
}
)
))) {
return(
error_msg_domain(
"points",
sprintf(
"list of valid Bernstein functions of length %i",
length(object@coefficients)
)
)
)
}
invisible(TRUE)
}
)
#' @rdname hidden_aliases
#'
#' @inheritParams methods::show
#'
#' @importFrom utils capture.output
#' @export
setMethod( # nocov start
"show",
"ConvexCombinationOfBernsteinFunctions",
function(object) {
cat(sprintf("An object of class %s\n", classLabel(class(object))))
if (isTRUE(validObject(object, test = TRUE))) {
for (i in seq_along(object@coefficients)) {
cat(
sprintf(
"- coefficient: %s\n", format(object@coefficients[[i]])
)
)
cat("- point:\n")
writeLines(
paste0("\t", capture.output(show(object@points[[i]])))
)
}
} else {
cat("\t (invalid or not initialized)\n")
}
invisible(NULL)
}
) # nocov end
#' @rdname hidden_aliases
#'
#' @inheritParams calcValue
#'
#' @include s4-calcValue.R
#' @export
setMethod(
"calcValue", "ConvexCombinationOfBernsteinFunctions",
function(object, x, cscale = 1, ...) {
calcIterativeDifference(object, x, cscale = cscale)
}
)
#' @rdname hidden_aliases
#'
#' @inheritParams calcIterativeDifference
#'
#' @include s4-calcIterativeDifference.R
#' @export
setMethod(
"calcIterativeDifference",
"ConvexCombinationOfBernsteinFunctions",
function(object, x, difference_order = 0L, n = 1L, k = 0L, cscale = 1, ...) { # nolint
drop(
t(object@coefficients) %*%
drop(t(sapply(
object@points,
calcIterativeDifference,
x = x,
difference_order = difference_order,
n = n,
k = k,
cscale = cscale,
...
)))
)
}
)