/
options.R
128 lines (105 loc) · 4.17 KB
/
options.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
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Set options for printing on the emphatic matrix or data.frame
#'
#' @inheritParams hl_opts
#' @param .data emphatic matrix or data.frame
#'
#' @return emphatic object with updated options
#'
#' @importFrom utils modifyList
#' @export
#' @examples
#' mtcars |>
#' hl('red') |>
#' hl_adjust(text_contrast = 0.3)
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
hl_adjust <- function(.data, na, full_colour, text_mode, text_contrast) {
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Sanity check
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
stopifnot(is_emphatic(.data))
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# 'magically' get any arguments the user has provided. Ignore ".data"
# from the list of options
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
new_options <- find_args()
new_options$.data <- NULL
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Get the current options attributes on this emphatic object and
# update them with any user-specified values
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
current_options <- attr(.data, 'options', exact = TRUE) %||% list()
new_options <- modifyList(current_options, new_options)
attr(.data, 'options') <- new_options
.data
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Private function: Code inspired by ggplot2 for dealing with calls to theme()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
find_args <- function () {
is_missing_arg <- function(x) identical(x, quote(expr = ))
env <- parent.frame()
args <- names(formals(sys.function(sys.parent(1))))
vals <- mget(args, envir = env)
vals <- vals[!vapply(vals, is_missing_arg, logical(1))]
vals
}
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
#' Create a set of options
#'
#' @param na Character string to display for NA values. Default 'NA'
#' @param full_colour Use 24bit ANSI escape codes? default: FALSE - use 8bit colour.
#' Note: RStudio only supports 8 bit ANSI output (24bit ANSI is
#' rendered invisibly in Rstudio). For 24bit colour output, try R in the terminal
#' e.g. 'iTerm' on OSX.
#' @param text_mode How to handle text if no text colour has been
#' explicitly specified by the user.
#' \describe{
#' \item{contrast}{(default) automatically select a contrasting colour for enhanced readability.}
#' \item{asis}{render text in the default text
#' colour for the output device, unless the user has already specified
#' a text colour at this location}
#' \item{remove}{remove all text without a user-defined colour}
#' }
#' @param text_contrast When \code{text_mode='contrast'} this numeric value in
#' range [0, 1] adjusts the visibility. Default: 1 (high contrast)
#'
#' @export
#' @examples
#' # Generate a standard set of options
#' hl_opts()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
hl_opts <- function(na = getOption("HL_NA", "NA"),
full_colour = getOption("HL_FULL_COLOUR", FALSE),
text_mode = getOption("HL_TEXT_MODE", "contrast"),
text_contrast = getOption("HL_TEXT_CONTRAST", 1)) {
stopifnot(exprs = {
is.character(na)
length(na) == 1
!is.na(na)
})
stopifnot(exprs = {
is.logical(full_colour)
length(full_colour) == 1
!is.na(full_colour)
})
stopifnot(exprs = {
is.character(text_mode)
length(text_mode) == 1
!is.na(text_mode)
text_mode %in% c('contrast', 'asis', 'remove')
})
stopifnot(exprs = {
is.numeric(text_contrast)
length(text_contrast) == 1
!is.na(text_contrast)
text_contrast >= 0
text_contrast <= 1
})
list(
na = na,
full_colour = full_colour,
text_mode = text_mode,
text_contrast = text_contrast
)
}