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
|
#' `drive_id` class
#'
#' @description
#' `drive_id` is an S3 class to mark strings as Drive file ids, in order to
#' distinguish them from Drive file names or paths. `as_id()` converts various
#' inputs into an instance of `drive_id`.
#'
#' `as_id()` is a generic function.
#' @param x A character vector of file or shared drive ids or URLs, a
#' [`dribble`], or a suitable data frame.
#' @param ... Other arguments passed down to methods. (Not used.)
#' @return A character vector bearing the S3 class `drive_id`.
#' @name drive_id
#' @examplesIf drive_has_token()
#' as_id("123abc")
#' as_id("https://docs.google.com/spreadsheets/d/qawsedrf16273849/edit#gid=12345")
#'
#' x <- drive_find(n_max = 3)
#' as_id(x)
NULL
new_drive_id <- function(x = character()) {
vec_assert(x, character())
new_vctr(x, class = "drive_id", inherit_base_type = TRUE)
}
validate_drive_id <- function(x) {
ok <- is_valid_drive_id(x)
if (all(ok)) {
return(x)
}
# proceed with plain character vector
x <- vec_data(x)
# pragmatism re: how to cli-style a path that is the empty string
# this is related to the use of gargle_map_cli() for vectorized styling
# if cli gains native vectorization, this may become unnecessary
x[!nzchar(x)] <- "\"\""
drive_abort(c(
"A {.cls drive_id} must match this regular expression: \\
{.code {drive_id_regex()}}",
"Invalid input{?s}:{cli::qty(sum(!ok))}",
bulletize(gargle_map_cli(x[!ok]), bullet = "x")
))
}
#' @export
#' @rdname drive_id
as_id <- function(x, ...) UseMethod("as_id")
#' @export
as_id.default <- function(x, ...) {
drive_abort("
Don't know how to coerce an object of class {.cls {class(x)}} into \\
a {.cls drive_id}.")
}
#' @export
as_id.NULL <- function(x, ...) NULL
#' @export
as_id.drive_id <- function(x, ...) x
#' @export
as_id.dribble <- function(x, ...) as_id(x$id)
#' @export
as_id.data.frame <- function(x, ...) as_id(validate_dribble(new_dribble(x)))
#' @export
as_id.character <- function(x, ...) {
if (length(x) == 0L) {
return(new_drive_id())
}
out <- map_chr(x, get_one_id)
validate_drive_id(new_drive_id(out))
}
drive_id_regex <- function() "^[a-zA-Z0-9_-]+$"
is_valid_drive_id <- function(x) {
# among practitioners, It Is Known that file IDs have >= 25 characters
# but I'm not convinced the pros outweigh the cons re: checking length
# for example, in tests, it's nice to not worry about this
grepl(drive_id_regex(), x) | is.na(x)
}
is_drive_id <- function(x) {
inherits(x, "drive_id")
}
#' @export
gargle_map_cli.drive_id <- function(x, ...) {
NextMethod()
}
#' @export
vec_ptype2.drive_id.drive_id <- function(x, y, ...) new_drive_id()
#' @export
vec_ptype2.drive_id.character <- function(x, y, ...) character()
#' @export
vec_ptype2.character.drive_id <- function(x, y, ...) character()
#' @export
vec_cast.drive_id.drive_id <- function(x, to, ...) x
#' @export
vec_cast.drive_id.character <- function(x, to, ...) {
validate_drive_id(new_drive_id(x))
}
#' @export
vec_cast.character.drive_id <- function(x, to, ...) vec_data(x)
#' @export
vec_ptype_abbr.drive_id <- function(x, ...) "drv_id"
#' @export
pillar_shaft.drive_id <- function(x, ...) {
# The goal is to either see drive_id in full (which would allow, e.g. copy
# and paste) or to truncate it severely and leave room for more interesting
# columns, such as the Drive file name.
# Anything in between these two extremes seems like a waste of horizontal space.
x_valid <- !is.na(x)
# It's important to keep NA in the vector!
out <- rep(NA_character_, vec_size(x))
out[x_valid] <- format(x[x_valid])
out_short <- out
# nchar("<drv_id>") is 8
n <- 8
trunkate <- function(x) {
glue("{substr(x, 1, n - 1)}{cli::symbol$continue}")
}
out_width <- nchar(trimws(out))
too_wide <- which(x_valid & out_width > n)
if (any(too_wide)) {
out_short[too_wide] <- trunkate(out_short[too_wide])
}
have_color <- cli::num_ansi_colors() > 1
pillar::new_pillar_shaft_simple(
out,
short_formatted = out_short,
na = if (have_color) pillar::style_na("NA") else "<NA>"
)
}
## we anticipate file-id-containing URLs in these forms:
## /d/FILE_ID Drive file
## /folders/FILE_ID Drive folder
## id=FILE_ID uploaded blob
id_regexp <- "(/d/|/folders/|id=)[^/]+"
is_drive_url <- function(x) grepl("^http", x) & grepl(id_regexp, x)
get_one_id <- function(x) {
if (!grepl("^http|/", x)) {
return(x)
}
id_loc <- regexpr(id_regexp, x)
if (id_loc == -1) {
NA_character_
} else {
gsub("/d/|/folders/|id=", "", regmatches(x, id_loc))
}
}
|
