-
Notifications
You must be signed in to change notification settings - Fork 23
/
general.functions.R
213 lines (207 loc) · 7.67 KB
/
general.functions.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
#' Check that the conversion to a data type does not change the number
#' of NA values
#'
#' @param x the value to convert
#' @param FUN the function to use for conversion
#' @param \dots arguments passed to `FUN`
#' @return `FUN(x, ...)` or an error if the set of NAs change.
#' @export
check.conversion <- function(x, FUN, ...) {
ret <- FUN(x, ...)
new.na <- sum(is.na(x) != is.na(ret))
if (new.na != 0)
# FIXME: It would be nice to have it give the function name as
# part of the error
stop(sprintf("%g new NA value(s) created during conversion",
new.na))
ret
}
#' Round a value to a defined number of digits printing out trailing zeros, if
#' applicable.
#'
#' @param x The number to round
#' @param digits integer indicating the number of decimal places
#' @param sci_range See help for [signifString()] (and you likely want
#' to round with `signifString` if you want to use this argument)
#' @param sci_sep The separator to use for scientific notation strings
#' (typically this will be either "e" or "x10^" for computer- or
#' human-readable output).
#' @param si_range Deprecated, please use `sci_range`
#' @return A string with the value
#' @details Values that are not standard numbers like `Inf`, `NA`, and
#' `NaN` are returned as `"Inf"`, `"NA"`, and `NaN`.
#' @seealso [round()], [signifString()]
#' @export
roundString <- function(x, digits=0, sci_range=Inf, sci_sep="e", si_range) {
if (!missing(si_range)) {
.Deprecated(new="roundString with the sci_range argument",
msg="The si_range argument is deprecated, please use sci_range")
sci_range <- si_range
}
if (length(digits) == 1) {
mask_na <- is.na(x)
mask_aschar <- is.nan(x) | is.infinite(x)
mask_manip <- !(mask_na | mask_aschar)
ret <- rep(NA, length(x))
# Put in the special values
if (any(mask_na)) {
ret[mask_na] <- "NA"
}
if (any(mask_aschar)) {
ret[mask_aschar] <- as.character(x[mask_aschar])
}
if (any(mask_manip)) {
xtmp <- round(x[mask_manip], digits)
mask_sci <-
xtmp != 0 &
abs(log10(abs(xtmp))) >= sci_range
mask_no_sci <- !mask_sci
if (any(mask_sci)) {
logval <- floor(log10(abs(xtmp[mask_sci])))
ret[mask_manip][mask_sci] <-
paste0(
formatC(xtmp[mask_sci]/10^logval, format="f", digits=digits + logval),
sci_sep,
formatC(logval, format="d"))
}
if (any(mask_no_sci)) {
if (digits < 0) {
ret[mask_manip][mask_no_sci] <-
formatC(xtmp[mask_no_sci], format='f', digits=0)
} else {
ret[mask_manip][mask_no_sci] <-
formatC(xtmp[mask_no_sci], format='f', digits=digits)
}
}
}
ret
} else if (length(x) == length(digits)) {
mapply(roundString, x, digits=digits, sci_range=sci_range, sci_sep=sci_sep)
} else {
stop("digits must either be a scalar or the same length as x")
}
}
#' Round a value to a defined number of significant digits printing out trailing
#' zeros, if applicable.
#'
#' @param x The number to round
#' @param digits integer indicating the number of significant digits
#' @param sci_range integer (or `Inf`) indicating when to switch to
#' scientific notation instead of floating point. Zero indicates always use
#' scientific; `Inf` indicates to never use scientific notation;
#' otherwise, scientific notation is used when `abs(log10(x)) > si_range`.
#' @param sci_sep The separator to use for scientific notation strings
#' (typically this will be either "e" or "x10^" for computer- or
#' human-readable output).
#' @param si_range Deprecated, please use `sci_range`
#' @param ... Arguments passed to methods.
#' @return A string with the value
#' @details Values that are not standard numbers like `Inf`, `NA`, and
#' `NaN` are returned as `"Inf"`, `"NA"`, and `NaN`.
#' @seealso [signif()], [roundString()]
#' @export
signifString <- function(x, ...)
UseMethod("signifString")
#' @rdname signifString
#' @export
signifString.data.frame <- function(x, ...) {
ret <- lapply(x,
function(y) {
if (is.numeric(y) & !is.factor(y)) {
signifString(x=y, ...)
} else {
y
}
})
ret <- as.data.frame(ret,
stringsAsFactors=FALSE)
rownames(ret) <- rownames(x)
colnames(ret) <- colnames(x)
ret
}
#' @rdname signifString
#' @export
signifString.default <- function(x, digits=6, sci_range=6, sci_sep="e", si_range, ...) {
if (length(list(...))) {
stop("Additional, unsupported arguments were passed")
}
if (!missing(si_range)) {
.Deprecated(new="roundString with the sci_range argument",
msg="The si_range argument is deprecated, please use sci_range")
sci_range <- si_range
}
mask_na <- is.na(x)
mask_aschar <- is.nan(x) | is.infinite(x)
mask_manip <- !(mask_na | mask_aschar)
ret <- rep(NA, length(x))
# Put in the special values
if (any(mask_na)) {
ret[mask_na] <- "NA"
}
if (any(mask_aschar)) {
ret[mask_aschar] <- as.character(x[mask_aschar])
}
if (any(mask_manip)) {
xtmp <- x[mask_manip]
toplog <- bottomlog <- rep(NA, length(xtmp))
# When 0 give the digits as the output
bottomlog[xtmp %in% 0] <- digits
# Otherwise set it to digits orders of magnitude lower than the
# current value
toplog <- log10(abs(xtmp))
# When the order of magnitude is an exact log 10, move up one so
# that the math works for determing the lower log.
mask.exact.log <- (toplog %% 1) %in% 0
toplog[mask.exact.log] <- toplog[mask.exact.log] + 1
toplog <- ceiling(toplog)
bottomlog[is.na(bottomlog)] <- digits-toplog[is.na(bottomlog)]
# Find times when rounding increases the toplog and shift up the
# bottomlog to a corresponding degree. e.g. x=0.9999 and digits=2
# should be 1.0 not 1.00.
newtoplog <- log10(abs(round(xtmp, digits=bottomlog)))
mask.exact.log <- (newtoplog %% 1) %in% 0
newtoplog[mask.exact.log] <- newtoplog[mask.exact.log] + 1
newtoplog <- ceiling(newtoplog)
mask.move.up <- toplog < newtoplog
bottomlog[mask.move.up] <- bottomlog[mask.move.up] - 1
# Do the rounding
ret[mask_manip] <- roundString(xtmp, digits=bottomlog,
sci_range=sci_range, sci_sep=sci_sep)
}
ret
}
#' Find the summary statistic value with a different value if the input is
#' zero-length.
#'
#' @details If `na.rm` is `TRUE`, then `NA` values will be removed prior to the
#' check if `length(c(...)) == 0`.
#'
#' @param ... objects to find the summary_statistic for (combined with `c()`
#' prior to calculation)
#' @param na.rm a logical indicating whether missing values should be removed
#' (see Details).
#' @param zero_length The value to return if `length(x) == 0`
#' @param FUN the summary statistic function (such as `max` or `min`)
#' @return Either `zero_length` or `FUN(...)`
#' @noRd
zero_len_summary <- function(FUN) {
function(..., na.rm=FALSE, zero_length=NA) { #nocov
x <- c(...)
if (na.rm) {
x <- stats::na.omit(x)
}
if (length(x) == 0) {
zero_length
} else {
FUN(x)
}
} #nocov
}
#' @describeIn zero_len_summary Find the maximum value with a different value if
#' the input is zero-length
#' @noRd
max_zero_len <- zero_len_summary(FUN=max)
#' @describeIn zero_len_summary Find the minimum value with a different value if
#' the input is zero-length
#' @noRd
min_zero_len <- zero_len_summary(FUN=min)