1 2test_that("bindCache reactive basic functionality", { 3 cache <- cachem::cache_mem() 4 5 k <- reactiveVal(0) 6 7 vals <- character() 8 r <- reactive({ 9 x <- paste0(k(), "v") 10 vals <<- c(vals, x) 11 k() 12 }) %>% bindCache({ 13 x <- paste0(k(), "k") 14 vals <<- c(vals, x) 15 k() 16 }, cache = cache) 17 18 o <- observe({ 19 x <- paste0(r(), "o") 20 vals <<- c(vals, x) 21 }) 22 23 flushReact() 24 expect_identical(vals, c("0k", "0v", "0o")) 25 26 vals <- character() 27 k(1) 28 flushReact() 29 k(2) 30 flushReact() 31 expect_identical(vals, c("1k", "1v", "1o", "2k", "2v", "2o")) 32 33 # Use a value that is in the cache. k and o will re-execute, but v will not. 34 vals <- character(0) 35 k(1) 36 flushReact() 37 expect_identical(vals, c("1k", "1o")) 38 k(0) 39 flushReact() 40 expect_identical(vals, c("1k", "1o", "0k", "0o")) 41 42 # Reset the cache - k and v will re-execute even if it's a previously-used value. 43 vals <- character(0) 44 cache$reset() 45 k(1) 46 flushReact() 47 expect_identical(vals, c("1k","1v", "1o")) 48}) 49 50test_that("bindCache - multiple key expressions", { 51 cache <- cachem::cache_mem() 52 53 k1 <- reactiveVal(0) 54 k2 <- reactiveVal(0) 55 56 r_vals <- character() 57 r <- reactive({ 58 x <- paste0(k1(), ":", k2()) 59 r_vals <<- c(r_vals, x) 60 x 61 }) %>% 62 bindCache(k1(), k2(), cache = cache) 63 64 o_vals <- character() 65 o <- observe({ 66 o_vals <<- c(o_vals, r()) 67 }) 68 69 flushReact() 70 expect_identical(r_vals, "0:0") 71 expect_identical(o_vals, "0:0") 72 flushReact() 73 expect_identical(r_vals, "0:0") 74 expect_identical(o_vals, "0:0") 75 76 # Each of the items can trigger 77 r_vals <- character(); o_vals <- character() 78 k1(10) 79 flushReact() 80 expect_identical(r_vals, "10:0") 81 expect_identical(o_vals, "10:0") 82 83 r_vals <- character(); o_vals <- character() 84 k2(100) 85 flushReact() 86 expect_identical(r_vals, "10:100") 87 expect_identical(o_vals, "10:100") 88 89 # Using a cached value means that reactive won't execute 90 r_vals <- character(); o_vals <- character() 91 k2(0) 92 flushReact() 93 expect_identical(r_vals, character()) 94 expect_identical(o_vals, "10:0") 95 k1(0) 96 flushReact() 97 expect_identical(r_vals, character()) 98 expect_identical(o_vals, c("10:0", "0:0")) 99}) 100 101 102test_that("bindCache reactive - original reactive can be GC'd", { 103 # bindCache.reactive essentially extracts code from the original reactive and 104 # then doesn't need the original anymore. We want to make sure the original 105 # can be GC'd afterward (if no one else has a reference to it). 106 cache <- cachem::cache_mem() 107 k <- reactiveVal(0) 108 109 vals <- character() 110 r <- reactive({ k() }) 111 112 finalized <- FALSE 113 reg.finalizer(attr(r, "observable"), function(e) finalized <<- TRUE) 114 115 r1 <- r %>% bindCache(k(), cache = cache) 116 rm(r) 117 gc() 118 expect_true(finalized) 119 120 121 # Same, but when using rlang::inject() to insert a quosure 122 cache <- cachem::cache_mem() 123 k <- reactiveVal(0) 124 125 vals <- character() 126 exp <- quo({ k() }) 127 r <- inject(reactive(!!exp)) 128 129 finalized <- FALSE 130 reg.finalizer(attr(r, "observable"), function(e) finalized <<- TRUE) 131 132 r1 <- r %>% bindCache(k(), cache = cache) 133 rm(r) 134 gc() 135 expect_true(finalized) 136}) 137 138test_that("bindCache reactive - value is isolated", { 139 # The value is isolated; the key is the one that dependencies are taken on. 140 cache <- cachem::cache_mem() 141 142 k <- reactiveVal(1) 143 v <- reactiveVal(10) 144 145 vals <- character() 146 r <- reactive({ 147 x <- paste0(v(), "v") 148 vals <<- c(vals, x) 149 v() 150 }) %>% bindCache({ 151 x <- paste0(k(), "k") 152 vals <<- c(vals, x) 153 k() 154 }, cache = cache) 155 156 o <- observe({ 157 x <- paste0(r(), "o") 158 vals <<- c(vals, x) 159 }) 160 161 flushReact() 162 expect_identical(vals, c("1k", "10v", "10o")) 163 164 # Changing k() triggers reactivity 165 k(2) 166 flushReact() 167 k(3) 168 flushReact() 169 expect_identical(vals, c("1k", "10v", "10o", "2k", "10v", "10o", "3k", "10v", "10o")) 170 171 # Changing v() does not trigger reactivity 172 vals <- character() 173 v(20) 174 flushReact() 175 v(30) 176 flushReact() 177 expect_identical(vals, character()) 178 179 # If k() changes, it will invalidate r, which will invalidate o. r will not 180 # re-execute, but instead fetch the old value (10) from the cache (from when 181 # the key was 1), and that value will be passed to o. This is an example of a 182 # bad key! 183 k(1) 184 flushReact() 185 expect_identical(vals, c("1k", "10o")) 186 187 # A new un-cached value for v will cause r to re-execute; it will fetch the 188 # current value of v (30), and that value will be passed to o. 189 vals <- character() 190 k(4) 191 flushReact() 192 expect_identical(vals, c("4k", "30v", "30o")) 193}) 194 195 196# ============================================================================ 197# Async key 198# ============================================================================ 199test_that("bindCache reactive with async key", { 200 cache <- cachem::cache_mem() 201 k <- reactiveVal(0) 202 203 vals <- character() 204 r <- reactive({ 205 x <- paste0(k(), "v") 206 vals <<- c(vals, x) 207 k() 208 }) %>% bindCache({ 209 promises::promise(function(resolve, reject) { 210 x <- paste0(k(), "k1") 211 vals <<- c(vals, x) 212 resolve(k()) 213 })$then(function(value) { 214 x <- paste0(k(), "k2") 215 vals <<- c(vals, x) 216 value 217 }) 218 }, cache = cache) 219 220 o <- observe({ 221 r()$then(function(value) { 222 x <- paste0(value, "o") 223 vals <<- c(vals, x) 224 }) 225 }) 226 227 # Initially, only the first step in the promise for key runs. 228 flushReact() 229 expect_identical(vals, c("0k1")) 230 231 # After pumping the event loop a feww times, the rest of the chain will run. 232 for (i in 1:3) later::run_now() 233 expect_identical(vals, c("0k1", "0k2", "0v", "0o")) 234 235 # If we change k, we should see same pattern as above, where run_now() is 236 # needed for the promise callbacks to run. 237 vals <- character() 238 k(1) 239 flushReact() 240 expect_identical(vals, c("1k1")) 241 for (i in 1:3) later::run_now() 242 expect_identical(vals, c("1k1", "1k2", "1v", "1o")) 243 244 # Going back to a cached value: The reactive's expr won't run, but the 245 # observer will. 246 vals <- character() 247 k(0) 248 flushReact() 249 expect_identical(vals, c("0k1")) 250 for (i in 1:3) later::run_now() 251 expect_identical(vals, c("0k1", "0k2", "0o")) 252}) 253 254 255# ============================================================================ 256# Async value 257# ============================================================================ 258test_that("bindCache reactives with async value", { 259 # If the value expr returns a promise, it must return a promise every time, 260 # even when the value is fetched in the cache. Similarly, if it returns a 261 # non-promise value, then it needs to do that whether or not it's fetched from 262 # the cache. This tests the promise case (almost all the other tests here test 263 # the non-promise case). 264 265 # Async value 266 cache <- cachem::cache_mem() 267 k <- reactiveVal(0) 268 269 vals <- character() 270 271 r <- reactive({ 272 promises::promise(function(resolve, reject) { 273 x <- paste0(k(), "v1") 274 vals <<- c(vals, x) 275 resolve(k()) 276 })$then(function(value) { 277 x <- paste0(value, "v2") 278 vals <<- c(vals, x) 279 value 280 }) 281 }) %>% bindCache({ 282 x <- paste0(k(), "k") 283 vals <<- c(vals, x) 284 k() 285 }, cache = cache) 286 287 o <- observe({ 288 r()$then(function(value) { 289 x <- paste0(value, "o") 290 vals <<- c(vals, x) 291 }) 292 }) 293 294 # Initially, the `then` in the value expr and observer don't run, but they will 295 # after running the event loop. 296 flushReact() 297 expect_identical(vals, c("0k", "0v1")) 298 for (i in 1:6) later::run_now() 299 expect_identical(vals, c("0k", "0v1", "0v2", "0o")) 300 301 # If we change k, we should see same pattern as above, where run_now() is 302 # needed for the promise callbacks to run. 303 vals <- character() 304 k(1) 305 flushReact() 306 expect_identical(vals, c("1k", "1v1")) 307 for (i in 1:6) later::run_now() 308 expect_identical(vals, c("1k", "1v1", "1v2", "1o")) 309 310 # Going back to a cached value: The reactives's expr won't run, but the 311 # observer will. 312 vals <- character() 313 k(0) 314 flushReact() 315 expect_identical(vals, c("0k")) 316 for (i in 1:2) later::run_now() 317 expect_identical(vals, c("0k", "0o")) 318}) 319 320 321# ============================================================================ 322# Async key and value 323# ============================================================================ 324test_that("bindCache reactives with async key and value", { 325 # If the value expr returns a promise, it must return a promise every time, 326 # even when the value is fetched in the cache. Similarly, if it returns a 327 # non-promise value, then it needs to do that whether or not it's fetched from 328 # the cache. This tests the promise case (almost all the other tests here test 329 # the non-promise case). 330 331 # Async key and value 332 cache <- cachem::cache_mem() 333 k <- reactiveVal(0) 334 335 vals <- character() 336 337 r <- reactive({ 338 promises::promise(function(resolve, reject) { 339 x <- paste0(k(), "v1") 340 vals <<- c(vals, x) 341 resolve(k()) 342 })$then(function(value) { 343 x <- paste0(value, "v2") 344 vals <<- c(vals, x) 345 value 346 }) 347 }) %>% bindCache({ 348 promises::promise(function(resolve, reject) { 349 x <- paste0(k(), "k1") 350 vals <<- c(vals, x) 351 resolve(k()) 352 })$then(function(value) { 353 x <- paste0(k(), "k2") 354 vals <<- c(vals, x) 355 value 356 }) 357 }, cache = cache) 358 359 o <- observe({ 360 r()$then(function(value) { 361 x <- paste0(value, "o") 362 vals <<- c(vals, x) 363 }) 364 }) 365 366 flushReact() 367 expect_identical(vals, c("0k1")) 368 for (i in 1:8) later::run_now() 369 expect_identical(vals, c("0k1", "0k2", "0v1", "0v2", "0o")) 370 371 # If we change k, we should see same pattern as above. 372 vals <- character(0) 373 k(1) 374 flushReact() 375 expect_identical(vals, c("1k1")) 376 for (i in 1:8) later::run_now() 377 expect_identical(vals, c("1k1", "1k2", "1v1", "1v2", "1o")) 378 379 # Going back to a cached value: The reactive's expr won't run, but the 380 # observer will. 381 vals <- character(0) 382 k(0) 383 flushReact() 384 expect_identical(vals, c("0k1")) 385 for (i in 1:6) later::run_now() 386 expect_identical(vals, c("0k1", "0k2", "0o")) 387}) 388 389test_that("bindCache reactive key collisions", { 390 # ======================================= 391 # No collision with different value exprs 392 # ======================================= 393 cache <- cachem::cache_mem() 394 k <- reactiveVal(1) 395 396 # Key collisions don't happen if they have different reactive expressions 397 # (because that is used in the key). 398 r_vals <- numeric() 399 r1 <- reactive({ 400 val <- k() * 10 401 r_vals <<- c(r_vals, val) 402 val 403 }) %>% 404 bindCache(k(), cache = cache) 405 406 r_vals <- numeric() 407 r2 <- reactive({ 408 val <- k() * 100 409 r_vals <<- c(r_vals, val) 410 val 411 }) %>% 412 bindCache(k(), cache = cache) 413 414 o_vals <- numeric() 415 o <- observe({ 416 o_vals <<- c(o_vals, r1(), r2()) 417 }) 418 419 # No collision because the reactive's expr is used in the key 420 flushReact() 421 expect_identical(r_vals, c(10, 100)) 422 expect_identical(o_vals, c(10, 100)) 423 424 k(2) 425 flushReact() 426 expect_identical(r_vals, c(10, 100, 20, 200)) 427 expect_identical(o_vals, c(10, 100, 20, 200)) 428 429 430 # ==================================== 431 # Collision with identical value exprs 432 # ==================================== 433 cache <- cachem::cache_mem() 434 k <- reactiveVal(1) 435 436 # Key collisions DO happen if they have the same value expressions. 437 r_vals <- numeric() 438 r1 <- reactive({ 439 val <- k() * 10 440 r_vals <<- c(r_vals, val) 441 val 442 }) %>% 443 bindCache(k(), cache = cache) 444 445 r2 <- reactive({ 446 val <- k() * 10 447 r_vals <<- c(r_vals, val) 448 val 449 }) %>% 450 bindCache(k(), cache = cache) 451 452 o_vals <- numeric() 453 o <- observe({ 454 o_vals <<- c(o_vals, r1(), r2()) 455 }) 456 457 # r2() never actually runs -- key collision. This is good, because this is 458 # what allows cache to be shared across multiple sessions. 459 flushReact() 460 expect_identical(r_vals, 10) 461 expect_identical(o_vals, c(10, 10)) 462 463 k(2) 464 flushReact() 465 expect_identical(r_vals, c(10, 20)) 466 expect_identical(o_vals, c(10, 10, 20, 20)) 467}) 468 469 470# ============================================================================ 471# Error handling 472# ============================================================================ 473test_that("bindCache reactive error handling", { 474 # =================================== 475 # Error in key 476 cache <- cachem::cache_mem() 477 k <- reactiveVal(0) 478 479 # Error in key 480 vals <- character() 481 r <- reactive({ 482 x <- paste0(k(), "v") 483 k() 484 }) %>% bindCache({ 485 x <- paste0(k(), "k") 486 vals <<- c(vals, x) 487 k() 488 stop("foo") 489 }, cache = cache) 490 491 o <- observe({ 492 x <- paste0(r(), "o") 493 vals <<- c(vals, x) 494 }) 495 496 suppress_stacktrace(expect_warning(flushReact())) 497 # A second flushReact should not raise warnings, since key has not been 498 # invalidated. 499 expect_silent(flushReact()) 500 501 k(1) 502 suppress_stacktrace(expect_warning(flushReact())) 503 expect_silent(flushReact()) 504 k(0) 505 suppress_stacktrace(expect_warning(flushReact())) 506 expect_silent(flushReact()) 507 # value expr and observer shouldn't have changed at all 508 expect_identical(vals, c("0k", "1k", "0k")) 509 510 # =================================== 511 # Silent error in key with req(FALSE) 512 cache <- cachem::cache_mem() 513 k <- reactiveVal(0) 514 515 vals <- character() 516 r <- reactive({ 517 x <- paste0(k(), "v") 518 k() 519 }) %>% bindCache({ 520 x <- paste0(k(), "k") 521 vals <<- c(vals, x) 522 k() 523 req(FALSE) 524 }, cache = cache) 525 526 o <- observe({ 527 x <- paste0(r(), "o") 528 vals <<- c(vals, x) 529 }) 530 531 532 expect_silent(flushReact()) 533 k(1) 534 expect_silent(flushReact()) 535 k(0) 536 expect_silent(flushReact()) 537 # value expr and observer shouldn't have changed at all 538 expect_identical(vals, c("0k", "1k", "0k")) 539 540 # =================================== 541 # Error in value 542 cache <- cachem::cache_mem() 543 k <- reactiveVal(0) 544 545 vals <- character() 546 r <- reactive({ 547 x <- paste0(k(), "v") 548 vals <<- c(vals, x) 549 stop("foo") 550 k() 551 }) %>% 552 bindCache({ 553 x <- paste0(k(), "k") 554 vals <<- c(vals, x) 555 k() 556 }, cache = cache) 557 558 o <- observe({ 559 x <- paste0(r(), "o") 560 vals <<- c(vals, x) 561 }) 562 563 suppress_stacktrace(expect_warning(flushReact())) 564 expect_silent(flushReact()) 565 k(1) 566 suppress_stacktrace(expect_warning(flushReact())) 567 expect_silent(flushReact()) 568 k(0) 569 # Should re-throw cached error 570 suppress_stacktrace(expect_warning(flushReact())) 571 expect_silent(flushReact()) 572 573 # 0v shouldn't be present, because error should be re-thrown without 574 # re-running code. 575 expect_identical(vals, c("0k", "0v", "1k", "1v", "0k")) 576 577 # ===================================== 578 # Silent error in value with req(FALSE) 579 cache <- cachem::cache_mem() 580 k <- reactiveVal(0) 581 582 vals <- character() 583 r <- reactive({ 584 x <- paste0(k(), "v") 585 vals <<- c(vals, x) 586 req(FALSE) 587 k() 588 }) %>% bindCache({ 589 x <- paste0(k(), "k") 590 vals <<- c(vals, x) 591 k() 592 }, cache = cache) 593 594 o <- observe({ 595 x <- paste0(r(), "o") 596 vals <<- c(vals, x) 597 }) 598 599 expect_silent(flushReact()) 600 k(1) 601 expect_silent(flushReact()) 602 k(0) 603 # Should re-throw cached error 604 expect_silent(flushReact()) 605 606 # 0v shouldn't be present, because error should be re-thrown without 607 # re-running code. 608 expect_identical(vals, c("0k", "0v", "1k", "1v", "0k")) 609}) 610 611 612test_that("bindCache reactive error handling - async", { 613 # =================================== 614 # Error in key 615 cache <- cachem::cache_mem() 616 k <- reactiveVal(0) 617 vals <- character() 618 r <- reactive({ 619 promises::promise(function(resolve, reject) { 620 x <- paste0(k(), "v1") 621 vals <<- c(vals, x) 622 resolve(k()) 623 })$then(function(value) { 624 x <- paste0(value, "v2") 625 vals <<- c(vals, x) 626 value 627 }) 628 }) %>% bindCache({ 629 promises::promise(function(resolve, reject) { 630 x <- paste0(k(), "k1") 631 vals <<- c(vals, x) 632 resolve(k()) 633 })$then(function(value) { 634 x <- paste0(k(), "k2") 635 vals <<- c(vals, x) 636 stop("err", k()) 637 value 638 }) 639 }, 640 cache = cache 641 ) 642 643 o <- observe({ 644 r()$then(function(value) { 645 x <- paste0(value, "o") 646 vals <<- c(vals, x) 647 })$catch(function(value) { 648 x <- paste0(value$message, "oc") 649 vals <<- c(vals, x) 650 }) 651 }) 652 653 suppress_stacktrace(flushReact()) 654 for (i in 1:4) later::run_now() 655 expect_identical(vals, c("0k1", "0k2", "err0oc")) 656 657 # A second flushReact should not raise warnings, since key has not been 658 # invalidated. 659 expect_silent(flushReact()) 660 661 vals <- character() 662 k(1) 663 suppress_stacktrace(flushReact()) 664 expect_silent(flushReact()) 665 for (i in 1:4) later::run_now() 666 expect_identical(vals, c("1k1", "1k2", "err1oc")) 667 668 vals <- character() 669 k(0) 670 suppress_stacktrace(flushReact()) 671 expect_silent(flushReact()) 672 for (i in 1:4) later::run_now() 673 expect_identical(vals, c("0k1", "0k2", "err0oc")) 674 675 # =================================== 676 # Silent error in key with req(FALSE) 677 cache <- cachem::cache_mem() 678 k <- reactiveVal(0) 679 vals <- character() 680 r <- reactive({ 681 x <- paste0(k(), "v") 682 vals <<- c(vals, x) 683 resolve(k()) 684 }) %>% bindCache({ 685 promises::promise(function(resolve, reject) { 686 x <- paste0(k(), "k1") 687 vals <<- c(vals, x) 688 resolve(k()) 689 })$then(function(value) { 690 x <- paste0(k(), "k2") 691 vals <<- c(vals, x) 692 req(FALSE) 693 value 694 }) 695 }, cache = cache) 696 697 o <- observe({ 698 r()$then(function(value) { 699 x <- paste0(value, "o") 700 vals <<- c(vals, x) 701 })$catch(function(value) { 702 x <- paste0(value$message, "oc") 703 vals <<- c(vals, x) 704 }) 705 }) 706 707 suppress_stacktrace(flushReact()) 708 for (i in 1:4) later::run_now() 709 # The `catch` will receive an empty message 710 expect_identical(vals, c("0k1", "0k2", "oc")) 711 712 # A second flushReact should not raise warnings, since key has not 713 # been invalidated. 714 expect_silent(flushReact()) 715 716 vals <- character() 717 k(1) 718 suppress_stacktrace(flushReact()) 719 expect_silent(flushReact()) 720 for (i in 1:4) later::run_now() 721 expect_identical(vals, c("1k1", "1k2", "oc")) 722 723 vals <- character() 724 k(0) 725 suppress_stacktrace(flushReact()) 726 expect_silent(flushReact()) 727 for (i in 1:4) later::run_now() 728 expect_identical(vals, c("0k1", "0k2", "oc")) 729 730 # =================================== 731 # Error in value 732 cache <- cachem::cache_mem() 733 k <- reactiveVal(0) 734 vals <- character() 735 r <- reactive({ 736 promises::promise(function(resolve, reject) { 737 x <- paste0(k(), "v1") 738 vals <<- c(vals, x) 739 resolve(k()) 740 })$then(function(value) { 741 x <- paste0(value, "v2") 742 vals <<- c(vals, x) 743 stop("err", k()) 744 value 745 }) 746 }) %>% bindCache({ 747 promises::promise(function(resolve, reject) { 748 x <- paste0(k(), "k1") 749 vals <<- c(vals, x) 750 resolve(k()) 751 })$then(function(value) { 752 x <- paste0(k(), "k2") 753 vals <<- c(vals, x) 754 value 755 }) 756 }, cache = cache) 757 758 o <- observe({ 759 r()$then(function(value) { 760 x <- paste0(value, "o") 761 vals <<- c(vals, x) 762 })$catch(function(value) { 763 x <- paste0(value$message, "oc") 764 vals <<- c(vals, x) 765 }) 766 }) 767 768 suppress_stacktrace(flushReact()) 769 for (i in 1:9) later::run_now() 770 # A second flushReact should not raise warnings, since key has not been 771 # invalidated. 772 expect_silent(flushReact()) 773 expect_identical(vals, c("0k1", "0k2", "0v1", "0v2", "err0oc")) 774 775 vals <- character() 776 k(1) 777 suppress_stacktrace(flushReact()) 778 expect_silent(flushReact()) 779 for (i in 1:9) later::run_now() 780 expect_identical(vals, c("1k1", "1k2", "1v1", "1v2", "err1oc")) 781 782 vals <- character() 783 k(0) 784 suppress_stacktrace(flushReact()) 785 expect_silent(flushReact()) 786 for (i in 1:6) later::run_now() 787 expect_identical(vals, c("0k1", "0k2", "err0oc")) 788 789 # ===================================== 790 # Silent error in value with req(FALSE) 791 cache <- cachem::cache_mem() 792 k <- reactiveVal(0) 793 vals <- character() 794 r <- reactive({ 795 promises::promise(function(resolve, reject) { 796 x <- paste0(k(), "v1") 797 vals <<- c(vals, x) 798 resolve(k()) 799 })$then(function(value) { 800 x <- paste0(value, "v2") 801 vals <<- c(vals, x) 802 req(FALSE) 803 value 804 }) 805 }) %>% 806 bindCache({ 807 promises::promise(function(resolve, reject) { 808 x <- paste0(k(), "k1") 809 vals <<- c(vals, x) 810 resolve(k()) 811 })$then(function(value) { 812 x <- paste0(k(), "k2") 813 vals <<- c(vals, x) 814 value 815 }) 816 }, cache = cache) 817 818 o <- observe({ 819 r()$then(function(value) { 820 x <- paste0(value, "o") 821 vals <<- c(vals, x) 822 })$catch(function(value) { 823 x <- paste0(value$message, "oc") 824 vals <<- c(vals, x) 825 }) 826 }) 827 828 suppress_stacktrace(flushReact()) 829 for (i in 1:9) later::run_now() 830 # A second flushReact should not raise warnings, since key has not been 831 # invalidated. 832 expect_silent(flushReact()) 833 expect_identical(vals, c("0k1", "0k2", "0v1", "0v2", "oc")) 834 835 vals <- character() 836 k(1) 837 suppress_stacktrace(flushReact()) 838 expect_silent(flushReact()) 839 for (i in 1:9) later::run_now() 840 expect_identical(vals, c("1k1", "1k2", "1v1", "1v2", "oc")) 841 842 vals <- character() 843 k(0) 844 suppress_stacktrace(flushReact()) 845 expect_silent(flushReact()) 846 for (i in 1:6) later::run_now() 847 expect_identical(vals, c("0k1", "0k2", "oc")) 848}) 849 850 851# ============================================================================ 852# Quosures 853# ============================================================================ 854test_that("bindCache quosures -- inlined with inject() at creation time", { 855 cache <- cachem::cache_mem() 856 res <- NULL 857 a <- 1 858 r <- inject({ 859 reactive({ 860 eval_tidy(quo(!!a)) 861 }) %>% 862 bindCache({ 863 x <- eval_tidy(quo(!!a)) + 10 864 res <<- x 865 x 866 }, cache = cache) 867 }) 868 a <- 2 869 expect_identical(isolate(r()), 1) 870 expect_identical(res, 11) 871}) 872 873 874test_that("bindCache quosures -- unwrapped at execution time", { 875 cache <- cachem::cache_mem() 876 res <- NULL 877 a <- 1 878 r <- reactive({ 879 eval_tidy(quo(!!a)) 880 }) %>% 881 bindCache({ 882 x <- eval_tidy(quo(!!a)) + 10 883 res <<- x 884 x 885 }, cache = cache) 886 a <- 2 887 expect_identical(isolate(r()), 2) 888 expect_identical(res, 12) 889}) 890 891 892# ============================================================================ 893# Visibility 894# ============================================================================ 895test_that("bindCache visibility", { 896 cache <- cachem::cache_mem() 897 k <- reactiveVal(0) 898 res <- NULL 899 r <- bindCache(k(), cache = cache, 900 x = reactive({ 901 if (k() == 0) invisible(k()) 902 else k() 903 }) 904 ) 905 906 o <- observe({ 907 res <<- withVisible(r()) 908 }) 909 910 flushReact() 911 expect_identical(res, list(value = 0, visible = FALSE)) 912 k(1) 913 flushReact() 914 expect_identical(res, list(value = 1, visible = TRUE)) 915 # Now fetch from cache 916 k(0) 917 flushReact() 918 expect_identical(res, list(value = 0, visible = FALSE)) 919 k(1) 920 flushReact() 921 expect_identical(res, list(value = 1, visible = TRUE)) 922}) 923 924 925test_that("bindCache reactive visibility - async", { 926 # only test if promises handles visibility 927 skip_if_not_installed("promises", "1.1.1.9001") 928 929 cache <- cachem::cache_mem() 930 k <- reactiveVal(0) 931 res <- NULL 932 r <- reactive({ 933 promise(function(resolve, reject) { 934 if (k() == 0) resolve(invisible(k())) 935 else resolve(k()) 936 }) 937 }) %>% 938 bindCache(k(), cache = cache) 939 940 o <- observe({ 941 r()$then(function(value) { 942 res <<- withVisible(value) 943 }) 944 }) 945 946 flushReact() 947 for (i in 1:3) later::run_now() 948 expect_identical(res, list(value = 0, visible = FALSE)) 949 k(1) 950 flushReact() 951 for (i in 1:3) later::run_now() 952 expect_identical(res, list(value = 1, visible = TRUE)) 953 # Now fetch from cache 954 k(0) 955 flushReact() 956 for (i in 1:3) later::run_now() 957 expect_identical(res, list(value = 0, visible = FALSE)) 958 k(1) 959 flushReact() 960 for (i in 1:3) later::run_now() 961 expect_identical(res, list(value = 1, visible = TRUE)) 962}) 963 964 965# ============================================================================ 966# bindCache and render functions 967# ============================================================================ 968 969test_that("bindCache renderFunction basic functionality", { 970 m <- cachem::cache_mem() 971 n <- 0 # Counter for how many times renderFunctions run. 972 a <- 1 973 974 # Two renderTexts with the same expression should share cache 975 t1 <- renderText({ n <<- n+1; a + 1 }) %>% bindCache(a, cache = m) 976 t2 <- renderText({ n <<- n+1; a + 1 }) %>% bindCache(a, cache = m) 977 expect_identical(t1(), "2") 978 expect_identical(t2(), "2") 979 expect_identical(n, 1) 980 981 a <- 2 982 expect_identical(t1(), "3") 983 expect_identical(t2(), "3") 984 expect_identical(n, 2) 985 986 # renderPrint with the same expression -- should run, and have a different 987 # result. 988 p1 <- renderPrint({ n <<- n+1; a + 1 }) %>% bindCache(a, cache = m) 989 p2 <- renderPrint({ n <<- n+1; a + 1 }) %>% bindCache(a, cache = m) 990 expect_identical(p1(), "[1] 3") 991 expect_identical(p2(), "[1] 3") 992 expect_identical(n, 3) 993}) 994 995# ============================================================================== 996# Custom render functions 997# ============================================================================== 998test_that("Custom render functions that call installExprFunction", { 999 # Combinations with `installExprFunction` or `quoToFunction` plus 1000 # `markRenderFunction` or `createRenderFunction` should work. 1001 1002 # The expressions passed into renderDouble below should be converted into this 1003 # function. We'll use this for comparison. 1004 target_cachehint <- list( 1005 origUserFunc = formalsAndBody(function() { n <<- n + 1; a }), 1006 renderFunc = list() 1007 ) 1008 1009 # installExprFunction + createRenderFunction: OK 1010 renderDouble <- function(expr) { 1011 installExprFunction(expr, "func") 1012 createRenderFunction( 1013 func, 1014 transform = function(value, session, name, ...) paste0(value, ",", value) 1015 ) 1016 } 1017 n <- 0 1018 a <- 1 1019 tc <- renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem()) 1020 expect_identical(tc(), "1,1") 1021 expect_identical(tc(), "1,1") 1022 expect_identical(n, 1) 1023 expect_identical( 1024 extractCacheHint(renderDouble({ n <<- n+1; a }))$origUserFunc, 1025 formalsAndBody(function() { n <<- n + 1; a }) 1026 ) 1027 1028 1029 # quoToFunction + createRenderFunction: OK 1030 renderDouble <- function(expr) { 1031 func <- quoToFunction(enquo(expr), "renderDouble") 1032 createRenderFunction( 1033 func, 1034 transform = function(value, session, name, ...) paste0(value, ",", value) 1035 ) 1036 } 1037 # Should work, because it went through createRenderFunction(). 1038 n <- 0 1039 a <- 1 1040 tc <- renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem()) 1041 expect_identical(tc(), "1,1") 1042 expect_identical(tc(), "1,1") 1043 expect_identical(n, 1) 1044 expect_identical( 1045 extractCacheHint(renderDouble({ n <<- n+1; a }))$origUserFunc, 1046 formalsAndBody(function() { n <<- n + 1; a }) 1047 ) 1048 1049 1050 # installExprFunction + markRenderFunction (without cacheHint): warning 1051 # because the original function can't be automatically extracted (it was 1052 # wrapped by installExprFunction). 1053 renderDouble <- function(expr) { 1054 installExprFunction(expr, "func") 1055 markRenderFunction(textOutput, function() { 1056 value <- func() 1057 paste0(value, ",", value) 1058 }) 1059 } 1060 expect_warning(renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem())) 1061 1062 # installExprFunction + markRenderFunction (without cacheHint): warning 1063 # because the original function can't be automatically extracted (it was 1064 # wrapped by installExprFunction). 1065 renderDouble <- function(expr) { 1066 installExprFunction(expr, "func") 1067 markRenderFunction(textOutput, 1068 function() { 1069 value <- func() 1070 paste0(value, ",", value) 1071 }, 1072 cacheHint = list(label = "renderDouble", userExpr = substitute(expr)) 1073 ) 1074 } 1075 n <- 0 1076 a <- 1 1077 tc <- renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem()) 1078 extractCacheHint(renderDouble({ n <<- n+1; a })) 1079 expect_identical(tc(), "1,1") 1080 expect_identical(tc(), "1,1") 1081 expect_identical(n, 1) 1082 expect_identical( 1083 extractCacheHint(renderDouble({ n <<- n+1; a })), 1084 list(label = "renderDouble", userExpr = zap_srcref(quote({ n <<- n+1; a }))) 1085 ) 1086 1087 1088 # quoToFunction + markRenderFunction (without cacheHint): warning 1089 renderDouble <- function(expr) { 1090 func <- quoToFunction(enquo(expr), "renderDouble") 1091 markRenderFunction(textOutput, function() { 1092 value <- func() 1093 paste0(value, ",", value) 1094 }) 1095 } 1096 expect_warning(renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem())) 1097 1098 1099 # quoToFunction + markRenderFunction (with cacheHint): OK 1100 # Also, non-list cacheHint will get wrapped into a list 1101 renderDouble <- function(expr) { 1102 func <- quoToFunction(enquo(expr), "renderDouble") 1103 markRenderFunction(textOutput, 1104 function() { 1105 value <- func() 1106 paste0(value, ",", value) 1107 }, 1108 cacheHint = enexpr(expr) 1109 ) 1110 } 1111 n <- 0 1112 a <- 1 1113 tc <- renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem()) 1114 expect_identical(tc(), "1,1") 1115 expect_identical(tc(), "1,1") 1116 expect_identical(n, 1) 1117 expect_identical( 1118 extractCacheHint(renderDouble({ n <<- n+1; a })), 1119 list(zap_srcref(quote({ n <<- n + 1; a }))) 1120 ) 1121 1122 1123 # installExprFunction + nothing: error 1124 renderTriple <- function(expr) { 1125 installExprFunction(expr, "func") 1126 func 1127 } 1128 expect_error(renderTriple({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem())) 1129 1130 # quoToFunction + nothing: error 1131 renderTriple <- function(expr) { 1132 quoToFunction(enquo(expr), "renderTriple") 1133 } 1134 expect_error(renderTriple({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem())) 1135}) 1136 1137 1138test_that("cacheWriteHook and cacheReadHook for render functions", { 1139 write_hook_n <- 0 1140 read_hook_n <- 0 1141 1142 renderDouble <- function(expr) { 1143 func <- quoToFunction(enquo(expr), "renderDouble") 1144 createRenderFunction( 1145 func, 1146 transform = function(value, session, name, ...) paste0(value, ",", value), 1147 cacheWriteHook = function(value) { 1148 write_hook_n <<- write_hook_n + 1 1149 paste0(value, ",w") 1150 }, 1151 cacheReadHook = function(value) { 1152 read_hook_n <<- read_hook_n + 1 1153 paste0(value, ",r") 1154 } 1155 ) 1156 } 1157 1158 n <- 0 1159 a <- 1 1160 tc <- renderDouble({ n <<- n+1; a }) %>% bindCache(a, cache = cachem::cache_mem()) 1161 expect_identical(tc(), "1,1") 1162 expect_identical(write_hook_n, 1) 1163 expect_identical(read_hook_n, 0) 1164 expect_identical(tc(), "1,1,w,r") 1165 expect_identical(write_hook_n, 1) 1166 expect_identical(read_hook_n, 1) 1167 expect_identical(tc(), "1,1,w,r") 1168 expect_identical(write_hook_n, 1) 1169 expect_identical(read_hook_n, 2) 1170 expect_identical(n, 1) 1171}) 1172 1173test_that("Custom render functions that call exprToFunction", { 1174 # A render function that uses exprToFunction won't work with bindCache(). It 1175 # needs to use quoToFunction or installExprFunction. 1176 1177 renderDouble <- function(expr, env = parent.frame(), quoted = FALSE) { 1178 func <- exprToFunction(expr, env, quoted) 1179 function() { value <- func(); paste0(value, ",", value) } 1180 } 1181 1182 m <- cachem::cache_mem() 1183 # Should throw an error because bindCache doesn't know how to deal with plain 1184 # functions. 1185 expect_error(renderDouble({ a }) %>% bindCache(a, cache = m)) 1186 1187 renderDouble <- function(expr, env = parent.frame(), quoted = FALSE) { 1188 func <- exprToFunction(expr, env, quoted) 1189 } 1190 expect_error(renderDouble({ a }) %>% bindCache(a, cache = m)) 1191 1192 # exprToFunction + markRenderFunction: warning because exprToFunction 1193 # doesn't attach the original function as metadata. 1194 renderDouble <- function(expr, env = parent.frame(), quoted = FALSE) { 1195 func <- exprToFunction(expr, env, quoted) 1196 markRenderFunction(textOutput, func) 1197 } 1198 expect_warning(renderDouble({ a }) %>% bindCache(a, cache = m)) 1199 1200 # exprToFunction + createRenderFunction: warning because exprToFunction 1201 # doesn't attach the original function as metadata. 1202 renderDouble <- function(expr, env = parent.frame(), quoted = FALSE) { 1203 func <- exprToFunction(expr, env, quoted) 1204 createRenderFunction(func, outputFunc = textOutput) 1205 } 1206 expect_warning(renderDouble({ a }) %>% bindCache(a, cache = m)) 1207}) 1208 1209 1210test_that("Some render functions can't be cached", { 1211 m <- cachem::cache_mem() 1212 expect_error(renderDataTable({ cars }) %>% bindCache(1, cache = m)) 1213 expect_error(renderCachedPlot({ plot(1) }, 1) %>% bindCache(1, cache = m)) 1214 expect_error(renderImage({ cars }) %>% bindCache(1, cache = m)) 1215}) 1216 1217 1218test_that("cacheHint to avoid collisions", { 1219 # Same function and expression -> same cache hint 1220 expect_identical( 1221 extractCacheHint(renderText({ a + 1 })), 1222 extractCacheHint(renderText({ a + 1 })), 1223 ) 1224 expect_identical( 1225 extractCacheHint(renderPrint({ a + 1 })), 1226 extractCacheHint(renderPrint({ a + 1 })) 1227 ) 1228 expect_identical( 1229 extractCacheHint(renderUI({ a + 1 })), 1230 extractCacheHint(renderUI({ a + 1 })) 1231 ) 1232 expect_identical( 1233 extractCacheHint(renderTable({ a + 1 })), 1234 extractCacheHint(renderTable({ a + 1 })) 1235 ) 1236 1237 # Different expressions -> different cache hint 1238 expect_false(identical( 1239 extractCacheHint(renderText({ a + 1 })), 1240 extractCacheHint(renderText({ a + 2 })) 1241 )) 1242 expect_false(identical( 1243 extractCacheHint(renderPrint({ a + 1 })), 1244 extractCacheHint(renderPrint({ a + 2 })) 1245 )) 1246 expect_false(identical( 1247 extractCacheHint(renderUI({ a + 1 })), 1248 extractCacheHint(renderUI({ a + 2 })) 1249 )) 1250 expect_false(identical( 1251 extractCacheHint(renderTable({ a + 1 })), 1252 extractCacheHint(renderTable({ a + 2 })) 1253 )) 1254 1255 # Different functions -> different cache hint 1256 expect_false(identical( 1257 extractCacheHint(renderText({ a + 1 })), 1258 extractCacheHint(renderPrint({ a + 1 })) 1259 )) 1260 expect_false(identical( 1261 extractCacheHint(renderText({ a + 1 })), 1262 extractCacheHint(renderUI({ a + 1 })) 1263 )) 1264}) 1265 1266 1267test_that("cacheHint works with quosures", { 1268 # Cache hint ignores environment 1269 my_quo <- local({ 1270 a <- 5 1271 rlang::quo({a + 1}) 1272 }) 1273 ap1 <- rlang::expr({a+1}) 1274 plotCacheList <- list(userExpr = ap1, res = 72) 1275 reactiveCacheList <- list(userExpr = ap1) 1276 quoCacheList <- list(q = ap1) 1277 1278 1279 # render** 1280 # Regular expression, quoted quosure object, injected quosure object 1281 expect_equal( 1282 extractCacheHint(renderPlot({ a + 1 })), 1283 plotCacheList 1284 ) 1285 expect_equal( 1286 extractCacheHint(renderPlot(my_quo, quoted = TRUE)), 1287 plotCacheList 1288 ) 1289 expect_equal( 1290 extractCacheHint(inject(renderPlot(!!my_quo))), 1291 plotCacheList 1292 ) 1293 1294 # reactive 1295 # Regular expression, quoted quosure object, injected quosure object 1296 expect_equal( 1297 extractCacheHint(reactive(a + 1)), 1298 reactiveCacheList 1299 ) 1300 expect_equal( 1301 extractCacheHint(reactive(my_quo, quoted = TRUE)), 1302 reactiveCacheList 1303 ) 1304 expect_equal( 1305 extractCacheHint(inject(reactive(!!my_quo))), 1306 reactiveCacheList 1307 ) 1308 1309 # markRenderFunction handles raw quosure objects as cacheHint 1310 expect_equal( 1311 extractCacheHint( 1312 markRenderFunction(force, force, cacheHint = list(q = my_quo)) 1313 ), 1314 quoCacheList 1315 ) 1316}) 1317