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
|
## groupGenerics for operations on pseries
## see ?groupGeneric
## see tests/test_groupGenerics_pseries.R for examples
##
## implemented wrappers for groups Ops, Math, Complex
##
## group generic for Summary (all, any, sum, prod, min, max, range) not needed
## as functions in this group do not change the data type
##
## groupGenerics need to be registered in NAMESPACE
##
## groupGenerics are used to allow automatic propagation to higher/lower data type
## when operations are performed on pseries,
## e.g., class c("pseries", "integer") -> c("pseries", "numeric") when a function
## takes an integer as input and outputs a numeric. Without the group generics,
## the class of the results would stay as c("pseries", "integer") while the values
## themselves are numerics. The associated test file demonstrates the behaviour,
## see tests/test_groupGenerics_pseries.R
## helper functions: remove_pseries_features and add_pseries_features
remove_pseries_features <- function(x) {
# debug:
# if (!is.pseries(x)) warning("removing pseries features now but object was not a proper pseries before")
attr(x, "index") <- NULL
# unclass is simpler and faster than previously (up to and incl. rev. 1307) used
# combination of check_propagation_correct_class() and class() <- setdiff(class(<.>), "pseries")
# unclass handles propagation and keeps names but coerces factor to integer
x <- if(!is.factor(x)) unclass(x) else { class(x) <- setdiff(class(x), "pseries"); x }
x
}
add_pseries_features <- function(x, index) {
# debug:
# if (is.null(index)) warning("'index' is null")
attr(x, "index") <- index
class(x) <- unique(c("pseries", class(x)))
return(x)
}
#' @export
Ops.pseries <- function(e1, e2) {
# print("Ops.pseries executed!") # debug output
miss_e2 <- missing(e2)
e1_pseries <- e2_pseries <- FALSE
# either one or both could be pseries
if(inherits(e1, "pseries")) {
e1_pseries <- TRUE
index_e1 <- attr(e1, "index")
e1 <- remove_pseries_features(e1)
}
if(!miss_e2 && inherits(e2, "pseries")) {
e2_pseries <- TRUE
index_e2 <- attr(e2, "index")
e2 <- remove_pseries_features(e2)
}
res <- if(!miss_e2) get(.Generic)(e1, e2) else get(.Generic)(e1)
# result could be, e.g., matrix. So check if adding back pseries features
# makes sense (e.g., do not create something of class c("pseries", "matrix")).
# Need is.atomic because is.vector is too strict, however need to sort out
# some other data types
add_back_pseries <- if(is.atomic(res) && !is.matrix(res) && !is.pairlist(res)) TRUE else FALSE
if(add_back_pseries) {
if(miss_e2 && e1_pseries) relevant_index <- index_e1
if( e1_pseries && !e2_pseries) relevant_index <- index_e1
if(!e1_pseries && e2_pseries) relevant_index <- index_e2
if( e1_pseries && e2_pseries) {
# decide on index for result:
# if objects vary in length: shorter object is recycled by R
# -> must take index of non-recycled object (= longer pseries)
#
# Also, base R uses the names of the first operand -> additional justification
# to assign index_e1 in case of same number of rows
relevant_index <- if(nrow(index_e1) >= nrow(index_e2)) index_e1 else index_e2
# do not warn anymore (since rev. 1181)
# if ((nrow(index_e1) == nrow(index_e2)) && !isTRUE(all.equal(index_e1, index_e2)))
# warning("indexes of pseries have same length but not same content: result was assigned first operand's index")
}
res <- add_pseries_features(res, relevant_index)
}
return(res)
}
#' @export
Math.pseries <- function(x, ...) {
# print("Math.pseries executed!") # debug output
index <- attr(x, "index")
x <- remove_pseries_features(x)
x <- get(.Generic)(x, ...)
x <- add_pseries_features(x, index)
return(x)
}
#' @export
Complex.pseries <- function(z) {
# print("Complex.pseries executed!") # debug output
index <- attr(z, "index")
z <- remove_pseries_features(z)
z <- get(.Generic)(z)
z <- add_pseries_features(z, index)
return(z)
}
|
