-
-
Notifications
You must be signed in to change notification settings - Fork 30
/
Copy pathdash.R
1625 lines (1418 loc) · 70.8 KB
/
dash.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
#' Create and configure a Dash app object
#'
#' A framework for building analytical web applications, Dash offers a pleasant and productive development experience. No JavaScript required.
#'
#' @usage Dash
#'
#' @section Constructor: Dash$new(
#' name = NULL,
#' server = fiery::Fire$new(),
#' assets_folder = 'assets',
#' assets_url_path = '/assets',
#' eager_loading = FALSE,
#' assets_ignore = '',
#' serve_locally = TRUE,
#' meta_tags = NULL,
#' url_base_pathname = '/',
#' routes_pathname_prefix = NULL,
#' requests_pathname_prefix = NULL,
#' external_scripts = NULL,
#' external_stylesheets = NULL,
#' suppress_callback_exceptions = FALSE
#' )
#'
#' @section Arguments:
#' \tabular{lll}{
#' `name` \tab \tab Character. The name of the Dash application (placed in the `<title>`
#' of the HTML page). DEPRECATED; please use `index_string()` or `interpolate_index()` instead.\cr
#' `server` \tab \tab The web server used to power the application.
#' Must be a [fiery::Fire] object.\cr
#' `assets_folder` \tab \tab Character. A path, relative to the current working directory,
#' for extra files to be used in the browser. Default is "assets". All .js and
#' .css files will be loaded immediately unless excluded by `assets_ignore`,
#' and other files such as images will be served if requested. Default is `assets`. \cr
#' `assets_url_path` \tab \tab Character. Specify the URL path for asset serving. Default is `assets`. \cr
#' `eager_loading` \tab \tab Logical. Controls whether asynchronous resources are prefetched (if `TRUE`) or loaded on-demand (if `FALSE`). \cr
#' `assets_ignore` \tab \tab Character. A regular expression, to match assets to omit from
#' immediate loading. Ignored files will still be served if specifically requested. You
#' cannot use this to prevent access to sensitive files. \cr
#' `serve_locally` \tab \tab Logical. Whether to serve HTML dependencies locally or
#' remotely (via URL).\cr
#' `meta_tags` \tab \tab List of lists. HTML `<meta>`tags to be added to the index page.
#' Each list element should have the attributes and values for one tag, eg:
#' `list(name = 'description', content = 'My App')`.\cr
#' `url_base_pathname` \tab \tab Character. A local URL prefix to use app-wide. Default is
#' `/`. Both `requests_pathname_prefix` and `routes_pathname_prefix` default to `url_base_pathname`.
#' Environment variable is `DASH_URL_BASE_PATHNAME`.\cr
#' `routes_pathname_prefix` \tab \tab Character. A prefix applied to the backend routes.
#' Environment variable is `DASH_ROUTES_PATHNAME_PREFIX`.\cr
#' `requests_pathname_prefix` \tab \tab Character. A prefix applied to request endpoints
#' made by Dash's front-end. Environment variable is `DASH_REQUESTS_PATHNAME_PREFIX`.\cr
#' `external_scripts` \tab \tab List. An optional list of valid URLs from which
#' to serve JavaScript source for rendered pages.\cr
#' `external_stylesheets` \tab \tab List. An optional list of valid URLs from which
#' to serve CSS for rendered pages.\cr
#' `suppress_callback_exceptions` \tab \tab Logical. Whether to relay warnings about
#' possible layout mis-specifications when registering a callback.
#' }
#'
#' @section Fields:
#' \describe{
#' \item{`server`}{
#' A cloned (and modified) version of the [fiery::Fire] object
#' provided to the `server` argument (various routes will be added which enable
#' Dash functionality).
#' }
#' \item{`config`}{
#' A list of configuration options passed along to dash-renderer.
#' Users shouldn't need to alter any of these options unless they are
#' constructing their own authorization front-end or otherwise need to know
#' where the application is making API calls.
#' }
#' }
#'
#' @section Methods:
#' \describe{
#' \item{`layout(...)`}{
#' Set the layout (i.e., user interface). The layout should be either a
#' collection of Dash components (e.g., [dccSlider], [htmlDiv], etc) or
#' a function which returns a collection of components.
#' }
#' \item{`layout_get(render = TRUE)`}{
#' Retrieves the layout. If render is `TRUE`, and the layout is a function,
#' the result of the function (rather than the function itself) is returned.
#' }
#' \item{`callback(output, params, func)`}{
#' The `callback` method has three formal arguments:
#' \describe{
#' \item{output}{a named list including a component `id` and `property`}
#' \item{params}{an unnamed list of [input] and [state] statements, each with defined `id` and `property`}
#' \item{func}{any valid R function which generates [output] provided [input] and/or [state] arguments, or a call to [clientsideFunction] including `namespace` and `function_name` arguments for a locally served JavaScript function}
#' }
#' The `output` argument defines which layout component property should
#' receive the results (via the [output] object). The events that
#' trigger the callback are then described by the [input] (and/or [state])
#' object(s) (which should reference layout components), which become
#' argument values for R callback handlers defined in `func`. Here `func` may
#' either be an anonymous R function, or a call to `clientsideFunction()`, which
#' describes a locally served JavaScript function instead. The latter defines a
#' "clientside callback", which updates components without passing data to and
#' from the Dash backend. The latter may offer improved performance relative
#' to callbacks written in R.
#' }
#' \item{`title("dash")`}{
#' The title of the app. If no title is supplied, Dash for R will use 'dash'.
#' }
#' \item{`callback_context()`}{
#' The `callback_context` method permits retrieving the inputs which triggered
#' the firing of a given callback, and allows introspection of the input/state
#' values given their names. It is only available from within a callback;
#' attempting to use this method outside of a callback will result in a warning.
#' }
#' \item{`get_asset_url(asset_path, prefix)`}{
#' The `get_asset_url` method permits retrieval of an asset's URL given its filename.
#' For example, `app$get_asset_url('style.css')` should return `/assets/style.css` when
#' `assets_folder = 'assets'`. By default, the prefix is the value of `requests_pathname_prefix`,
#' but this is configurable via the `prefix` parameter. Note: this method will
#' present a warning and return `NULL` if the Dash app was not loaded via `source()`
#' if the `DASH_APP_PATH` environment variable is undefined.
#' }
#' \item{`index_string(string)`}{
#' The `index_string` method allows the specification of a custom index by changing
#' the default `HTML` template that is generated by the Dash UI. Meta tags, CSS, Javascript,
#' are some examples of features that can be modified.
#' This method will present a warning if your HTML template is missing any necessary elements
#' and return an error if a valid index is not defined. The following interpolation keys are
#' currently supported:
#' \describe{
#' \item{`{%metas%}`}{Optional - The registered meta tags.}
#' \item{`{%favicon%}`}{Optional - A favicon link tag if found in assets.}
#' \item{`{%css%}`}{Optional - Link tags to css resources.}
#' \item{`{%config%}`}{Required - Config generated by dash for the renderer.}
#' \item{`{%app_entry%}`}{Required - The container where dash react components are rendered.}
#' \item{`{%scripts%}`}{Required - Collected dependencies scripts tags.}
#' }
#' \describe{
#' \item{Example of a basic HTML index string:}{
#' \preformatted{
#' "<!DOCTYPE html>
#' <html>
#' <head>
#' \{\%meta_tags\%\}
#' <title>\{\{%css\%\}\}</title>
#' \{\%favicon\%\}
#' \{\%css_tags\%\}
#' </head>
#' <body>
#' \{\%app_entry\%\}
#' <footer>
#' \{\%config\%\}
#' \{\%scripts\%\}
#' </footer>
#' </body>
#' </html>"
#' }
#' }
#' }
#' }
#' \item{`interpolate_index(template_index, ...)`}{
#' With the `interpolate_index` method, we can pass a custom index with template string
#' variables that are already evaluated. We can directly pass arguments to the `template_index`
#' by assigning them to variables present in the template. This is similar to the `index_string` method
#' but offers the ability to change the default components of the Dash index as seen in the example below:
#' \preformatted{
#' app$interpolate_index(
#' template_index,
#' metas = "<meta_charset='UTF-8'/>",
#' renderer = renderer,
#' config = config)
#' }
#' \describe{
#' \item{template_index}{Character. A formatted string with the HTML index string. Defaults to the initial template}
#' \item{...}{Named List. The unnamed arguments can be passed as individual named lists corresponding to the components
#' of the Dash html index. These include the same arguments as those found in the `index_string()` template.}
#' }
#' }
#' \item{`run_server(host = Sys.getenv('HOST', "127.0.0.1"),
#' port = Sys.getenv('PORT', 8050), block = TRUE, showcase = FALSE, ...)`}{
#' The `run_server` method has 13 formal arguments, several of which are optional:
#' \describe{
#' \item{host}{Character. A string specifying a valid IPv4 address for the Fiery server, or `0.0.0.0` to listen on all addresses. Default is `127.0.0.1` Environment variable: `HOST`.}
#' \item{port}{Integer. Specifies the port number on which the server should listen (default is `8050`). Environment variable: `PORT`.}
#' \item{block}{Logical. Start the server while blocking console input? Default is `TRUE`.}
#' \item{showcase}{Logical. Load the Dash application into the default web browser when server starts? Default is `FALSE`.}
#' \item{use_viewer}{Logical. Load the Dash application into RStudio's viewer pane? Requires that `host` is either `127.0.0.1` or `localhost`, and that Dash application is started within RStudio; if `use_viewer = TRUE` and these conditions are not satsified, the user is warned and the app opens in the default browser instead. Default is `FALSE`.}
#' \item{debug}{Logical. Enable/disable all the dev tools unless overridden by the arguments or environment variables. Default is `FALSE` when called via `run_server`. Environment variable: `DASH_DEBUG`.}
#' \item{dev_tools_ui}{Logical. Show Dash's dev tools UI? Default is `TRUE` if `debug == TRUE`, `FALSE` otherwise. Environment variable: `DASH_UI`.}
#' \item{dev_tools_hot_reload}{Logical. Activate hot reloading when app, assets, and component files change? Default is `TRUE` if `debug == TRUE`, `FALSE` otherwise. Requires that the Dash application is loaded using `source()`, so that `srcref` attributes are available for executed code. Environment variable: `DASH_HOT_RELOAD`.}
#' \item{dev_tools_hot_reload_interval}{Numeric. Interval in seconds for the client to request the reload hash. Default is `3`. Environment variable: `DASH_HOT_RELOAD_INTERVAL`.}
#' \item{dev_tools_hot_reload_watch_interval}{Numeric. Interval in seconds for the server to check asset and component folders for changes. Default `0.5`. Environment variable: `DASH_HOT_RELOAD_WATCH_INTERVAL`.}
#' \item{dev_tools_hot_reload_max_retry}{Integer. Maximum number of failed reload hash requests before failing and displaying a pop up. Default `0.5`. Environment variable: `DASH_HOT_RELOAD_MAX_RETRY`.}
#' \item{dev_tools_props_check}{Logical. Validate the types and values of Dash component properties? Default is `TRUE` if `debug == TRUE`, `FALSE` otherwise. Environment variable: `DASH_PROPS_CHECK`.}
#' \item{dev_tools_prune_errors}{Logical. Reduce tracebacks to just user code, stripping out Fiery and Dash pieces? Only available with debugging. `TRUE` by default, set to `FALSE` to see the complete traceback. Environment variable: `DASH_PRUNE_ERRORS`.}
#' \item{dev_tools_silence_routes_logging}{Logical. Replace Fiery's default logger with `dashLogger` instead (will remove all routes logging)? Enabled with debugging by default because hot reload hash checks generate a lot of requests.}
#' }
#' Starts the Fiery server in local mode. If a parameter can be set by an environment variable, that is listed too. Values provided here take precedence over environment variables.
#' Launch the application. If provided, `host`/`port` set the `host`/`port` fields of the underlying [fiery::Fire] web server. The `block`/`showcase`/`...` arguments are passed along
#' to the `ignite()` method of the [fiery::Fire] server.
#' }
#' }
#'
#' @examples
#' \dontrun{
#' library(dashCoreComponents)
#' library(dashHtmlComponents)
#' library(dash)
#' app <- Dash$new()
#' app$layout(
#' dccInput(id = "inputID", value = "initial value", type = "text"),
#' htmlDiv(id = "outputID")
#' )
#'
#' app$callback(output = list(id="outputID", property="children"),
#' params = list(input(id="inputID", property="value"),
#' state(id="inputID", property="type")),
#' function(x, y)
#' sprintf("You've entered: '%s' into a '%s' input control", x, y)
#' )
#'
#' app$run_server(showcase = TRUE)
#' }
#'
#' @export
#' @docType class
#' @format An [R6::R6Class] generator object
#'
Dash <- R6::R6Class(
'Dash',
public = list(
# user-facing fields
server = NULL,
config = list(),
# i.e., the Dash$new() method
initialize = function(name = NULL,
server = fiery::Fire$new(),
assets_folder = 'assets',
assets_url_path = '/assets',
eager_loading = FALSE,
assets_ignore = '',
serve_locally = TRUE,
meta_tags = NULL,
url_base_pathname = "/",
routes_pathname_prefix = NULL,
requests_pathname_prefix = NULL,
external_scripts = NULL,
external_stylesheets = NULL,
compress = TRUE,
suppress_callback_exceptions = FALSE) {
# argument type checking
assertthat::assert_that(inherits(server, "Fire"))
assertthat::assert_that(is.logical(serve_locally))
assertthat::assert_that(is.logical(suppress_callback_exceptions))
# save relevant args as private fields
if (!is.null(name)) {
warning(sprintf(
"The supplied application title, '%s', should be set using the title() method, or passed via index_string() or interpolate_index(); it has been ignored, and 'dash' will be used instead.",
name),
call. = FALSE
)
}
private$serve_locally <- serve_locally
private$eager_loading <- eager_loading
# remove leading and trailing slash(es) if present
private$assets_folder <- gsub("^/+|/+$", "", assets_folder)
# remove trailing slash in assets_url_path, if present
private$assets_url_path <- sub("/$", "", assets_url_path)
private$assets_ignore <- assets_ignore
private$suppress_callback_exceptions <- suppress_callback_exceptions
private$compress <- compress
private$app_root_path <- getAppPath()
private$app_launchtime <- as.integer(Sys.time())
private$meta_tags <- meta_tags
private$in_viewer <- FALSE
# config options
self$config$routes_pathname_prefix <- resolvePrefix(routes_pathname_prefix, "DASH_ROUTES_PATHNAME_PREFIX", url_base_pathname)
self$config$requests_pathname_prefix <- resolvePrefix(requests_pathname_prefix, "DASH_REQUESTS_PATHNAME_PREFIX", url_base_pathname)
self$config$external_scripts <- external_scripts
self$config$external_stylesheets <- external_stylesheets
# ------------------------------------------------------------
# Initialize a route stack and register a static resource route
# ------------------------------------------------------------
router <- routr::RouteStack$new()
# ensure that assets_folder is neither NULL nor character(0)
if (!(is.null(private$assets_folder)) & length(private$assets_folder) != 0) {
if (!(dir.exists(private$assets_folder)) && gsub("/+", "", assets_folder) != "assets") {
warning(sprintf(
"The supplied assets folder, '%s', could not be found in the project directory.",
private$assets_folder),
call. = FALSE
)
} else if (dir.exists(private$assets_folder)) {
if (length(countEnclosingFrames("dash_nested_fiery_server")) == 0) {
private$refreshAssetMap()
private$last_refresh <- as.integer(Sys.time())
}
# fiery is attempting to launch a server within a server, do not refresh assets
}
}
# ------------------------------------------------------------------------
# Set a sensible default logger
# ------------------------------------------------------------------------
server$set_logger(dashLogger)
server$access_log_format <- fiery::combined_log_format
# ------------------------------------------------------------------------
# define & register routes on the server
# https://github.com/plotly/dash/blob/d2ebc837/dash/dash.py#L88-L124
# http://www.data-imaginist.com/2017/Introducing-routr/
# ------------------------------------------------------------------------
route <- routr::Route$new()
dash_layout <- paste0(self$config$routes_pathname_prefix, "_dash-layout")
route$add_handler("get", dash_layout, function(request, response, keys, ...) {
rendered_layout <- private$layout_render()
# pass the layout on to encode_plotly in case there are dccGraph
# components which include Plotly.js figures for which we'll need to
# run plotly_build from the plotly package
lay <- encode_plotly(rendered_layout)
response$body <- to_JSON(lay, pretty = TRUE)
response$status <- 200L
response$type <- 'json'
TRUE
})
dash_deps <- paste0(self$config$routes_pathname_prefix, "_dash-dependencies")
route$add_handler("get", dash_deps, function(request, response, keys, ...) {
# dash-renderer wants an empty array when no dependencies exist (see python/01.py)
if (!length(private$callback_map)) {
response$body <- to_JSON(list())
response$status <- 200L
response$type <- 'json'
return(FALSE)
}
payload <- Map(function(callback_signature) {
list(
inputs=callback_signature$inputs,
output=createCallbackId(callback_signature$output),
state=callback_signature$state,
clientside_function=callback_signature$clientside_function
)
}, private$callback_map)
response$body <- to_JSON(setNames(payload, NULL))
response$status <- 200L
response$type <- 'json'
if (private$compress)
response <- tryCompress(request, response)
TRUE
})
dash_update <- paste0(self$config$routes_pathname_prefix, "_dash-update-component")
route$add_handler("post", dash_update, function(request, response, keys, ...) {
request <- request_parse_json(request)
if (!"output" %in% names(request$body)) {
response$body <- "Couldn't find output component in request body"
response$status <- 500L
response$type <- 'json'
return(FALSE)
}
# get the callback associated with this particular output
callback <- private$callback_map[[request$body$output]][['func']]
if (!length(callback)) stop_report("Couldn't find output component.")
if (!is.function(callback)) {
stop(sprintf("Couldn't find a callback function associated with '%s'", thisOutput))
}
# the following callback_args code handles inputs which may contain
# NULL values; we wish to retain the NULL elements, since these can
# be passed into the callback handler, rather than dropping the list
# elements when they are encountered (which also compromises the
# sequencing of passed arguments). the R FAQ notes that list(NULL)
# can be used to append NULL elements into a constructed list, but
# that assigning NULL into list elements omits them from the object.
#
# we want the NULL elements to be wrapped in a list when they're
# passed, so they're nested in the code below.
#
# https://cran.r-project.org/doc/FAQ/R-FAQ.html#Others:
callback_args <- list()
for (input_element in request$body$inputs) {
if(is.null(input_element$value))
callback_args <- c(callback_args, list(list(NULL)))
else
callback_args <- c(callback_args, list(input_element$value))
}
if (length(request$body$state)) {
for (state_element in request$body$state) {
if(is.null(state_element$value))
callback_args <- c(callback_args, list(list(NULL)))
else
callback_args <- c(callback_args, list(state_element$value))
}
}
# set the callback context associated with this invocation of the callback
private$callback_context_ <- setCallbackContext(request$body)
output_value <- getStackTrace(do.call(callback, callback_args),
debug = private$debug,
prune_errors = private$prune_errors)
# reset callback context
private$callback_context_ <- NULL
# inspect the output_value to determine whether any outputs have no_update
# objects within them; these should not be updated
if (length(output_value) == 1 && class(output_value) == "no_update") {
response$body <- character(1) # return empty string
response$status <- 204L
}
else if (is.null(private$stack_message)) {
# pass on output_value to encode_plotly in case there are dccGraph
# components which include Plotly.js figures for which we'll need to
# run plotly_build from the plotly package
output_value <- encode_plotly(output_value)
# for multiple outputs, have to format the response body like this, including 'multi' key:
# https://github.com/plotly/dash/blob/d9ddc877d6b15d9354bcef4141acca5d5fe6c07b/dash/dash.py#L1174-L1209
# for single outputs, the response body is formatted slightly differently:
# https://github.com/plotly/dash/blob/d9ddc877d6b15d9354bcef4141acca5d5fe6c07b/dash/dash.py#L1210-L1220
if (substr(request$body$output, 1, 2) == '..') {
# omit return objects of class "no_update" from output_value
updatable_outputs <- "no_update" != vapply(output_value, class, character(1))
output_value <- output_value[updatable_outputs]
# if multi-output callback, isolate the output IDs and properties
ids <- getIdProps(request$body$output)$ids[updatable_outputs]
props <- getIdProps(request$body$output)$props[updatable_outputs]
# prepare a response object which has list elements corresponding to ids
# which themselves contain named list elements corresponding to props
# then fill in nested list elements based on output_value
allprops <- setNames(vector("list", length(unique(ids))), unique(ids))
idmap <- setNames(ids, props)
for (id in unique(ids)) {
allprops[[id]] <- output_value[grep(id, ids)]
names(allprops[[id]]) <- names(idmap[which(idmap==id)])
}
resp <- list(
response = allprops,
multi = TRUE
)
} else {
resp <- list(
response = list(
props = setNames(list(output_value), gsub( "(^.+)(\\.)", "", request$body$output))
)
)
}
response$body <- to_JSON(resp)
response$status <- 200L
response$type <- 'json'
} else if (private$debug==TRUE) {
# if there is an error, send it back to dash-renderer
response$body <- private$stack_message
response$status <- 500L
response$type <- 'html'
private$stack_message <- NULL
} else {
# if not in debug mode, do not return stack
response$body <- NULL
response$status <- 500L
private$stack_message <- NULL
}
if (private$compress)
response <- tryCompress(request, response)
TRUE
})
# This endpoint supports dynamic dependency loading
# during `_dash-update-component` -- for reference:
# https://docs.python.org/3/library/pkgutil.html#pkgutil.get_data
#
# analogous to
# https://github.com/plotly/dash/blob/2d735aa250fc67b14dc8f6a337d15a16b7cbd6f8/dash/dash.py#L543-L551
dash_suite <- paste0(self$config$routes_pathname_prefix, "_dash-component-suites/:package_name/:filename")
route$add_handler("get", dash_suite, function(request, response, keys, ...) {
filename <- basename(file.path(keys$filename))
# checkFingerprint returns a list of length 2, the first element is
# the un-fingerprinted path, if a fingerprint is present (otherwise
# the original path is returned), while the second element indicates
# whether the original filename included a valid fingerprint (by
# Dash convention)
fingerprinting_metadata <- checkFingerprint(filename)
filename <- fingerprinting_metadata[[1]]
has_fingerprint <- fingerprinting_metadata[[2]] == TRUE
dep_list <- c(private$dependencies_internal,
private$dependencies,
private$dependencies_user)
dep_pkg <- get_package_mapping(filename,
keys$package_name,
clean_dependencies(dep_list)
)
# return warning if a dependency goes unmatched, since the page
# will probably fail to render properly anyway without it
if (length(dep_pkg$rpkg_path) == 0) {
warning(sprintf("The dependency '%s' could not be loaded; the file was not found.",
filename),
call. = FALSE)
response$body <- NULL
response$status <- 404L
} else {
# need to check for debug mode, don't cache, don't etag
# if debug mode is not active
dep_path <- system.file(dep_pkg$rpkg_path,
package = dep_pkg$rpkg_name)
response$body <- readLines(dep_path,
warn = FALSE,
encoding = "UTF-8")
if (!private$debug && has_fingerprint) {
response$status <- 200L
response$set_header('Cache-Control',
sprintf('public, max-age=%s',
31536000) # 1 year
)
} else if (!private$debug && !has_fingerprint) {
modified <- as.character(as.integer(file.mtime(dep_path)))
response$set_header('ETag', modified)
request_etag <- request$get_header('If-None-Match')
if (!is.null(request_etag) && modified == request_etag) {
response$body <- NULL
response$status <- 304L
} else {
response$status <- 200L
}
} else {
response$status <- 200L
}
response$type <- get_mimetype(filename)
}
if (private$compress && length(response$body) > 0)
response <- tryCompress(request, response)
TRUE
})
dash_assets <- paste0(self$config$routes_pathname_prefix, private$assets_url_path, "/*")
# ensure slashes are not doubled
dash_assets <- sub("//", "/", dash_assets)
route$add_handler("get", dash_assets, function(request, response, keys, ...) {
# unfortunately, keys do not exist for wildcard headers in routr -- URL must be parsed
# e.g. for "http://127.0.0.1:8050/assets/stylesheet.css?m=1552591104"
#
# the following regex pattern will return "/stylesheet.css":
assets_pattern <- paste0("(?<=",
gsub("/",
"\\\\/",
private$assets_url_path),
")([^?])+"
)
# now, identify vector positions for asset string matching pattern above
asset_match <- gregexpr(pattern = assets_pattern, request$url, perl=TRUE)
# use regmatches to retrieve only the substring following assets_url_path
asset_to_match <- unlist(regmatches(request$url, asset_match))
# now that we've parsed the URL, attempt to match the subpath in the map,
# then return the local absolute path to the asset
asset_path <- get_asset_path(private$asset_map,
asset_to_match)
# the following codeblock attempts to determine whether the requested
# content exists, if the data should be encoded as plain text or binary,
# and opens/closes a file handle if the type is assumed to be binary
if (!(is.null(asset_path)) && file.exists(asset_path)) {
response$type <- request$headers[["Content-Type"]] %||%
mime::guess_type(asset_to_match,
empty = "application/octet-stream")
if (grepl("text|javascript", response$type)) {
response$body <- readLines(asset_path,
warn = FALSE,
encoding = "UTF-8")
if (private$compress && length(response$body) > 0) {
response <- tryCompress(request, response)
}
} else {
file_handle <- file(asset_path, "rb")
file_size <- file.size(asset_path)
response$body <- readBin(file_handle,
raw(),
file_size)
close(file_handle)
}
response$status <- 200L
}
TRUE
})
dash_favicon <- paste0(self$config$routes_pathname_prefix, "_favicon.ico")
route$add_handler("get", dash_favicon, function(request, response, keys, ...) {
asset_path <- get_asset_path(private$asset_map,
"/favicon.ico")
file_handle <- file(asset_path, "rb")
response$body <- readBin(file_handle,
raw(),
file.size(asset_path))
close(file_handle)
response$set_header('Cache-Control',
sprintf('public, max-age=%s',
'31536000')
)
response$type <- 'image/x-icon'
response$status <- 200L
TRUE
})
# Add a 'catchall' handler to redirect other requests to the index
dash_catchall <- paste0(self$config$routes_pathname_prefix, "*")
route$add_handler('get', dash_catchall, function(request, response, keys, ...) {
response$body <- private$.index
response$status <- 200L
response$type <- 'html'
if (private$compress)
response <- tryCompress(request, response)
TRUE
})
dash_reload_hash <- paste0(self$config$routes_pathname_prefix, "_reload-hash")
route$add_handler("get", dash_reload_hash, function(request, response, keys, ...) {
modified_files <- private$modified_since_reload
hard <- TRUE
if (is.null(modified_files)) {
# dash-renderer requires that this element not be NULL
modified_files <- list()
}
resp <- list(files = modified_files,
hard = hard,
packages = c("dash_renderer",
unique(
vapply(
private$dependencies,
function(x) x[["name"]],
FUN.VALUE=character(1),
USE.NAMES = FALSE)
)
),
reloadHash = self$config$reload_hash)
response$body <- to_JSON(resp)
response$status <- 200L
response$type <- 'json'
# reset the field for the next reloading operation
private$modified_since_reload <- list()
TRUE
})
router$add_route(route, "dashR-endpoints")
server$attach(router)
server$on("start", function(server, ...) {
private$generateReloadHash()
private$index()
viewer <- !(is.null(getOption("viewer"))) && (dynGet("use_viewer") == TRUE)
app_url <- paste0("http://", self$server$host, ":", self$server$port)
if (viewer && self$server$host %in% c("localhost", "127.0.0.1")) {
rstudioapi::viewer(app_url)
private$in_viewer <- TRUE
}
else if (viewer) {
warning("\U{26A0} RStudio viewer not supported; ensure that host is 'localhost' or '127.0.0.1' and that you are using RStudio to run your app. Opening default browser...")
utils::browseURL(app_url)
}
})
# user-facing fields
self$server <- server
},
# ------------------------------------------------------------------------
# dash layout methods
# ------------------------------------------------------------------------
layout_get = function(render = TRUE) {
if (render) private$layout_render() else private$layout_
},
layout = function(...) {
private$layout_ <- if (is.function(..1)) ..1 else list(...)
# render the layout, and then return the rendered layout without printing
invisible(private$layout_render())
},
react_version_set = function(version) {
versions <- private$react_versions()
idx <- versions %in% version
# needs to match one react & one react-dom version
if (sum(idx) != 2) {
stop(sprintf(
"React version '%s' is not supported. Supported versions include: '%s'",
version, paste(unique(versions), collapse = "', '")
), call. = FALSE)
}
private$react_version_enabled <- version
},
# ------------------------------------------------------------------------
# callback registration
# ------------------------------------------------------------------------
callback = function(output, params, func) {
assert_valid_callbacks(output, params, func)
inputs <- params[vapply(params, function(x) 'input' %in% attr(x, "class"), FUN.VALUE=logical(1))]
state <- params[vapply(params, function(x) 'state' %in% attr(x, "class"), FUN.VALUE=logical(1))]
if (is.function(func)) {
clientside_function <- NULL
} else {
clientside_function <- func
func <- NULL
}
# register the callback_map
private$callback_map <- insertIntoCallbackMap(private$callback_map,
inputs,
output,
state,
func,
clientside_function)
},
# ------------------------------------------------------------------------
# request and return callback context
# ------------------------------------------------------------------------
callback_context = function() {
if (is.null(private$callback_context_)) {
warning("callback_context is undefined; callback_context may only be accessed within a callback.")
}
private$callback_context_
},
# ------------------------------------------------------------------------
# return asset URLs
# ------------------------------------------------------------------------
get_asset_url = function(asset_path, prefix = self$config$requests_pathname_prefix) {
app_root_path <- Sys.getenv("DASH_APP_PATH")
if (app_root_path == "" && getAppPath() != FALSE) {
# app loaded via source(), root path is known
app_root_path <- dirname(private$app_root_path)
} else if (getAppPath() == FALSE) {
# app not loaded via source(), env var not set, no reliable way to ascertain root path
warning("application not started via source(), and DASH_APP_PATH environment variable is undefined. get_asset_url returns NULL since root path cannot be reliably identified.")
return(NULL)
}
asset <- lapply(private$asset_map,
function(x) {
# asset_path should be prepended with the full app root & assets path
# if leading slash(es) present in asset_path, remove them before
# assembling full asset path
asset_path <- file.path(app_root_path,
private$assets_folder,
sub(pattern="^/+",
replacement="",
asset_path))
return(names(x[x == asset_path]))
}
)
asset <- unlist(asset, use.names = FALSE)
if (length(asset) == 0)
stop(sprintf("the asset path '%s' is not valid; please verify that this path exists within the '%s' directory.",
asset_path,
private$assets_folder))
# strip multiple slashes if present, since we'll
# introduce one when we concatenate the prefix and
# asset path & prepend the asset name with route prefix
return(gsub(pattern="/+",
replacement="/",
paste(prefix,
private$assets_url_path,
asset,
sep="/")))
},
# ------------------------------------------------------------------------
# specify a custom index string
# ------------------------------------------------------------------------
index_string = function(string) {
private$custom_index <- validate_keys(string)
},
# ------------------------------------------------------------------------
# modify the templated variables by using the `interpolate_index` method.
# ------------------------------------------------------------------------
interpolate_index = function(template_index = private$template_index[[1]], ...) {
template = template_index
kwargs <- list(...)
for (name in names(kwargs)) {
key = paste0('\\{\\%', name, '\\%\\}')
template = sub(key, kwargs[[name]], template)
}
invisible(validate_keys(names(kwargs)))
private$template_index <- template
},
# ------------------------------------------------------------------------
# specify a custom title
# ------------------------------------------------------------------------
title = function(string = "dash") {
assertthat::assert_that(is.character(string))
private$name <- string
},
# ------------------------------------------------------------------------
# convenient fiery wrappers
# ------------------------------------------------------------------------
run_server = function(host = Sys.getenv('HOST', "127.0.0.1"),
port = Sys.getenv('PORT', 8050),
block = TRUE,
showcase = FALSE,
use_viewer = FALSE,
dev_tools_prune_errors = TRUE,
debug = Sys.getenv('DASH_DEBUG'),
dev_tools_ui = Sys.getenv('DASH_UI'),
dev_tools_props_check = Sys.getenv('DASH_PROPS_CHECK'),
dev_tools_hot_reload = Sys.getenv('DASH_HOT_RELOAD'),
dev_tools_hot_reload_interval = Sys.getenv('DASH_HOT_RELOAD_INTERVAL'),
dev_tools_hot_reload_watch_interval = Sys.getenv('DASH_HOT_RELOAD_WATCH_INTERVAL)'),
dev_tools_hot_reload_max_retry = Sys.getenv('DASH_HOT_RELOAD_MAX_RETRY'),
dev_tools_silence_routes_logging = NULL,
...) {
if (exists("dash_nested_fiery_server", env=parent.frame(1))) {
# fiery is attempting to launch a server within a server, abort gracefully
return(NULL)
}
getServerParam <- function(value, type, default) {
if (length(value) == 0 || is.na(value))
return(default)
if (type %in% c("double", "integer") && value < 0)
return(default)
if (toupper(value) %in% c("TRUE", "FALSE") && type == "logical")
value <- as.logical(toupper(value))
if (type == "integer")
value <- as.integer(value)
if (type == "double")
value <- as.double(value)
if (value != "" && typeof(value) == type) {
return(value)
} else {
return(default)
}
}
debug <- getServerParam(debug, "logical", FALSE)
private$debug <- debug
self$server$host <- getServerParam(host, "character", "127.0.0.1")
self$server$port <- getServerParam(as.integer(port), "integer", 8050)
dev_tools_ui <- getServerParam(dev_tools_ui, "logical", debug)
dev_tools_props_check <- getServerParam(dev_tools_props_check, "logical", debug)
dev_tools_silence_routes_logging <- getServerParam(dev_tools_silence_routes_logging, "logical", debug)
dev_tools_hot_reload <- getServerParam(dev_tools_hot_reload, "logical", debug)
private$prune_errors <- getServerParam(dev_tools_prune_errors, "logical", TRUE)
if(getAppPath() != FALSE) {
source_dir <- dirname(getAppPath())
private$app_root_modtime <- modtimeFromPath(source_dir, recursive = TRUE, asset_path = private$assets_folder)
} else {
source_dir <- NULL
}
# set the modtime to track state of the Dash app directory
# this calls getAppPath, which will try three approaches to
# identifying the local app path (depending on whether the app
# is invoked via script, source(), or executed dire ctly from console)
self$config$ui <- dev_tools_ui
if (dev_tools_hot_reload) {
hot_reload <- TRUE
hot_reload_interval <- getServerParam(dev_tools_hot_reload_interval, "double", 3)
hot_reload_watch_interval <- getServerParam(dev_tools_hot_reload_watch_interval, "double", 0.5)
hot_reload_max_retry <- getServerParam(as.integer(dev_tools_hot_reload_max_retry), "integer", 8)
# convert from seconds to msec as used by js `setInterval`
self$config$hot_reload <- list(interval = hot_reload_interval * 1000, max_retry = hot_reload_max_retry)
} else {
hot_reload <- FALSE
}
self$config$silence_routes_logging <- dev_tools_silence_routes_logging
self$config$props_check <- dev_tools_props_check
if (hot_reload == TRUE & !(is.null(source_dir))) {
self$server$on('cycle-end', function(server, ...) {
# handle case where assets are not present, since we can still hot reload the app itself
#
# private$last_refresh is set after the asset_map is refreshed
# private$last_reload stores the time of the last hard or soft reload event
# private$last_cycle will be set when the cycle-end handler terminates
#
if (!is.null(private$last_cycle) & !is.null(hot_reload_watch_interval)) {
permit_reload <- (Sys.time() - private$last_reload) >= hot_reload_watch_interval
} else {
permit_reload <- FALSE
}
if (permit_reload) {
if (dir.exists(private$assets_folder)) {
# by specifying asset_path, we can exclude assets from the root_modtime when recursive=TRUE
# otherwise modifying CSS assets will always trigger a hard reload
current_asset_modtime <- modtimeFromPath(private$assets_folder, recursive = TRUE)
current_root_modtime <- modtimeFromPath(source_dir, recursive = TRUE, asset_path = private$assets_folder)
updated_assets <- isTRUE(current_asset_modtime > private$asset_modtime)
updated_root <- isTRUE(current_root_modtime > private$app_root_modtime)
private$app_root_modtime <- current_root_modtime
} else {
# there is no assets folder, update the root modtime only
current_asset_modtime <- NULL
current_root_modtime <- modtimeFromPath(source_dir, recursive = TRUE)
updated_root <- isTRUE(current_root_modtime > private$app_root_modtime)
updated_assets <- FALSE
private$app_root_modtime <- current_root_modtime
}
if (!is.null(current_asset_modtime) && updated_assets) {
# refreshAssetMap silently returns a list of updated objects in the map
# we can use this to retrieve the modified files, and also determine if
# any are scripts or other non-CSS data
has_assets <- file.exists(file.path(source_dir, private$assets_folder))
if (length(has_assets) != 0 && has_assets) {
updated_files <- private$refreshAssetMap()
file_extensions <- tools::file_ext(updated_files$modified)
# if the vector of file_extensions is logical(0), this ensures
# we return FALSE instead of logical(0)
checkIfCSS <- function(extension) {
if (length(extension) == 0)
return(FALSE)
else
return(extension == "css")
}
all_updated <- c(updated_files$added, updated_files$modified)
private$modified_since_reload <- lapply(setNames(all_updated, NULL),
function(current_file) {
list(is_css = checkIfCSS(tools::file_ext(current_file)),
modified = modtimeFromPath(current_file),
url = paste(private$assets_url_path, basename(current_file), sep="/"))