-
Notifications
You must be signed in to change notification settings - Fork 3
/
cutoff.R
64 lines (60 loc) · 1.97 KB
/
cutoff.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
to_native <- function(quantiles, space_size) {
stats::qchisq(quantiles, df = space_size - 1, lower.tail = FALSE) / 2
}
to_quantile <- function(natives, space_size) {
stats::pchisq(2 * natives, df = space_size - 1, lower.tail = FALSE)
}
guaranteed_pruning <- function(raw_cutoff, space_size, scale, raw) {
if (!raw) {
if (length(raw_cutoff) > 1) {
pre_res <- sqrt(raw_cutoff[-length(raw_cutoff)] * raw_cutoff[-1])
last_val <- 2 * raw_cutoff[length(raw_cutoff)] - pre_res[length(pre_res)]
cutoff <- c(pre_res, last_val)
} else {
cutoff <- after(raw_cutoff)
}
} else {
cutoff <- raw_cutoff
}
if (scale == "native") {
cutoff
} else {
to_quantile(cutoff, space_size)
}
}
## this function returns a vector of unique values using a relaxed the notion of
## uniqueness to account for rounding errors. The function assumes its input
## to be sorted
relaxed_unique <- function(x, tol = .Machine$double.eps^0.5) {
x[c(TRUE, abs(diff(x)) >= tol)]
}
#' Cut off values for VLMC like model
#'
#' This generic function returns one or more cut off values that are guaranteed
#' to have an effect on the `model` passed to the function when a simplification
#' procedure is applied (in general a tree pruning operation as provided by
#' [prune()]).
#'
#' The exact definition of what is a cut off value depends on the model type and
#' is documented in concrete implementation of the function.
#'
#' @param model a model.
#' @param ... additional arguments for the cutoff function implementations
#' @returns a cut off value or a vector of cut off values.
#' @examples
#' pc <- powerconsumption[powerconsumption$week == 5, ]
#' rdts <- cut(pc$active_power,
#' breaks = c(0, quantile(pc$active_power,
#' probs = c(0.25, 0.5, 0.75, 1)
#' ))
#' )
#' model <- vlmc(rdts)
#' draw(model)
#' model_cuts <- cutoff(model)
#' model_2 <- prune(model, model_cuts[2])
#' draw(model_2)
#' @seealso [prune()]
#' @export
cutoff <- function(model, ...) {
UseMethod("cutoff")
}