-
Notifications
You must be signed in to change notification settings - Fork 1
/
methods.R
executable file
·238 lines (209 loc) · 6.37 KB
/
methods.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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
# Methods for DISTRIBUTION class
# 20181028 by JJAV
# # # # # # # # # # # # # # # # #
# Fields in the DISTRIBUION object are immutable and should not be changed
#' @export
`[[<-.DISTRIBUTION` <- function(..., value){
stop("Objects of class DISTRIBUTION are immutable")
}
#' @export
`[<-.DISTRIBUTION` <- function(..., value){
stop("Objects of class DISTRIBUTION are immutable")
}
#' @export
`$<-.DISTRIBUTION` <- function(..., value){
stop("Objects of class DISTRIBUTION are immutable")
}
#' Metadata for a DISTRIBUTION
#'
#' Shows the distribution and the oval values of a \code{\link{DISTRIBUTION}}
#' object
#'
#' @note The number of columns depends on the dimensions of the distribution.
#' There will be one column \code{distribution} with the name of the distribution
#' and one column for each dimension with the names from the \code{oval} field.
#'
#' @author John J. Aponte
#' @param x a \code{\link{DISTRIBUTION}} object
#' @return A \code{\link{data.frame}} with the metadata of the distributions
#' @export
metadata <- function(x) {
UseMethod("metadata",x)
}
#' @describeIn metadata Metadata for DISTRIBUTION objects
#' @importFrom dplyr bind_cols
#' @export
metadata.DISTRIBUTION <- function(x) {
dplyr::bind_cols(
data.frame(
distribution = x$distribution,
stringsAsFactors = FALSE,
row.names = NULL
),
data.frame(t(x$oval))
)
}
#' @describeIn metadata Metadata for other objects
#' @export
metadata.default <- function(x){
stop("Don't know how to make metadata for an object of class", class(x))
}
#' @export
print.DISTRIBUTION <- function(x, ...){
print(metadata(x))
invisible(x)
}
#' cinqnum
#'
#' Produce 5 numbers of the distribution (mean_, sd_, lci_, uci_, median_).
#'
#' Uses the stored seed to have the same sequence always and produce the same numbers
#' This is an internal function for the summary function
#' @author John J. Aponte
#' @param x an object of class \code{\link{DISTRIBUTION}}
#' @param ... further parameters
#' @return a vector with the mean, sd, lci, uci and median values
cinqnum <- function(x,...){
UseMethod("cinqnum",x)
}
#' @param n number of drawns
#' @import stats
#' @importFrom shiny repeatable
#' @export
#' @describeIn cinqnum Generic method for a DISTRIBUTION
cinqnum.DISTRIBUTION <- function(x,n, ...) {
cinqnum_base <- function(x,n){
draws <- x$rfunc(n)
mean_ <- apply(draws, 2, mean)
sd_ <- apply(draws, 2, sd)
lci_ <- apply(draws, 2, quantile, 0.025, na.rm = TRUE)
uci_ <- apply(draws, 2, quantile, 0.975, na.rm = TRUE)
median_ <- apply(draws, 2, median)
list(
mean_ = mean_,
sd_ = sd_,
lci_ = lci_,
uci_ = uci_,
median_ = median_
)
}
cinqnum_repeteable <- shiny::repeatable(cinqnum_base, seed = x$seed)
cinqnum_repeteable(x,n)
}
#' @export
#' @describeIn cinqnum Generic method for optimized for a NA distribution
cinqnum.NA <- function(x,n, ...) {
list(
mean_ = x$oval,
sd_ = x$oval,
sd_ = x$oval,
lci_ = x$oval,
uci_ = x$oval,
median_ = x$oval
)
}
#' @export
#' @describeIn cinqnum Generic method optimized for a DIRAC distribution
cinqnum.DIRAC <- function(x,n, ...) {
list(
mean_ = x$oval,
sd_ = 0,
sd_ = x$oval,
lci_ = x$oval,
uci_ = x$oval,
median_ = x$oval
)
}
#' Summary of Distributions
#'
#' @author John J. Aponte
#' @param object object of class \code{\link{DISTRIBUTION}}
#' @param n the number of random samples from the distribution
#' @param ... other parameters. Not used
#' @return A \code{\link{data.frame}} with as many rows as dimensions had the
#' distribution and with the following columns
#' \itemize{
#' \item distribution name
#' \item varname name of the dimension
#' \item oval value
#' \item nsample number of random samples
#' \item mean_ mean value of the sample
#' \item sd_ standard deviation of the sample
#' \item lci_ lower 95% centile of the sample
#' \item median_ median value of the sample
#' \item uci_ upper 95% centile of the sample
#' }
#' @note The sample uses the seed saved in the object those it will
#' provide the same values fir an \code{n} value
#' @export
summary.DISTRIBUTION <- function(object, n = 10000, ...) {
cinqlist <- cinqnum(object,n)
data.frame(distribution = object$distribution,
varname = names(object$oval),
oval = object$oval,
nsample = n,
mean_ = cinqlist[["mean_"]],
sd_ = cinqlist[["sd_"]],
lci_ = cinqlist[["lci_"]],
median_ = cinqlist[["median_"]],
uci_ = cinqlist[["uci_"]] ,
stringsAsFactors = FALSE,
row.names = NULL)
}
#' Generate random numbers from a \code{\link{DISTRIBUTION}} object
#'
#' This is a generic method that calls the \code{rfunc} slot of the object
#'
#' @author John J. Aponte
#' @param x an object
#' @param n the number of random samples
#' @return a matrix with as many rows as \code{n} and as many columns as
#' dimensions have \code{distribution}
#' @export
rfunc <- function(x, n) {
UseMethod("rfunc",x)
}
#' Generic function for a \code{\link{DISTRIBUTION}} object
#'
#' @author John J. Aponte
#' @param x an object of class \code{\link{DISTRIBUTION}}
#' @param n the number of random samples
#' @return a matrix with as many rows as \code{n} and as many columns as
#'
#' @export
rfunc.DISTRIBUTION <- function(x,n) {
x$rfunc(n)
}
#' Default function
#' @author John J. Aponte
#' @param x an object of class different from \code{\link{DISTRIBUTION}}
#' @param n the number of random samples
#' @return No return value. Raise an error message.
#' @export
rfunc.default <- function(x,n) {
stop("Don't know how to obtain random numbers from an object of class ", class(x))
}
#' @export
dimnames.DISTRIBUTION <- function(x) {
return(names(x$oval))
}
#' Modify a the seed of a Distribution object
#'
#' This create a new \code{\link{DISTRIBUTION}} object but with the
#' specified seed
#' @author John J. Aponte
#' @param distribution a \code{\link{DISTRIBUTION}} object
#' @param seed the new seed
#' @return a \code{\link{DISTRIBUTION}} object of the same class
#' @export
set_seed <- function(distribution, seed){
stopifnot(inherits(distribution,"DISTRIBUTION"))
stopifnot(is.numeric(seed))
stopifnot(!is.na(seed))
stopifnot(length(seed) == 1)
prevclass <- class(distribution)
xtemp <- unclass(distribution)
xtemp$seed <- seed
class(xtemp) <- prevclass
xtemp
}