1 2# as future expansion becomes a thing, look into `selectr::parse(selector)` 3# https://github.com/sjp/selectr/blob/master/R/parser.R 4# selectr:::parse("#a.warning > b.mine:not(.theres) d")[[1]]$show() 5#> CombinedSelector[CombinedSelector[Class[Hash[Element[*]#a].warning] > Negation[Class[Element[b].mine]:not(Class[Element[*].theres])]] <followed> Element[d]] 6## ^^ R6 output 7 8SELECTOR_EVERYTHING <- "everything" 9SELECTOR_REGULAR <- "regular" 10 11SELECTOR_SPACE <- "space" 12SELECTOR_CHILD <- "child" 13 14selectorClass <- "htmltools.selector" 15selectorListClass <- "htmltools.selector.list" 16isSelector <- function(x) { 17 inherits(x, selectorClass) 18} 19isSelectorList <- function(x) { 20 inherits(x, selectorListClass) 21} 22 23# only handles id and classes 24asSelector <- function(selector) { 25 if (isSelector(selector) || isSelectorList(selector)) { 26 return(selector) 27 } 28 29 # make sure it's a trimmed string 30 selector <- txt_trim(paste0(selector, collapse = " ")) 31 32 if (txt_detect(selector, ",", fixed = TRUE)) { 33 stop("CSS selectors that contain `,` aren't (yet) implemented.", call. = FALSE) 34 } 35 if (txt_detect(selector, "[", fixed = TRUE)) { 36 stop("CSS selectors that contain `[` aren't (yet) implemented.", call. = FALSE) 37 } 38 if (txt_detect(selector, "~", fixed = TRUE)) { 39 stop("CSS selectors that contain `~` aren't (yet) implemented.", call. = FALSE) 40 } 41 if (txt_detect(selector, "+", fixed = TRUE)) { 42 stop("CSS selectors that contain `+` aren't (yet) implemented.", call. = FALSE) 43 } 44 if (txt_detect(selector, ":", fixed = TRUE)) { 45 stop( 46 "Pseudo CSS selectors (e.g., `:first-child`, `:not()`, etc)", 47 " aren't (yet) implemented.", 48 call. = FALSE 49 ) 50 } 51 52 # Check here to avoid inf recursion 53 if (txt_detect(selector, ">", fixed = TRUE)) { 54 # If there is a `>`, pad it with spaces 55 if (txt_detect(selector, "(^>)|(>$)")) { 56 stop( 57 "Direct children selector, `>`, must not be the first element or last element", 58 " in a css selector. Please add more selector information, such as `*`." 59 ) 60 } 61 # While there are any consecutive `> >` items... 62 while(txt_detect(selector, ">\\s*>")) { 63 # If there are any `>>`, replace them with `> * >` 64 selector <- txt_replace_all(selector, ">\\s*>", "> * >") 65 } 66 67 # Split by `>` and convert to selectors 68 # Alter parts (execpt first) to say they are a direct child 69 # Return selector list 70 selectorItems <- lapply(strsplit(selector, ">")[[1]], asSelector) 71 selectorListItems <- Map( 72 selectorItems, 73 seq_along(selectorItems), 74 f = function(selectorItem, i) { 75 if (isSelector(selectorItem)) { 76 if (i > 1) selectorItem$traversal <- SELECTOR_CHILD 77 asSelectorList(selectorItem) 78 } else { 79 if (i > 1) selectorItem[[1]]$traversal <- SELECTOR_CHILD 80 selectorItem 81 } 82 } 83 ) 84 selectorList <- asSelectorList( 85 unlist(selectorListItems, recursive = FALSE, use.names = FALSE) 86 ) 87 return(selectorList) 88 } 89 90 # Split into a selector parts and recurse one more time 91 if (txt_detect(selector, "\\s")) { 92 selectorItems <- lapply(strsplit(selector, "\\s+")[[1]], asSelector) 93 selectorList <- asSelectorList(selectorItems) 94 return(selectorList) 95 } 96 97 # https://www.w3.org/TR/selectors-3/#selectors 98 99 type <- NULL 100 traversal <- SELECTOR_SPACE 101 element <- NULL 102 id <- NULL 103 classes <- NULL 104 105 if (isTRUE(selector == "*")) { 106 type <- SELECTOR_EVERYTHING 107 } else { 108 type <- SELECTOR_REGULAR 109 110 ## Not needed as the regex values below work around this. 111 # # if there is more than a `*`, such as `*.warning`, treat as `.warning` 112 # if (txt_detect(selector, "^\\*")) 113 # selector <- sub("^\\*", "", selector) 114 # if (grepl("^\\*", selector)) { 115 # stop("malformed css selector. Found at least two `**` that were not separated by a space") 116 # } 117 # } 118 119 elementRegex <- "^[a-zA-Z0-9]+" 120 element <- txt_match_first(selector, elementRegex) 121 if (!is.null(element)) { 122 selector <- txt_remove(selector, elementRegex) 123 } 124 125 ## https://www.w3.org/TR/CSS21/syndata.html#value-def-identifier 126 ## In CSS, identifiers (including element names, classes, and IDs in selectors) can contain only the characters [a-zA-Z0-9] and ISO 10646 characters U+00A0 and higher, plus the hyphen (-) and the underscore (_); they cannot start with a digit, two hyphens, or a hyphen followed by a digit. Identifiers can also contain escaped characters and any ISO 10646 character as a numeric code (see next item). For instance, the identifier "B&W?" may be written as "B\&W\?" or "B\26 W\3F". 127 # # define simpler (maybe not accurate) regex 128 # id_regex <- "^#[^#.:[\\s]+" # `#` then everything that isn't a `#`, `.`, `:`, or white space 129 # class_regex <- "^\\.[^#.:[\\s]+" # `.` then everything that isn't a `.`, `:`, or white space 130 131 tmpId <- txt_match_first(selector, "#[^.:[]+") 132 if (!is.null(tmpId)) { 133 id <- txt_remove(tmpId, "^#") 134 selector <- txt_remove(selector, tmpId, fixed = TRUE) 135 } 136 137 classes <- txt_remove(txt_match_all(selector, "\\.[^.:[]+"), "^\\.") 138 if (length(classes) == 0) { 139 classes <- NULL 140 } 141 # if (!is.null(classes)) { 142 # selector <- txt_remove(selector, "\\.[^.:[]+") 143 # } 144 } 145 146 structure(class = selectorClass, list( 147 element = element, 148 id = id, 149 classes = classes, 150 type = type, 151 traversal = traversal 152 )) 153} 154 155 156asSelectorList <- function(selector) { 157 if (isSelectorList(selector)) { 158 return(selector) 159 } 160 if (is.character(selector)) { 161 selector <- asSelector(selector) 162 } 163 if (isSelector(selector)) { 164 selector <- list(selector) 165 } 166 if (!is.list(selector)) { 167 stop("Do not know how to convert non list object into a `htmltools.selector.list`") 168 } 169 170 isSelectorVals <- vapply(selector, isSelector, logical(1)) 171 if (!all(isSelectorVals)) { 172 stop("Can only convert a list of selectors to a `htmltools.selector.list`") 173 } 174 structure(class = selectorListClass, selector) 175} 176 177#' @export 178format.htmltools.selector <- function(x, ...) { 179 paste0( 180 c( 181 if (x$traversal == SELECTOR_CHILD) "> ", 182 if (x$type == SELECTOR_EVERYTHING) { 183 "*" 184 } else { 185 paste0(c( 186 x$element, 187 if (!is.null(x$id)) paste0("#", x$id), 188 if (!is.null(x$classes)) paste0(".", x$classes) 189 )) 190 } 191 ), 192 collapse = "" 193 ) 194} 195#' @export 196format.htmltools.selector.list <- function(x, ...) { 197 paste0(as.character(lapply(x, format, ...)), collapse = " ") 198} 199 200#' @export 201print.htmltools.selector <- function(x, ...) { 202 cat("// htmltools css selector\n") 203 cat(format(x, ...), "\n") 204} 205#' @export 206print.htmltools.selector.list <- function(x, ...) { 207 cat("// htmltools css selector list\n") 208 cat(format(x, ...), "\n") 209} 210 211 212 213# When `fixed = TRUE`, `sub()`, `gsub()`, `grepl()` perform ~4x faster 214# #> bench::mark(grepl("* ", "A B * C"), grepl("* ", "A B * C", fixed = TRUE)) 215# expression min median 216# <bch:expr> <bch:t> <bch:> 217# 1 grepl("* ", "A B * C") 3.91µs 5.23µs 218# 2 grepl("* ", "A B * C", fixed = TRUE) 1.1µs 1.34µs 219txt_replace <- function(text, pattern, replacement, fixed = FALSE) { 220 sub(pattern = pattern, replacement = replacement, x = text, perl = !fixed, fixed = fixed) 221} 222 223txt_replace_all <- function(text, pattern, replacement, fixed = FALSE) { 224 gsub(pattern = pattern, replacement = replacement, x = text, perl = !fixed, fixed = fixed) 225} 226 227txt_remove <- function(x, pattern, ...) { 228 txt_replace(x, pattern, "", ...) 229} 230txt_remove_all <- function(x, pattern, ...) { 231 txt_replace_all(x, pattern, "", ...) 232} 233 234trim_leading <- function(text) { 235 txt_remove_all(text, pattern = "^\\s+") 236} 237 238trim_trailing <- function(text) { 239 txt_remove_all(text, pattern = "\\s+$") 240} 241 242txt_trim <- function(text, side = "both") { 243 if (side == "both" || side == "left") { 244 text <- trim_leading(text) 245 } 246 if (side == "both" || side == "right") { 247 text <- trim_trailing(text) 248 } 249 text 250} 251 252txt_detect <- function(text, pattern, fixed = FALSE) { 253 grepl(pattern = pattern, x = text, perl = !fixed, fixed = fixed) 254} 255 256# finds first, NOT all 257txt_match_first <- function(x, pattern, ...) { 258 regInfo <- regexpr(pattern, x, ...) 259 if (length(regInfo) == 1 && regInfo == -1) { 260 return(NULL) 261 } 262 263 regmatches(x, regInfo) 264} 265 266# return a vector of matches or NULL 267txt_match_all <- function(x, pattern, ...) { 268 if (length(x) != 1) { 269 stop("`x` must have a length of 1") 270 } 271 regInfo <- gregexpr(pattern, x, ...) 272 first <- regInfo[[1]] 273 if (length(first) == 1 && first == -1) { 274 return(NULL) 275 } 276 277 regmatches(x, regInfo)[[1]] 278} 279