/
bookmark-state.R
1220 lines (1114 loc) · 39.6 KB
/
bookmark-state.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
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
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
ShinySaveState <- R6Class("ShinySaveState",
public = list(
input = NULL,
exclude = NULL,
onSave = NULL, # A callback to invoke during the saving process.
# These are set not in initialize(), but by external functions that modify
# the ShinySaveState object.
dir = NULL,
initialize = function(input = NULL, exclude = NULL, onSave = NULL) {
self$input <- input
self$exclude <- exclude
self$onSave <- onSave
private$values_ <- new.env(parent = emptyenv())
}
),
active = list(
# `values` looks to the outside world like an environment for storing
# arbitrary values. Two things to note: (1) This is an environment (instead
# of, say, a list) because if the onSave function represents multiple
# callback functions (when onBookmark is called multiple times), each
# callback can change `values`, and if we used a list, one of the callbacks
# could easily obliterate values set by another. This can happen when using
# modules that have an onBookmark function. (2) The purpose of the active
# binding is to prevent replacing state$values with another arbitrary
# object. (Simply locking the binding would prevent all changes to
# state$values.)
values = function(value) {
if (missing(value))
return(private$values_)
if (identical(value, private$values_)) {
return(value)
} else {
stop("Items in `values` can be changed, but `values` itself cannot be replaced.")
}
}
),
private = list(
values_ = NULL
)
)
# Save a state to disk. Returns a query string which can be used to restore the
# session.
saveShinySaveState <- function(state) {
id <- createUniqueId(8)
# A function for saving the state object to disk, given a directory to save
# to.
saveState <- function(stateDir) {
state$dir <- stateDir
# Allow user-supplied onSave function to do things like add state$values, or
# save data to state dir.
if (!is.null(state$onSave))
isolate(state$onSave(state))
# Serialize values, possibly saving some extra data to stateDir
exclude <- c(state$exclude, "._bookmark_")
inputValues <- serializeReactiveValues(state$input, exclude, state$dir)
saveRDS(inputValues, file.path(stateDir, "input.rds"))
# If values were added, save them also.
if (length(state$values) != 0)
saveRDS(state$values, file.path(stateDir, "values.rds"))
}
# Pass the saveState function to the save interface function, which will
# invoke saveState after preparing the directory.
# Look for a save.interface function. This will be defined by the hosting
# environment if it supports bookmarking.
saveInterface <- getShinyOption("save.interface", default = NULL)
if (is.null(saveInterface)) {
if (inShinyServer()) {
# We're in a version of Shiny Server/Connect that doesn't have
# bookmarking support.
saveInterface <- function(id, callback) {
stop("The hosting environment does not support saved-to-server bookmarking.")
}
} else {
# We're running Shiny locally.
saveInterface <- saveInterfaceLocal
}
}
saveInterface(id, saveState)
paste0("_state_id_=", encodeURIComponent(id))
}
# Encode the state to a URL. This does not save to disk.
encodeShinySaveState <- function(state) {
exclude <- c(state$exclude, "._bookmark_")
inputVals <- serializeReactiveValues(state$input, exclude, stateDir = NULL)
# Allow user-supplied onSave function to do things like add state$values.
if (!is.null(state$onSave))
isolate(state$onSave(state))
inputVals <- vapply(inputVals,
function(x) toJSON(x, strict_atomic = FALSE),
character(1),
USE.NAMES = TRUE
)
res <- ""
# If any input values are present, add them.
if (length(inputVals) != 0) {
res <- paste0(res, "_inputs_&",
paste0(
encodeURIComponent(names(inputVals)),
"=",
encodeURIComponent(inputVals),
collapse = "&"
)
)
}
# If 'values' is present, add them as well.
if (length(state$values) != 0) {
values <- vapply(state$values,
function(x) toJSON(x, strict_atomic = FALSE),
character(1),
USE.NAMES = TRUE
)
res <- paste0(res,
if (length(inputVals != 0)) "&", # Add separator if there were inputs
"_values_&",
paste0(
encodeURIComponent(names(values)),
"=",
encodeURIComponent(values),
collapse = "&"
)
)
}
res
}
RestoreContext <- R6Class("RestoreContext",
public = list(
# This will be set to TRUE if there's actually a state to restore
active = FALSE,
# This is set to an error message string in case there was an initialization
# error. Later, after the app has started on the client, the server can send
# this message as a notification on the client.
initErrorMessage = NULL,
# This is a RestoreInputSet for input values. This is a key-value store with
# some special handling.
input = NULL,
# Directory for extra files, if restoring from state that was saved to disk.
dir = NULL,
# For values other than input values. These values don't need the special
# phandling that's needed for input values, because they're only accessed
# from the onRestore function.
values = NULL,
initialize = function(queryString = NULL) {
self$reset() # Need this to initialize self$input
if (!is.null(queryString) && nzchar(queryString)) {
tryCatch(
withLogErrors({
qsValues <- parseQueryString(queryString, nested = TRUE)
if (!is.null(qsValues[["__subapp__"]]) && qsValues[["__subapp__"]] == 1) {
# Ignore subapps in shiny docs
self$reset()
} else if (!is.null(qsValues[["_state_id_"]]) && nzchar(qsValues[["_state_id_"]])) {
# If we have a "_state_id_" key, restore from saved state and
# ignore other key/value pairs. If not, restore from key/value
# pairs in the query string.
self$active <- TRUE
private$loadStateQueryString(queryString)
} else {
# The query string contains the saved keys and values
self$active <- TRUE
private$decodeStateQueryString(queryString)
}
}),
error = function(e) {
# If there's an error in restoring problem, just reset these values
self$reset()
self$initErrorMessage <- e$message
warning(e$message)
}
)
}
},
reset = function() {
self$active <- FALSE
self$initErrorMessage <- NULL
self$input <- RestoreInputSet$new(list())
self$values <- new.env(parent = emptyenv())
self$dir <- NULL
},
# Completely replace the state
set = function(active = FALSE, initErrorMessage = NULL, input = list(), values = list(), dir = NULL) {
# Validate all inputs
stopifnot(is.logical(active))
stopifnot(is.null(initErrorMessage) || is.character(initErrorMessage))
stopifnot(is.list(input))
stopifnot(is.list(values))
stopifnot(is.null(dir) || is.character(dir))
self$active <- active
self$initErrorMessage <- initErrorMessage
self$input <- RestoreInputSet$new(input)
self$values <- list2env2(values, parent = emptyenv())
self$dir <- dir
},
# This should be called before a restore context is popped off the stack.
flushPending = function() {
self$input$flushPending()
},
# Returns a list representation of the RestoreContext object. This is passed
# to the app author's onRestore function. An important difference between
# the RestoreContext object and the list is that the former's `input` field
# is a RestoreInputSet object, while the latter's `input` field is just a
# list.
asList = function() {
list(
input = self$input$asList(),
dir = self$dir,
values = self$values
)
}
),
private = list(
# Given a query string with a _state_id_, load saved state with that ID.
loadStateQueryString = function(queryString) {
values <- parseQueryString(queryString, nested = TRUE)
id <- values[["_state_id_"]]
# Check that id has only alphanumeric chars
if (grepl("[^a-zA-Z0-9]", id)) {
stop("Invalid state id: ", id)
}
# This function is passed to the loadInterface function; given a
# directory, it will load state from that directory
loadFun <- function(stateDir) {
self$dir <- stateDir
if (!dirExists(stateDir)) {
stop("Bookmarked state directory does not exist.")
}
tryCatch({
inputValues <- readRDS(file.path(stateDir, "input.rds"))
self$input <- RestoreInputSet$new(inputValues)
},
error = function(e) {
stop("Error reading input values file.")
}
)
valuesFile <- file.path(stateDir, "values.rds")
if (file.exists(valuesFile)) {
tryCatch({
self$values <- readRDS(valuesFile)
},
error = function(e) {
stop("Error reading values file.")
}
)
}
}
# Look for a load.interface function. This will be defined by the hosting
# environment if it supports bookmarking.
loadInterface <- getShinyOption("load.interface", default = NULL)
if (is.null(loadInterface)) {
if (inShinyServer()) {
# We're in a version of Shiny Server/Connect that doesn't have
# bookmarking support.
loadInterface <- function(id, callback) {
stop("The hosting environment does not support saved-to-server bookmarking.")
}
} else {
# We're running Shiny locally.
loadInterface <- loadInterfaceLocal
}
}
loadInterface(id, loadFun)
invisible()
},
# Given a query string with values encoded in it, restore saved state
# from those values.
decodeStateQueryString = function(queryString) {
# Remove leading '?'
if (substr(queryString, 1, 1) == '?')
queryString <- substr(queryString, 2, nchar(queryString))
# Error if multiple '_inputs_' or '_values_'. This is needed because
# strsplit won't add an entry if the search pattern is at the end of a
# string.
if (length(gregexpr("(^|&)_inputs_(&|$)", queryString)[[1]]) > 1)
stop("Invalid state string: more than one '_inputs_' found")
if (length(gregexpr("(^|&)_values_(&|$)", queryString)[[1]]) > 1)
stop("Invalid state string: more than one '_values_' found")
# Look for _inputs_ and store following content in inputStr
splitStr <- strsplit(queryString, "(^|&)_inputs_(&|$)")[[1]]
if (length(splitStr) == 2) {
inputStr <- splitStr[2]
# Remove any _values_ (and content after _values_) that may come after
# _inputs_
inputStr <- strsplit(inputStr, "(^|&)_values_(&|$)")[[1]][1]
} else {
inputStr <- ""
}
# Look for _values_ and store following content in valueStr
splitStr <- strsplit(queryString, "(^|&)_values_(&|$)")[[1]]
if (length(splitStr) == 2) {
valueStr <- splitStr[2]
# Remove any _inputs_ (and content after _inputs_) that may come after
# _values_
valueStr <- strsplit(valueStr, "(^|&)_inputs_(&|$)")[[1]][1]
} else {
valueStr <- ""
}
inputs <- parseQueryString(inputStr, nested = TRUE)
values <- parseQueryString(valueStr, nested = TRUE)
valuesFromJSON <- function(vals) {
mapply(names(vals), vals, SIMPLIFY = FALSE,
FUN = function(name, value) {
tryCatch(
safeFromJSON(value),
error = function(e) {
stop("Failed to parse URL parameter \"", name, "\"")
}
)
}
)
}
inputs <- valuesFromJSON(inputs)
self$input <- RestoreInputSet$new(inputs)
values <- valuesFromJSON(values)
self$values <- list2env2(values, self$values)
}
)
)
# Restore input set. This is basically a key-value store, except for one
# important difference: When the user `get()`s a value, the value is marked as
# pending; when `flushPending()` is called, those pending values are marked as
# used. When a value is marked as used, `get()` will not return it, unless
# called with `force=TRUE`. This is to make sure that a particular value can be
# restored only within a single call to `withRestoreContext()`. Without this, if
# a value is restored in a dynamic UI, it could completely prevent any other
# (non- restored) kvalue from being used.
RestoreInputSet <- R6Class("RestoreInputSet",
private = list(
values = NULL,
pending = character(0),
used = character(0) # Names of values which have been used
),
public = list(
initialize = function(values) {
private$values <- list2env2(values, parent = emptyenv())
},
exists = function(name) {
exists(name, envir = private$values)
},
# Return TRUE if the value exists and has not been marked as used.
available = function(name) {
self$exists(name) && !self$isUsed(name)
},
isPending = function(name) {
name %in% private$pending
},
isUsed = function(name) {
name %in% private$used
},
# Get a value. If `force` is TRUE, get the value without checking whether
# has been used, and without marking it as pending.
get = function(name, force = FALSE) {
if (force)
return(private$values[[name]])
if (!self$available(name))
return(NULL)
# Mark this name as pending. Use unique so that it's not added twice.
private$pending <- unique(c(private$pending, name))
private$values[[name]]
},
# Take pending names and mark them as used, then clear pending list.
flushPending = function() {
private$used <- unique(c(private$used, private$pending))
private$pending <- character(0)
},
asList = function() {
as.list.environment(private$values, all.names = TRUE)
}
)
)
# This is a fastmap::faststack(); value is assigned in .onLoad().
restoreCtxStack <- NULL
withRestoreContext <- function(ctx, expr) {
restoreCtxStack$push(ctx)
on.exit({
# Mark pending names as used
restoreCtxStack$peek()$flushPending()
restoreCtxStack$pop()
}, add = TRUE)
force(expr)
}
# Is there a current restore context?
hasCurrentRestoreContext <- function() {
if (restoreCtxStack$size() > 0)
return(TRUE)
domain <- getDefaultReactiveDomain()
if (!is.null(domain) && !is.null(domain$restoreContext))
return(TRUE)
return(FALSE)
}
# Call to access the current restore context. First look on the restore
# context stack, and if not found, then see if there's one on the current
# reactive domain. In practice, the only time there will be a restore context
# on the stack is when executing the UI function; when executing server code,
# the restore context will be attached to the domain/session.
getCurrentRestoreContext <- function() {
ctx <- restoreCtxStack$peek()
if (is.null(ctx)) {
domain <- getDefaultReactiveDomain()
if (is.null(domain) || is.null(domain$restoreContext)) {
stop("No restore context found")
}
ctx <- domain$restoreContext
}
ctx
}
#' Restore an input value
#'
#' This restores an input value from the current restore context. It should be
#' called early on inside of input functions (like [textInput()]).
#'
#' @param id Name of the input value to restore.
#' @param default A default value to use, if there's no value to restore.
#'
#' @export
restoreInput <- function(id, default) {
# Need to evaluate `default` in case it contains reactives like input$x. If we
# don't, then the calling code won't take a reactive dependency on input$x
# when restoring a value.
force(default)
if (!hasCurrentRestoreContext()) {
return(default)
}
oldInputs <- getCurrentRestoreContext()$input
if (oldInputs$available(id)) {
oldInputs$get(id)
} else {
default
}
}
#' Update URL in browser's location bar
#'
#' This function updates the client browser's query string in the location bar.
#' It typically is called from an observer. Note that this will not work in
#' Internet Explorer 9 and below.
#'
#' For `mode = "push"`, only three updates are currently allowed:
#' \enumerate{
#' \item the query string (format: `?param1=val1¶m2=val2`)
#' \item the hash (format: `#hash`)
#' \item both the query string and the hash
#' (format: `?param1=val1¶m2=val2#hash`)
#' }
#'
#' In other words, if `mode = "push"`, the `queryString` must start
#' with either `?` or with `#`.
#'
#' A technical curiosity: under the hood, this function is calling the HTML5
#' history API (which is where the names for the `mode` argument come from).
#' When `mode = "replace"`, the function called is
#' `window.history.replaceState(null, null, queryString)`.
#' When `mode = "push"`, the function called is
#' `window.history.pushState(null, null, queryString)`.
#'
#' @param queryString The new query string to show in the location bar.
#' @param mode When the query string is updated, should the the current history
#' entry be replaced (default), or should a new history entry be pushed onto
#' the history stack? The former should only be used in a live bookmarking
#' context. The latter is useful if you want to navigate between states using
#' the browser's back and forward buttons. See Examples.
#' @param session A Shiny session object.
#' @seealso [enableBookmarking()], [getQueryString()]
#' @examples
#' ## Only run these examples in interactive sessions
#' if (interactive()) {
#'
#' ## App 1: Doing "live" bookmarking
#' ## Update the browser's location bar every time an input changes.
#' ## This should not be used with enableBookmarking("server"),
#' ## because that would create a new saved state on disk every time
#' ## the user changes an input.
#' enableBookmarking("url")
#' shinyApp(
#' ui = function(req) {
#' fluidPage(
#' textInput("txt", "Text"),
#' checkboxInput("chk", "Checkbox")
#' )
#' },
#' server = function(input, output, session) {
#' observe({
#' # Trigger this observer every time an input changes
#' reactiveValuesToList(input)
#' session$doBookmark()
#' })
#' onBookmarked(function(url) {
#' updateQueryString(url)
#' })
#' }
#' )
#'
#' ## App 2: Printing the value of the query string
#' ## (Use the back and forward buttons to see how the browser
#' ## keeps a record of each state)
#' shinyApp(
#' ui = fluidPage(
#' textInput("txt", "Enter new query string"),
#' helpText("Format: ?param1=val1¶m2=val2"),
#' actionButton("go", "Update"),
#' hr(),
#' verbatimTextOutput("query")
#' ),
#' server = function(input, output, session) {
#' observeEvent(input$go, {
#' updateQueryString(input$txt, mode = "push")
#' })
#' output$query <- renderText({
#' query <- getQueryString()
#' queryText <- paste(names(query), query,
#' sep = "=", collapse=", ")
#' paste("Your query string is:\n", queryText)
#' })
#' }
#' )
#' }
#' @export
updateQueryString <- function(queryString, mode = c("replace", "push"),
session = getDefaultReactiveDomain()) {
mode <- match.arg(mode)
session$updateQueryString(queryString, mode)
}
#' Create a button for bookmarking/sharing
#'
#' A `bookmarkButton` is a [actionButton()] with a default label
#' that consists of a link icon and the text "Bookmark...". It is meant to be
#' used for bookmarking state.
#'
#' @inheritParams actionButton
#' @param title A tooltip that is shown when the mouse cursor hovers over the
#' button.
#' @param id An ID for the bookmark button. The only time it is necessary to set
#' the ID unless you have more than one bookmark button in your application.
#' If you specify an input ID, it should be excluded from bookmarking with
#' [setBookmarkExclude()], and you must create an observer that
#' does the bookmarking when the button is pressed. See the examples below.
#'
#' @seealso [enableBookmarking()] for more examples.
#'
#' @examples
#' ## Only run these examples in interactive sessions
#' if (interactive()) {
#'
#' # This example shows how to use multiple bookmark buttons. If you only need
#' # a single bookmark button, see examples in ?enableBookmarking.
#' ui <- function(request) {
#' fluidPage(
#' tabsetPanel(id = "tabs",
#' tabPanel("One",
#' checkboxInput("chk1", "Checkbox 1"),
#' bookmarkButton(id = "bookmark1")
#' ),
#' tabPanel("Two",
#' checkboxInput("chk2", "Checkbox 2"),
#' bookmarkButton(id = "bookmark2")
#' )
#' )
#' )
#' }
#' server <- function(input, output, session) {
#' # Need to exclude the buttons from themselves being bookmarked
#' setBookmarkExclude(c("bookmark1", "bookmark2"))
#'
#' # Trigger bookmarking with either button
#' observeEvent(input$bookmark1, {
#' session$doBookmark()
#' })
#' observeEvent(input$bookmark2, {
#' session$doBookmark()
#' })
#' }
#' enableBookmarking(store = "url")
#' shinyApp(ui, server)
#' }
#' @export
bookmarkButton <- function(label = "Bookmark...",
icon = shiny::icon("link", lib = "glyphicon"),
title = "Bookmark this application's state and get a URL for sharing.",
...,
id = "._bookmark_")
{
actionButton(id, label, icon, title = title, ...)
}
#' Generate a modal dialog that displays a URL
#'
#' The modal dialog generated by `urlModal` will display the URL in a
#' textarea input, and the URL text will be selected so that it can be easily
#' copied. The result from `urlModal` should be passed to the
#' [showModal()] function to display it in the browser.
#'
#' @param url A URL to display in the dialog box.
#' @param title A title for the dialog box.
#' @param subtitle Text to display underneath URL.
#' @export
urlModal <- function(url, title = "Bookmarked application link", subtitle = NULL) {
subtitleTag <- tagList(
br(),
span(class = "text-muted", subtitle),
span(id = "shiny-bookmark-copy-text", class = "text-muted")
)
modalDialog(
title = title,
easyClose = TRUE,
tags$textarea(class = "form-control", rows = "1", style = "resize: none;",
readonly = "readonly",
url
),
subtitleTag,
# Need separate show and shown listeners. The show listener sizes the
# textarea just as the modal starts to fade in. The 200ms delay is needed
# because if we try to resize earlier, it can't calculate the text height
# (scrollHeight will be reported as zero). The shown listener selects the
# text; it's needed because because selection has to be done after the fade-
# in is completed.
tags$script(
"$('#shiny-modal').
one('show.bs.modal', function() {
setTimeout(function() {
var $textarea = $('#shiny-modal textarea');
$textarea.innerHeight($textarea[0].scrollHeight);
}, 200);
});
$('#shiny-modal')
.one('shown.bs.modal', function() {
$('#shiny-modal textarea').select().focus();
});
$('#shiny-bookmark-copy-text')
.text(function() {
if (/Mac/i.test(navigator.userAgent)) {
return 'Press \u2318-C to copy.';
} else {
return 'Press Ctrl-C to copy.';
}
});
"
)
)
}
#' Display a modal dialog for bookmarking
#'
#' This is a wrapper function for [urlModal()] that is automatically
#' called if an application is bookmarked but no other [onBookmark()]
#' callback was set. It displays a modal dialog with the bookmark URL, along
#' with a subtitle that is appropriate for the type of bookmarking used ("url"
#' or "server").
#'
#' @param url A URL to show in the modal dialog.
#' @export
showBookmarkUrlModal <- function(url) {
store <- getShinyOption("bookmarkStore", default = "")
if (store == "url") {
subtitle <- "This link stores the current state of this application."
} else if (store == "server") {
subtitle <- "The current state of this application has been stored on the server."
} else {
subtitle <- NULL
}
showModal(urlModal(url, subtitle = subtitle))
}
#' Enable bookmarking for a Shiny application
#'
#' @description
#'
#' There are two types of bookmarking: saving an application's state to disk on
#' the server, and encoding the application's state in a URL. For state that has
#' been saved to disk, the state can be restored with the corresponding state
#' ID. For URL-encoded state, the state of the application is encoded in the
#' URL, and no server-side storage is needed.
#'
#' URL-encoded bookmarking is appropriate for applications where there not many
#' input values that need to be recorded. Some browsers have a length limit for
#' URLs of about 2000 characters, and if there are many inputs, the length of
#' the URL can exceed that limit.
#'
#' Saved-on-server bookmarking is appropriate when there are many inputs, or
#' when the bookmarked state requires storing files.
#'
#' @details
#'
#' For restoring state to work properly, the UI must be a function that takes
#' one argument, `request`. In most Shiny applications, the UI is not a
#' function; it might have the form `fluidPage(....)`. Converting it to a
#' function is as simple as wrapping it in a function, as in
#' \code{function(request) \{ fluidPage(....) \}}.
#'
#' By default, all input values will be bookmarked, except for the values of
#' passwordInputs. fileInputs will be saved if the state is saved on a server,
#' but not if the state is encoded in a URL.
#'
#' When bookmarking state, arbitrary values can be stored, by passing a function
#' as the `onBookmark` argument. That function will be passed a
#' `ShinySaveState` object. The `values` field of the object is a list
#' which can be manipulated to save extra information. Additionally, if the
#' state is being saved on the server, and the `dir` field of that object
#' can be used to save extra information to files in that directory.
#'
#' For saved-to-server state, this is how the state directory is chosen:
#' \itemize{
#' \item If running in a hosting environment such as Shiny Server or
#' Connect, the hosting environment will choose the directory.
#' \item If running an app in a directory with [runApp()], the
#' saved states will be saved in a subdirectory of the app called
#' shiny_bookmarks.
#' \item If running a Shiny app object that is generated from code (not run
#' from a directory), the saved states will be saved in a subdirectory of
#' the current working directory called shiny_bookmarks.
#' }
#'
#' When used with [shinyApp()], this function must be called before
#' `shinyApp()`, or in the `shinyApp()`'s `onStart` function. An
#' alternative to calling the `enableBookmarking()` function is to use the
#' `enableBookmarking` *argument* for `shinyApp()`. See examples
#' below.
#'
#' @param store Either `"url"`, which encodes all of the relevant values in
#' a URL, `"server"`, which saves to disk on the server, or
#' `"disable"`, which disables any previously-enabled bookmarking.
#'
#' @seealso [onBookmark()], [onBookmarked()],
#' [onRestore()], and [onRestored()] for registering
#' callback functions that are invoked when the state is bookmarked or
#' restored.
#'
#' Also see [updateQueryString()].
#'
#' @export
#' @examples
#' ## Only run these examples in interactive R sessions
#' if (interactive()) {
#'
#' # Basic example with state encoded in URL
#' ui <- function(request) {
#' fluidPage(
#' textInput("txt", "Text"),
#' checkboxInput("chk", "Checkbox"),
#' bookmarkButton()
#' )
#' }
#' server <- function(input, output, session) { }
#' enableBookmarking("url")
#' shinyApp(ui, server)
#'
#'
#' # An alternative to calling enableBookmarking(): use shinyApp's
#' # enableBookmarking argument
#' shinyApp(ui, server, enableBookmarking = "url")
#'
#'
#' # Same basic example with state saved to disk
#' enableBookmarking("server")
#' shinyApp(ui, server)
#'
#'
#' # Save/restore arbitrary values
#' ui <- function(req) {
#' fluidPage(
#' textInput("txt", "Text"),
#' checkboxInput("chk", "Checkbox"),
#' bookmarkButton(),
#' br(),
#' textOutput("lastSaved")
#' )
#' }
#' server <- function(input, output, session) {
#' vals <- reactiveValues(savedTime = NULL)
#' output$lastSaved <- renderText({
#' if (!is.null(vals$savedTime))
#' paste("Last saved at", vals$savedTime)
#' else
#' ""
#' })
#'
#' onBookmark(function(state) {
#' vals$savedTime <- Sys.time()
#' # state is a mutable reference object, and we can add arbitrary values
#' # to it.
#' state$values$time <- vals$savedTime
#' })
#' onRestore(function(state) {
#' vals$savedTime <- state$values$time
#' })
#' }
#' enableBookmarking(store = "url")
#' shinyApp(ui, server)
#'
#'
#' # Usable with dynamic UI (set the slider, then change the text input,
#' # click the bookmark button)
#' ui <- function(request) {
#' fluidPage(
#' sliderInput("slider", "Slider", 1, 100, 50),
#' uiOutput("ui"),
#' bookmarkButton()
#' )
#' }
#' server <- function(input, output, session) {
#' output$ui <- renderUI({
#' textInput("txt", "Text", input$slider)
#' })
#' }
#' enableBookmarking("url")
#' shinyApp(ui, server)
#'
#'
#' # Exclude specific inputs (The only input that will be saved in this
#' # example is chk)
#' ui <- function(request) {
#' fluidPage(
#' passwordInput("pw", "Password"), # Passwords are never saved
#' sliderInput("slider", "Slider", 1, 100, 50), # Manually excluded below
#' checkboxInput("chk", "Checkbox"),
#' bookmarkButton()
#' )
#' }
#' server <- function(input, output, session) {
#' setBookmarkExclude("slider")
#' }
#' enableBookmarking("url")
#' shinyApp(ui, server)
#'
#'
#' # Update the browser's location bar every time an input changes. This should
#' # not be used with enableBookmarking("server"), because that would create a
#' # new saved state on disk every time the user changes an input.
#' ui <- function(req) {
#' fluidPage(
#' textInput("txt", "Text"),
#' checkboxInput("chk", "Checkbox")
#' )
#' }
#' server <- function(input, output, session) {
#' observe({
#' # Trigger this observer every time an input changes
#' reactiveValuesToList(input)
#' session$doBookmark()
#' })
#' onBookmarked(function(url) {
#' updateQueryString(url)
#' })
#' }
#' enableBookmarking("url")
#' shinyApp(ui, server)
#'
#'
#' # Save/restore uploaded files
#' ui <- function(request) {
#' fluidPage(
#' sidebarLayout(
#' sidebarPanel(
#' fileInput("file1", "Choose CSV File", multiple = TRUE,
#' accept = c(
#' "text/csv",
#' "text/comma-separated-values,text/plain",
#' ".csv"
#' )
#' ),
#' tags$hr(),
#' checkboxInput("header", "Header", TRUE),
#' bookmarkButton()
#' ),
#' mainPanel(
#' tableOutput("contents")
#' )
#' )
#' )
#' }
#' server <- function(input, output) {
#' output$contents <- renderTable({
#' inFile <- input$file1
#' if (is.null(inFile))
#' return(NULL)
#'
#' if (nrow(inFile) == 1) {
#' read.csv(inFile$datapath, header = input$header)
#' } else {
#' data.frame(x = "multiple files")
#' }
#' })
#' }
#' enableBookmarking("server")
#' shinyApp(ui, server)
#'
#' }
enableBookmarking <- function(store = c("url", "server", "disable")) {
store <- match.arg(store)
shinyOptions(bookmarkStore = store)
}
#' Exclude inputs from bookmarking
#'
#' This function tells Shiny which inputs should be excluded from bookmarking.
#' It should be called from inside the application's server function.
#'
#' This function can also be called from a module's server function, in which
#' case it will exclude inputs with the specified names, from that module. It
#' will not affect inputs from other modules or from the top level of the Shiny
#' application.
#'
#' @param names A character vector containing names of inputs to exclude from
#' bookmarking.
#' @param session A shiny session object.
#' @seealso [enableBookmarking()] for examples.
#' @export