/
proportional.R
146 lines (128 loc) · 4.84 KB
/
proportional.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
#' Proportion of messy dates meeting logical test
#'
#' These functions provide various proportional tests for messy date objects.
#' @name proportional
#' @param e1,e2 `mdate` or other class objects
#' @return The proportion that the comparison is true.
#' @return A logical vector the same length as the `mdate` passed.
NULL
#' @rdname proportional
#' @export
`%l%` <- function(e1, e2) UseMethod("%l%")
#' @describeIn proportional Tests proportion of dates in the first vector
#' that precede the minimum in the second vector.
#' @examples
#' as_messydate("2012-06") < as.Date("2012-06-02")
#' as_messydate("2012-06") %l% as_messydate("2012-06-02")
#' @export
`%l%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
suppressMessages(purrr::map2_dbl(expand(e1), expand(e2),
~ mean(.x < min(.y))))
}
evalqOnLoad({
registerS3method("%l%", "Date", `%l%.mdate`)
registerS3method("%l%", "POSIXt", `%l%.mdate`)
})
#' @rdname proportional
#' @export
`%g%` <- function(e1, e2) UseMethod("%g%")
#' @describeIn proportional Tests proportion of dates in the first vector
#' that follow the maximum in the second vector.
#' @export
#' @examples
#' as_messydate("2012-06") > as.Date("2012-06-02")
#' as_messydate("2012-06") %g% as_messydate("2012-06-02")
`%g%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
suppressMessages(purrr::map2_dbl(expand(e1), expand(e2),
~ mean(.x > max(.y))))
}
evalqOnLoad({
registerS3method("%g%", "Date", `%g%.mdate`)
registerS3method("%g%", "POSIXt", `%g%.mdate`)
})
#' @rdname proportional
#' @export
`%ge%` <- function(e1, e2) UseMethod("%ge%")
#' @describeIn proportional Tests proportion of dates in the first vector
#' that follow or are equal to the maximum in the second vector.
#' @export
#' @examples
#' as_messydate("2012-06") >= as.Date("2012-06-02")
#' as_messydate("2012-06") %ge% as_messydate("2012-06-02")
`%ge%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
suppressMessages(purrr::map2_dbl(expand(e1), expand(e2),
~ mean(.x >= max(.y))))
}
evalqOnLoad({
registerS3method("%ge%", "Date", `%ge%.mdate`)
registerS3method("%ge%", "POSIXt", `%ge%.mdate`)
})
#' @rdname proportional
#' @export
`%le%` <- function(e1, e2) UseMethod("%le%")
#' @describeIn proportional Tests proportion of dates in the first vector
#' that precede or are equal to the minimum in the second vector.
#' @export
#' @examples
#' as_messydate("2012-06") <= as.Date("2012-06-02")
#' as_messydate("2012-06") %le% "2012-06-02"
`%le%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
suppressMessages(purrr::map2_dbl(expand(e1), expand(e2),
~ mean(.x <= min(.y))))
}
evalqOnLoad({
registerS3method("%le%", "Date", `%le%.mdate`)
registerS3method("%le%", "POSIXt", `%le%.mdate`)
})
#' @rdname proportional
#' @export
`%><%` <- function(e1, e2) UseMethod("%><%")
#' @describeIn proportional Tests proportion of dates in the first vector
#' that are between the minimum and maximum dates in the second vector.
#' @export
#' @examples
#' as_messydate("2012-06") %><% as_messydate("2012-06-15..2012-07-15")
`%><%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
# Need to create fast way to trim ranges or just get dates within the range
suppressMessages(purrr::map2_dbl(e1, e2,
~ length(.x %intersect% .y)/
(length(unlist(expand(.x)))+1)))
}
evalqOnLoad({
registerS3method("%><%", "Date", `%><%.mdate`)
registerS3method("%><%", "POSIXt", `%><%.mdate`)
})
#' @rdname proportional
#' @export
`%>=<%` <- function(e1, e2) UseMethod("%>=<%")
#' @describeIn proportional Tests proportion of dates in the first vector that
#' are between the minimum and maximum dates in the second vector, inclusive.
#' @export
#' @examples
#' as_messydate("2012-06") %>=<% as_messydate("2012-06-15..2012-07-15")
`%>=<%.mdate` <- function(e1, e2) {
if(length(e1)!=length(e2))
stop("Can only compare vectors of equal length.")
# Need to fix this for element wise on vectors...
suppressMessages(purrr::map2_dbl(e1, e2, ~ length(.x %intersect% .y)/
length(unlist(expand(.x)))))
}
evalqOnLoad({
registerS3method("%>=<%", "Date", `%>=<%.mdate`)
registerS3method("%>=<%", "POSIXt", `%>=<%.mdate`)
})