1#' Quosure getters, setters and testers 2#' 3#' @description 4#' 5#' A quosure is a type of [quoted expression][nse-defuse] that includes 6#' a reference to the context where it was created. A quosure is thus 7#' guaranteed to evaluate in its original environment and can refer to 8#' local objects. 9#' 10#' You can access the quosure components (its expression and its 11#' environment) with: 12#' 13#' * [get_expr()] and [get_env()]. These getters also support other 14#' kinds of objects such as formulas. 15#' 16#' * `quo_get_expr()` and `quo_get_env()`. These getters only work 17#' with quosures and throw an error with other types of input. 18#' 19#' Test if an object is a quosure with `is_quosure()`. If you know an 20#' object is a quosure, use the `quo_` prefixed predicates to check 21#' its contents, `quo_is_missing()`, `quo_is_symbol()`, etc. 22#' 23#' 24#' @section Quosured constants: 25#' 26#' A quosure usually does not carry environments for [constant 27#' objects][is_syntactic_literal] like strings or numbers. [quo()] and 28#' [enquo()] only capture an environment for [symbolic 29#' expressions][is_symbolic]. For instance, all of these return the 30#' [empty environment][empty_env]: 31#' 32#' ``` 33#' quo_get_env(quo("constant")) 34#' quo_get_env(quo(100)) 35#' quo_get_env(quo(NA)) 36#' ``` 37#' 38#' On the other hand, quosures capture the environment of symbolic 39#' expressions, i.e. expressions whose meaning depends on the 40#' environment in which they are evaluated and what objects are 41#' defined there: 42#' 43#' ``` 44#' quo_get_env(quo(some_object)) 45#' quo_get_env(quo(some_function())) 46#' ``` 47#' 48#' 49#' @section Empty quosures: 50#' 51#' When missing arguments are captured as quosures, either through 52#' [enquo()] or [quos()], they are returned as an empty quosure. These 53#' quosures contain the [missing argument][missing_arg] and typically 54#' have the [empty environment][empty_env] as enclosure. 55#' 56#' 57#' @section Life cycle: 58#' 59#' - `is_quosure()` is stable. 60#' 61#' - `quo_get_expr()` and `quo_get_env()` are stable. 62#' 63#' @name quosure 64#' @seealso [quo()] for creating quosures by quotation; [as_quosure()] 65#' and [new_quosure()] for constructing quosures manually. 66#' @examples 67#' quo <- quo(my_quosure) 68#' quo 69#' 70#' 71#' # Access and set the components of a quosure: 72#' quo_get_expr(quo) 73#' quo_get_env(quo) 74#' 75#' quo <- quo_set_expr(quo, quote(baz)) 76#' quo <- quo_set_env(quo, empty_env()) 77#' quo 78#' 79#' # Test wether an object is a quosure: 80#' is_quosure(quo) 81#' 82#' # If it is a quosure, you can use the specialised type predicates 83#' # to check what is inside it: 84#' quo_is_symbol(quo) 85#' quo_is_call(quo) 86#' quo_is_null(quo) 87#' 88#' # quo_is_missing() checks for a special kind of quosure, the one 89#' # that contains the missing argument: 90#' quo() 91#' quo_is_missing(quo()) 92#' 93#' fn <- function(arg) enquo(arg) 94#' fn() 95#' quo_is_missing(fn()) 96NULL 97 98#' @rdname quosure 99#' @param x An object to test. 100#' @export 101is_quosure <- function(x) { 102 inherits(x, "quosure") 103} 104 105#' @rdname quosure 106#' @param quo A quosure to test. 107#' @export 108quo_is_missing <- function(quo) { 109 .Call(rlang_quo_is_missing, quo) 110} 111#' @rdname quosure 112#' @param name The name of the symbol or function call. If `NULL` the 113#' name is not tested. 114#' @export 115quo_is_symbol <- function(quo, name = NULL) { 116 is_symbol(quo_get_expr(quo), name = name) 117} 118#' @rdname quosure 119#' @inheritParams is_call 120#' @export 121quo_is_call <- function(quo, name = NULL, n = NULL, ns = NULL) { 122 is_call(quo_get_expr(quo), name = name, n = n, ns = ns) 123} 124#' @rdname quosure 125#' @export 126quo_is_symbolic <- function(quo) { 127 .Call(rlang_quo_is_symbolic, quo) 128} 129#' @rdname quosure 130#' @export 131quo_is_null <- function(quo) { 132 .Call(rlang_quo_is_null, quo) 133} 134 135 136#' @rdname quosure 137#' @export 138quo_get_expr <- function(quo) { 139 .Call(rlang_quo_get_expr, quo) 140} 141#' @rdname quosure 142#' @export 143quo_get_env <- function(quo) { 144 .Call(rlang_quo_get_env, quo) 145} 146 147#' @rdname quosure 148#' @param expr A new expression for the quosure. 149#' @export 150quo_set_expr <- function(quo, expr) { 151 .Call(rlang_quo_set_expr, quo, expr) 152} 153#' @rdname quosure 154#' @param env A new environment for the quosure. 155#' @export 156quo_set_env <- function(quo, env) { 157 .Call(rlang_quo_set_env, quo, env) 158} 159 160 161#' Create a list of quosures 162#' 163#' @description 164#' 165#' This small S3 class provides methods for `[` and `c()` and ensures 166#' the following invariants: 167#' 168#' * The list only contains quosures. 169#' * It is always named, possibly with a vector of empty strings. 170#' 171#' `new_quosures()` takes a list of quosures and adds the `quosures` 172#' class and a vector of empty names if needed. `as_quosures()` calls 173#' [as_quosure()] on all elements before creating the `quosures` 174#' object. 175#' 176#' @param x A list of quosures or objects to coerce to quosures. 177#' @param env The default environment for the new quosures. 178#' @param named Whether to name the list with [quos_auto_name()]. 179#' @export 180new_quosures <- function(x) { 181 if (!is_list(x) || !every(x, is_quosure)) { 182 abort("Expected a list of quosures") 183 } 184 structure(x, 185 class = c("quosures", "list"), 186 names = names2(x) 187 ) 188} 189#' @rdname new_quosures 190#' @export 191as_quosures <- function(x, env, named = FALSE) { 192 x <- map(x, as_quosure, env = env) 193 if (named) { 194 x <- quos_auto_name(x) 195 } 196 new_quosures(x) 197} 198#' @rdname new_quosures 199#' @export 200is_quosures <- function(x) { 201 inherits(x, "quosures") 202} 203 204#' @export 205`[.quosures` <- function(x, i) { 206 structure(NextMethod(), class = c("quosures", "list")) 207} 208#' @export 209c.quosures <- function(..., recursive = FALSE) { 210 out <- NextMethod() 211 if (every(out, is_quosure)) { 212 new_quosures(out) 213 } else { 214 warn_deprecated(paste_line( 215 "Quosure lists can't be concatenated with objects other than quosures as of rlang 0.3.0.", 216 "Please call `as.list()` on the quosure list first." 217 )) 218 out 219 } 220} 221#' @export 222print.quosures <- function(x, ...) { 223 cat_line("<list_of<quosure>>\n") 224 print(unclass(x), ...) 225} 226#' @export 227as.list.quosures <- function(x, ...) { 228 unclass(x) 229} 230 231#' @export 232`[<-.quosures` <- function(x, i, value) { 233 if (idx <- detect_index(value, negate(is_quosure))) { 234 signal_quosure_assign(value[[idx]]) 235 } 236 NextMethod() 237} 238#' @export 239`[[<-.quosures` <- function(x, i, value) { 240 if (!is_quosure(value) && !is_null(value)) { 241 signal_quosure_assign(value) 242 } 243 NextMethod() 244} 245#' @export 246`$<-.quosures` <- function(x, name, value) { 247 x[[name]] <- value 248 x 249} 250signal_quosure_assign <- function(x) { 251 warn_deprecated(paste_line( 252 "Assigning non-quosure objects to quosure lists is deprecated as of rlang 0.3.0.", 253 "Please coerce to a bare list beforehand with `as.list()`" 254 )) 255} 256 257# Dynamically registered 258pillar_shaft.quosures <- function(x, ...) { 259 labels <- map_chr(unname(x), as_label) 260 structure(labels, width = 10L) 261} 262type_sum.quosures <- function(x) { 263 "quos" 264} 265 266#' Coerce object to quosure 267#' 268#' @description 269#' 270#' While `new_quosure()` wraps any R object (including expressions, 271#' formulas, or other quosures) into a quosure, `as_quosure()` 272#' converts formulas and quosures and does not double-wrap. 273#' 274#' 275#' @section Life cycle: 276#' 277#' - `as_quosure()` now requires an explicit default environment for 278#' creating quosures from symbols and calls. 279#' 280#' - `as_quosureish()` is deprecated as of rlang 0.2.0. This function 281#' assumes that quosures are formulas which is currently true but 282#' might not be in the future. 283#' 284#' @param x An object to convert. Either an [expression][is_expression] or a 285#' formula. 286#' @param env The environment in which the expression should be 287#' evaluated. Only used for symbols and calls. This should typically 288#' be the environment in which the expression was created. 289#' @seealso [quo()], [is_quosure()] 290#' @export 291#' @examples 292#' # as_quosure() converts expressions or any R object to a validly 293#' # scoped quosure: 294#' env <- env(var = "thing") 295#' as_quosure(quote(var), env) 296#' 297#' 298#' # The environment is ignored for formulas: 299#' as_quosure(~foo, env) 300#' as_quosure(~foo) 301#' 302#' # However you must supply it for symbols and calls: 303#' try(as_quosure(quote(var))) 304as_quosure <- function(x, env = NULL) { 305 if (is_quosure(x)) { 306 return(x) 307 } 308 309 if (is_bare_formula(x)) { 310 env <- f_env(x) 311 if (is_null(env)) { 312 abort(paste_line( 313 "The formula does not have an environment.", 314 "This is a quoted formula that was never evaluated." 315 )) 316 } 317 318 return(new_quosure(f_rhs(x), env)) 319 } 320 321 if (is_symbolic(x)) { 322 if (is_null(env)) { 323 warn_deprecated(paste_line( 324 "`as_quosure()` requires an explicit environment as of rlang 0.3.0.", 325 "Please supply `env`." 326 )) 327 env <- caller_env() 328 } 329 330 return(new_quosure(x, env)) 331 } 332 333 new_quosure(x, empty_env()) 334} 335#' @rdname as_quosure 336#' @param expr The expression wrapped by the quosure. 337#' @export 338new_quosure <- function(expr, env = caller_env()) { 339 .Call(rlang_new_quosure, expr, env) 340} 341 342 343#' Squash a quosure 344#' 345#' @description 346#' 347#' `quo_squash()` flattens all nested quosures within an expression. 348#' For example it transforms `^foo(^bar(), ^baz)` to the bare 349#' expression `foo(bar(), baz)`. 350#' 351#' This operation is safe if the squashed quosure is used for 352#' labelling or printing (see [quo_label()] or [quo_name()]). However 353#' if the squashed quosure is evaluated, all expressions of the 354#' flattened quosures are resolved in a single environment. This is a 355#' source of bugs so it is good practice to set `warn` to `TRUE` to 356#' let the user know about the lossy squashing. 357#' 358#' 359#' @section Life cycle: 360#' 361#' This function replaces `quo_expr()` which was deprecated in 362#' rlang 0.2.0. `quo_expr()` was a misnomer because it implied that it 363#' was a mere expression acccessor for quosures whereas it was really 364#' a lossy operation that squashed all nested quosures. 365#' 366#' 367#' @param quo A quosure or expression. 368#' @param warn Whether to warn if the quosure contains other quosures 369#' (those will be collapsed). This is useful when you use 370#' `quo_squash()` in order to make a non-tidyeval API compatible 371#' with quosures. In that case, getting rid of the nested quosures 372#' is likely to cause subtle bugs and it is good practice to warn 373#' the user about it. 374#' 375#' @export 376#' @examples 377#' # Quosures can contain nested quosures: 378#' quo <- quo(wrapper(!!quo(wrappee))) 379#' quo 380#' 381#' # quo_squash() flattens all the quosures and returns a simple expression: 382#' quo_squash(quo) 383quo_squash <- function(quo, warn = FALSE) { 384 # Never warn when unwrapping outer quosure 385 if (is_quosure(quo)) { 386 quo <- quo_get_expr(quo) 387 } 388 if (is_missing(quo)) { 389 missing_arg() 390 } else { 391 quo_squash_impl(duplicate(quo), warn = warn) 392 } 393} 394 395 396#' Format quosures for printing or labelling 397#' 398#' @description 399#' 400#' \Sexpr[results=rd, stage=render]{rlang:::lifecycle("questioning")} 401#' 402#' **Note:** You should now use [as_label()] or [as_name()] instead 403#' of `quo_name()`. See life cycle section below. 404#' 405#' These functions take an arbitrary R object, typically an 406#' [expression][is_expression], and represent it as a string. 407#' 408#' * `quo_name()` returns an abbreviated representation of the object 409#' as a single line string. It is suitable for default names. 410#' 411#' * `quo_text()` returns a multiline string. For instance block 412#' expressions like `{ foo; bar }` are represented on 4 lines (one 413#' for each symbol, and the curly braces on their own lines). 414#' 415#' These deparsers are only suitable for creating default names or 416#' printing output at the console. The behaviour of your functions 417#' should not depend on deparsed objects. If you are looking for a way 418#' of transforming symbols to strings, use [as_string()] instead of 419#' `quo_name()`. Unlike deparsing, the transformation between symbols 420#' and strings is non-lossy and well defined. 421#' 422#' @inheritParams quo_squash 423#' @inheritParams expr_label 424#' 425#' @section Life cycle: 426#' 427#' These functions are in the questioning life cycle stage. 428#' 429#' * [as_label()] and [as_name()] should be used instead of 430#' `quo_name()`. `as_label()` transforms any R object to a string 431#' but should only be used to create a default name. Labelisation is 432#' not a well defined operation and no assumption should be made 433#' about the label. On the other hand, `as_name()` only works with 434#' (possibly quosured) symbols, but is a well defined and 435#' deterministic operation. 436#' 437#' * We don't have a good replacement for `quo_text()` yet. See 438#' <https://github.com/r-lib/rlang/issues/636> to follow discussions 439#' about a new deparsing API. 440#' 441#' @seealso [expr_label()], [f_label()] 442#' @examples 443#' # Quosures can contain nested quosures: 444#' quo <- quo(foo(!! quo(bar))) 445#' quo 446#' 447#' # quo_squash() unwraps all quosures and returns a raw expression: 448#' quo_squash(quo) 449#' 450#' # This is used by quo_text() and quo_label(): 451#' quo_text(quo) 452#' 453#' # Compare to the unwrapped expression: 454#' expr_text(quo) 455#' 456#' # quo_name() is helpful when you need really short labels: 457#' quo_name(quo(sym)) 458#' quo_name(quo(!! sym)) 459#' @export 460quo_label <- function(quo) { 461 expr_label(quo_squash(quo)) 462} 463#' @rdname quo_label 464#' @export 465quo_text <- function(quo, width = 60L, nlines = Inf) { 466 expr_text(quo_squash(quo), width = width, nlines = nlines) 467} 468#' @rdname quo_label 469#' @export 470quo_name <- function(quo) { 471 expr_name(quo_squash(quo)) 472} 473 474quo_squash_impl <- function(x, parent = NULL, warn = FALSE) { 475 switch_expr(x, 476 language = { 477 if (is_quosure(x)) { 478 if (!is_false(warn)) { 479 if (is_string(warn)) { 480 msg <- warn 481 } else { 482 msg <- "Collapsing inner quosure" 483 } 484 warn(msg) 485 warn <- FALSE 486 } 487 488 while (is_quosure(x)) { 489 x <- quo_get_expr(x) 490 } 491 if (!is_null(parent)) { 492 node_poke_car(parent, x) 493 } 494 quo_squash_impl(x, parent, warn = warn) 495 } else { 496 quo_squash_impl(node_cdr(x), warn = warn) 497 } 498 }, 499 pairlist = { 500 while (!is_null(x)) { 501 quo_squash_impl(node_car(x), x, warn = warn) 502 x <- node_cdr(x) 503 } 504 } 505 ) 506 507 x 508} 509 510 511#' @export 512print.quosure <- function(x, ...) { 513 cat_line(.trailing = FALSE, 514 bold("<quosure>"), 515 "expr: " 516 ) 517 quo_print(x) 518 cat_line(.trailing = FALSE, 519 "env: " 520 ) 521 522 env <- quo_get_env(x) 523 quo_env_print(env) 524 525 invisible(x) 526} 527#' @export 528str.quosure <- function(object, ...) { 529 str(unclass(object), ...) 530} 531 532#' @export 533as.character.quosure <- function(x, ...) { 534 warn_deprecated(paste_line( 535 "Using `as.character()` on a quosure is deprecated as of rlang 0.3.0.", 536 "Please use `as_label()` or `as_name()` instead." 537 )) 538 NextMethod() 539} 540 541#' @export 542`[.quosure` <- function(x, i, ...) { 543 signal_soft_deprecated(c( 544 "Subsetting quosures with `[` is deprecated as of rlang 0.4.0", 545 "Please use `quo_get_expr()` instead." 546 )) 547 NextMethod() 548} 549#' @export 550`[[.quosure` <- function(x, i, ...) { 551 signal_soft_deprecated(c( 552 "Subsetting quosures with `[[` is deprecated as of rlang 0.4.0", 553 "Please use `quo_get_expr()` instead." 554 )) 555 NextMethod() 556} 557 558# Create a circular list of colours. This infloops if printed in the REPL! 559new_quo_palette <- function() { 560 last_node <- new_node(open_cyan, NULL) 561 palette <- new_node(open_blue, new_node(open_green, new_node(open_magenta, last_node))) 562 node_poke_cdr(last_node, palette) 563 564 # First node has no colour 565 new_node(close_colour, palette) 566} 567 568# Reproduces output of printed calls 569base_deparse <- function(x) { 570 deparse(x, control = "keepInteger") 571} 572 573quo_deparse <- function(x, lines = new_quo_deparser()) { 574 if (!is_quosure(x)) { 575 return(sexp_deparse(x, lines = lines)) 576 } 577 578 env <- quo_get_env(x) 579 lines$quo_open_colour(env) 580 581 lines$push("^") 582 lines$make_next_sticky() 583 sexp_deparse(quo_get_expr(x), lines) 584 585 lines$quo_reset_colour() 586 587 lines$get_lines() 588} 589 590new_quo_deparser <- function(width = peek_option("width"), 591 crayon = has_crayon()) { 592 lines <- new_lines(width = width, deparser = quo_deparse) 593 594 child_r6lite(lines, 595 has_colour = crayon, 596 597 quo_envs = list(), 598 quo_history = pairlist(), 599 quo_colours = list( 600 open_blue, 601 open_green, 602 open_magenta, 603 open_cyan, 604 open_yellow 605 ), 606 quo_was_too_many = FALSE, 607 608 quo_push_opener = function(self, opener) { 609 self$quo_history <- new_node(opener, self$quo_history) 610 self$push_sticky(opener()) 611 self 612 }, 613 614 quo_open_colour = function(self, env) { 615 if (self$has_colour) { 616 if (is_reference(env, global_env()) || is_reference(env, empty_env())) { 617 self$quo_push_opener(close_colour) 618 return(NULL) 619 } 620 621 n_known_envs <- length(self$quo_envs) 622 623 idx <- detect_index(self$quo_envs, identical, env) 624 if (idx) { 625 opener <- self$quo_colours[[idx]] 626 } else if (n_known_envs < length(self$quo_colours)) { 627 self$quo_envs <- c(self$quo_envs, list(env)) 628 idx <- n_known_envs + 1L 629 opener <- self$quo_colours[[idx]] 630 } else { 631 opener <- function() paste0(close_colour(), open_blurred_italic()) 632 self$quo_was_too_many <- TRUE 633 } 634 635 self$quo_push_opener(opener) 636 } 637 }, 638 639 quo_reset_colour = function(self) { 640 if (self$has_colour) { 641 if (self$quo_was_too_many) { 642 self$push_sticky(close_blurred_italic()) 643 } 644 self$quo_history <- node_cdr(self$quo_history) 645 reset <- node_car(self$quo_history) %||% close_colour 646 self$push_sticky(reset()) 647 } 648 } 649 ) 650} 651 652quo_print <- function(quo) { 653 # Take into account the first 8-character wide columns 654 width <- peek_option("width") - 10L 655 deparser <- new_quo_deparser(width = width) 656 657 lines <- quo_deparse(quo, deparser) 658 659 n <- length(lines) 660 lines[seq2(2, n)] <- paste0(" ", lines[seq2(2, n)]) 661 662 cat(paste0(lines, "\n")) 663} 664quo_env_print <- function(env) { 665 nm <- env_label(env) 666 667 if (!is_reference(env, global_env()) && !is_reference(env, empty_env())) { 668 nm <- blue(nm) 669 } 670 671 cat_line(nm) 672} 673 674#' @export 675Ops.quosure <- function(e1, e2) { 676 if (identical(.Generic, "!")) { 677 abort(paste_line( 678 "Quosures can only be unquoted within a quasiquotation context.", 679 "", 680 " # Bad:", 681 " list(!!myquosure)", 682 "", 683 " # Good:", 684 " dplyr::mutate(data, !!myquosure)" 685 )) 686 } 687 688 if (missing(e2)) { 689 bad <- sprintf(" %s%s", .Generic, "myquosure") 690 good <- sprintf(" %s!!%s", .Generic, "myquosure") 691 } else if (is_quosure(e1) && is_quosure(e2)) { 692 bad <- sprintf(" myquosure1 %s myquosure2", .Generic) 693 good <- sprintf(" !!myquosure1 %s !!myquosure2", .Generic) 694 } else if (is_quosure(e1)) { 695 bad <- sprintf(" myquosure %s rhs", .Generic) 696 good <- sprintf(" !!myquosure %s rhs", .Generic) 697 } else { 698 bad <- sprintf(" lhs %s myquosure", .Generic) 699 good <- sprintf(" lhs %s !!myquosure", .Generic) 700 } 701 702 abort(paste_line( 703 "Base operators are not defined for quosures.", 704 "Do you need to unquote the quosure?", 705 "", 706 " # Bad:", 707 bad, 708 "", 709 " # Good:", 710 good, 711 )) 712} 713 714abort_quosure_op <- function(group, op) { 715 abort(paste_line( 716 sprintf("%s operations are not defined for quosures.", group), 717 "Do you need to unquote the quosure?", 718 "", 719 " # Bad:", 720 sprintf(" %s(myquosure)", op), 721 "", 722 " # Good:", 723 sprintf(" %s(!!myquosure)", op), 724 )) 725} 726#' @export 727Math.quosure <- function(x, ...) { 728 abort_quosure_op("Math", .Generic) 729} 730#' @export 731Summary.quosure <- function(x, ...) { 732 abort_quosure_op("Summary", .Generic) 733} 734#' @export 735mean.quosure <- function(x, na.rm = TRUE, ...) { 736 abort_quosure_op("Summary", "mean") 737} 738#' @importFrom stats median 739#' @export 740median.quosure <- function(x, na.rm = TRUE, ...) { 741 abort_quosure_op("Summary", "median") 742} 743#' @importFrom stats quantile 744#' @export 745quantile.quosure <- function(x, na.rm = TRUE, ...) { 746 abort_quosure_op("Summary", "quantile") 747} 748