-
Notifications
You must be signed in to change notification settings - Fork 0
/
plots.R
1879 lines (1773 loc) · 71.3 KB
/
plots.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
#' @importFrom dplyr case_when
#' @importFrom stringr str_length
#' @importFrom plotly plot_ly
#' @importFrom purrr imap
#' @importFrom lubridate as_date today
roboplotr_config <- function(p,
title,
subtitle = "",
caption,
legend_position,
legend_orientation,
legend_order,
height,
width,
margin = NA,
zeroline = F,
shadearea = NULL,
enable_rangeslider = list(rangeslider = F, max = as_date(today())),
ticktypes,
container,
hovermode,
info_text,
legend_title,
tidy_legend,
modebar
) {
if (!is.list(margin)) {
if (is.na(margin)) {
margin <- list(t = 0,
r = 5,
b = 0,
l = 5)
}
}
p |>
roboplotr_dependencies(title, subtitle, container, ticktypes, tidy_legend) |>
roboplotr_grid() |>
roboplotr_set_background() |>
roboplotr_modebar(title, subtitle, caption, height, width, ticktypes$dateformat, info_text, modebar) |>
roboplotr_set_ticks(ticktypes) |>
roboplotr_set_margin(margin) |>
roboplotr_logo() |>
roboplotr_legend(legend_position, legend_orientation, legend_order, legend_title) |>
roboplotr_title(title, subtitle) |>
roboplotr_caption(caption) |>
roboplotr_add_shapes(zeroline, shadearea) |>
roboplotr_rangeslider(enable_rangeslider) |>
roboplotr_set_axis_ranges(ticktypes[c("xlim", "ylim")], enable_rangeslider$rangeslider, hovermode) |>
roboplotr_hoverlabel()
}
#' @importFrom dplyr add_row
#' @importFrom htmltools tagList tags
#' @importFrom htmlwidgets appendContent onRender
#' @importFrom R.utils setOption
#' @importFrom RCurl base64Encode
#' @importFrom shiny isRunning
#' @importFrom stringr str_c str_extract_all str_replace_all str_squish str_pad str_wrap
roboplotr_dependencies <- function(p, title, subtitle, container, ticktypes, tidy_legend = T) {
if(title$include == T) {
plot_title <-
list(title$title, subtitle, getOption("roboplot.font.title")$bold)
} else {
plot_title <-
list("", subtitle, getOption("roboplot.font.title")$bold)
}
if (!isRunning()) {
if (is.null(getOption("roboplot.widget.deps.session"))) {
deps <- roboplotr_widget_deps()
setOption("roboplot.widget.deps.session", deps)
} else {
deps <- getOption("roboplot.widget.deps.session")
}
p <- appendContent(p,
tagList(
tags$script(src = deps$js),
tags$link(
rel = "stylesheet",
type = "text/css",
href = deps$css
)
))
}
rangeslider_sums <- F
if (any(str_detect(p$plot_mode, "stack")) &&
any(p$trace_types == "bar")) {
rangeslider_sums = T
}
pie_plot <- if (any(p$trace_types == "pie")) {
T
} else {
F
}
p |>
onRender(
jsCode = "function (gd, params, data){
let plot_title = data.plotTitle;
for (i = gd.layout.annotations.length - 1; i >= 0; i--) {
if(gd.layout.annotations[i].text == gd.layout.annotations[0].text && i > 0 ) {
Plotly.relayout(gd, 'annotations[' + i + ']', 'remove');
}
}
let roboplot_logo = new Image();
roboplot_logo.src = gd.layout.images[0].source;
roboplot_logo = roboplot_logo.width / roboplot_logo.height
setVerticalLayout({'width': true}, gd, data.fonts, plot_title, pie_plot = data.piePlot, logo = roboplot_logo, tidy_legend = data.tidyLegend);
setYPositions({'width': true}, gd, data.piePlot);
gd.on('plotly_relayout',function(eventdata) {
plotlyRelayoutEventFunction(eventdata, gd, data.fonts, plot_title, data.rangesliderSums, pie_plot = data.piePlot, logo = roboplot_logo, tidy_legend = data.tidyLegend);
})
let observer = new IntersectionObserver(function(entries) {
// Check if the element is intersecting (visible)
if(entries[0].isIntersecting) {
// Element is visible, handle the plot rendering or adjustment
console.log('relayout fired!');
plotlyRelayoutEventFunction({width: true}, gd, data.fonts, plot_title, data.rangesliderSums, pie_plot = data.piePlot, logo = roboplot_logo, tidy_legend = data.tidyLegend);
observer.disconnect();
}
}, { threshold: [0.1] }); // Adjust the threshold as needed
observer.observe(gd); // Start observing the container
gd.on('plotly_afterplot', function() {
let thisscrollbar = $(gd).find('.scrollbar')
thisscrollbar.length > 0 ? thisscrollbar[0].style.visibility = 'hidden' : () => {}
let thisclippath = $(gd).find('clipPath[id*=legend] > rect')
if(thisclippath.length > 0) {
thisclippath = thisclippath[0];
thiswidth = thisclippath.getAttribute('width');
thisheight = thisclippath.getAttribute('height');
// console.log('init width: ' + thiswidth)
thisclippath.setAttribute('width',Number(thiswidth)*1.05);
thisclippath.setAttribute('height',Number(thisheight)*1.1);
// thiswidth = thisclippath.getAttribute('width');
// console.log('recalc width: ' + thiswidth)
};
})
}",
data = list(
plotTitle = plot_title,
rangesliderSums = rangeslider_sums,
fonts = list(legend = getOption("roboplot.font.main")$size, x = ticktypes$xfont$size,y = ticktypes$yfont$size),
piePlot = pie_plot,
container = container,
tidyLegend = tidy_legend
# dataString = desc_string,
# titleString = ttl_string,
# ariaID = ariaid
)
)
}
#
# clippath for onRender.. to-do
# let thisclippath = $(gd).find('clipPath[id*=legend] > rect')[0]
# let thiswidth = thisclippath.getAttribute('width')
# thisclippath.setAttribute('width',Number(thiswidth)*1.05)
# gd.on('plotly_afterplot', function() {
# let thisclippath = $(gd).find('clipPath[id*=legend] > rect')[0]
# let thiswidth = thisclippath.getAttribute('width')
# thisclippath.setAttribute('width',Number(thiswidth)*1.05)
# })
#' Automated plotly plotting for properly scaling plots.
#'
#' Wrapper for [plotly::plot_ly] for shorthand declaration of many layout and trace arguments.
#' Ensures proper scaling or elements when used in shiny apps, iframes, static image downloads and so on.
#'
#' @param d Data frame. Data to be plotted with at least the columns "time"
#' (Date or POSIXt) and "value" (numeric). Other columns could be specified
#' instead with 'plot_axes', using [set_axes()].
#' @param color Symbol, string, or function resulting in symbol or string.
#' Column from param 'd' to use for trace color. If NULL, the argument 'subtitle'
#' will be used as a placeholder for determining color and hoverlabels.
#' @param pattern Symbol, string, or function resulting in symbol or string.
#' Optionally, use [set_pattern()] for more fine-tuned control. See documentation
#' of that function. Column from param 'd' to use for scatter plot linetype or
#' bar plot pattern. Not supported for pie charts.
#' @param title,subtitle Characters. Labels for plot elements. Optionally, use
#' [set_title()] for the title if you want to omit the title from the
#' displayed plot, but include it for any downloads through the modebar.
#' @param caption Function or character. Use [set_caption()].
#' @param legend_position,legend_orientation Characters. Currently only
#' legend_position is used, and takes only "bottom" or NA for no legend.
#' Legend is removed on default if the argument 'color' in argument 'd' has only
#' one observation.
#' @param legend_title Logical or character. Use TRUE if you want the parameter
#' 'color' to be the legend title. Use a character string if you want to
#' provide your own legend title.
#' @param zeroline Logical or numeric. Determines zeroline inclusion, TRUE for
#' zeroline, or numeric for exact placement.
#' @param rangeslider Logical or character in %Y-%m-%d format. Determines
#' rangeslider inclusion. TRUE includes the rangeslider, a character string
#' includes the rangeslider with the given date as a start date.
#' @param hovertext Function. Use [set_hovertext()].
#' @param highlight Numeric or list. Determines if a given trace is included in
#' legend and assigned a color. If numeric, traces with max(value) < highlight
#' will be give trace color matching the grid color, and removed from the
#' legend. If function, it must return a logical and include named items "value"
#' and ".fun", where .fun checks if given value will get a color or legend item.
#' Will not currently work with multiple patterns.
#' @param plot_type Character vector, named if length > 1. Determines the trace
#' type for either the whole plot, or for all variables defined by color as
#' name-value pairs.
#' @param plot_mode Character vector, named if length > 1. Controls plot specifics
#' along with the parameter 'plot_type'. When 'plot_type' is "scatter", the
#' available modes are "line" "scatter", "smooth", "step" and "scatter+line".
#' When 'plot_type' is "bar", the available modes are "dodge" "stack",
#' "horizontal", "horizontalfill" and "horizontalstack". Mode of "horizontalfill"
#' makes bars fill the space available is observations are missing. When
#' 'plot_type' is "pie", the available modes are "normal" and "rotated". You can
#' give a single unnamed 'plot_mode' which is used as applicable, or name-value
#' pairs, where names are items from parameter 'd' column described by parameter
#' 'color', and values applicable plot modes listed above.
#' @param plot_axes Function. Use [set_axes()].
#' @param trace_color Character vector, named if length > 1. Trace colors for all
#' traces. Determines the trace type for either the whole plot, or for all variables
#' defined by param 'color' as name-value pairs.
#' @param line_width Numeric vector, named if length > 1. Line width for all
#' line traces. Determines the line width for either the whole plot, or for all
#' variables contained in the column defined by param 'color' as name-value pairs.
#' @param height,width Numeric. Height and width of the plot. Default width is
#' NA for responsive plots, give a value for static plot width.
#' @param markers Function. Use [set_markers()]. Marker appearance for all markers.
#' @param facet_split Currently unused. Variable from argument 'd' to use for
#' facet splits.
#' @param shadearea Use if you want to have a highlighted area on the
#' [roboplot()]. Use [set_shadearea()] for fine-tuned control (see that function
#' for documentation), or provide a single value that corresponds with the x-axis
#' of the plot. Currently only useful when x-axis is numeric or date, and y-axis
#' is numeric.
#' @param error_bars Function. Use [set_errorbars()]. Specifications for any error bars.
#' @param legend_maxwidth Numeric. Legend items (and y-axis values for horizontal
#' barplots) longer than this will be collapsed with an ellipsis.
#' @param secondary_yaxis Character vector. Observations from param 'color' of [roboplot]
#' which will use a secondary y-axis. Parameter 'zeroline' will be ignored. Use
#' param 'plot_axes' with [set_axes()] for more control over secondary yaxis (see
#' documentation for several examples.)
#' @param xaxis_ceiling Character or date. One of "default", "days", "months",
#' "weeks", "quarters", "years", or "guess"). Set, or round, the upper bound of
#' plot x-axis for other than bar plots if no axis limits are given.
#' @param artefacts Logical or function. Use [set_artefacts()] for fine-tuned
#' control. Use TRUE instead for automated artefact creation or html and/or other
#' files from the plot based on settings globally set by [set_roboplot_options()].
#' @param tidy_legend Logical. Controls whether the legend items will have matching
#' widths, making for neater legends, or containing text widths, saving space. Default
#' is FALSE.
#' @param modebar Function. Use [set_modebar()].
#' @param container Character. Experimental, might not work as intended. Use only
#' with shiny apps. A css selector for the element in a shiny app where this
#' [roboplot()] will be contained in. Used for relayouts if the plot is rendered
#' while the container is not displayed.
#' @param info_text Character. If provided, an info button is appended to the modebar
#' of [roboplot()] which brings about a popup with this parameter as the text
#' content, along with plot title and caption elements.
#' @param ... Placeholder for other parameters.
#' @return A list of classes "plotly" and "html"
#' @examples
#' \dontrun{
#' # The default use for roboplotr::roboplot is for line charts. Providing
#' # a title is mandatory, subtitle and color is optional but very likely
#' # necessary.
#'
#' d <- roboplotr::energiantuonti |>
#' dplyr::filter(Alue %in% c("Kanada","Norja","Yhdistynyt kuningaskunta"))
#' d1 <- d |> dplyr::filter(Suunta == "Tuonti")
#' d1 |> roboplot(color = Alue,
#' title = "Energian tuonti",
#' subtitle = "Milj. \u20AC",
#' caption = "Lähde: Tilastokeskus.")
#'
#'
#' # Legend will automatically be omitted if only a single observation exists
#' # for 'color' is unless legend_position is given (currently only "bottom"
#' # works). Caption may be further specified with the helper function
#' # roboplotr::set_caption (see documentation for more control).
#' d1 |>
#' dplyr::filter(Alue == "Yhdistynyt kuningaskunta") |>
#' roboplot(Alue,"Energian tuonti Yhdistyneest\uE4 kuningaskunnasta","Milj. \u20AC",
#' caption = set_caption(text = "Tilastokeskus",
#' updated = TRUE,
#' .data = d1
#' )
#' )
#'
#'
#' # You can also use set_roboplot_options() to preconstruct some caption texts.
#'
#' set_roboplot_options(
#' caption_template = "{prepend}.<br>Source: {caption}.<br>{append}.")
#'
#' d |>
#' roboplot(Alue, "Energy import","Million euros",
#' caption = set_caption(
#' prepend ="Canada",
#' caption = "Statistics Finland",
#' append = paste0("(Customs Finland, International trade ",
#' "statistics;<br>Radiation and Nuclear Safety ",
#' "Authority; Gasum LLC)")))
#'
#' # Reset to defaults
#' set_roboplot_options(reset = TRUE)
#'
#' # Legend can also be omitted by giving a legend_position of NA. Height and
#' # width can also be specified, while for most uses width specification is
#' # unnecessary, as roboplotr is designed for plots with responsive widths.
#' d1 |> roboplot(Alue,"Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' legend_position = NA,
#' height = 600,
#' width = 400
#' )
#'
#' # If you have a lot of legend items, you might want to use param 'tidy_legend' for
#' # neater columns in the legend. This will cause problems for smaller plots, as
#' # roboplot() will have a hard time with fitting everything properly. This will be
#' # doubly so when using a rangeslider, and when resizing the roboplot.
#' energiantuonti |>
#' dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, tidy_legend = T, rangeslider = T, width = 400)
#'
#' # Avoid this by being reasonable with the number of legend items and plot dimensions.
#' energiantuonti |>
#' dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, tidy_legend = T, rangeslider = T, height = 700)
#'
#' # Pattern can be used in addition to color and you can control the ordering of
#' # the traces by transforming your variables to factors. You can also let
#' # roboplotr guess how much space is given to yaxis end in line plots, or give a
#' # string such as "weeks" or "days" to it. Message about missing frequency data
#' # can be silenced by setting the information as an attribute of the used data.
#' d2 <- d |> dplyr::mutate(Alue = forcats::fct_reorder(Alue, value))
#' attr(d2, "frequency") <- "Quarterly"
#' d2 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' pattern = Suunta,
#' xaxis_ceiling = "guess")
#'
#' # Bar plots use a pattern too.
#' d2 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' pattern = Suunta,
#' plot_type = "bar")
#' # Use set_pattern() if you want more options. See documentation for a more
#' # detailed explanation.
#' d2 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' pattern = set_pattern(pattern = Suunta, sep = " - "),
#' xaxis_ceiling = "guess")
#' # Scatter plots and bar plot may be combined, and colors determined by
#' # trace by giving named character vectors as the appropriate arguments.
#' # Barmode or scatter type is controlled by plot_mode.
#' d1 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' trace_color = c("Kanada" = "red","Norja" = "blue", .other = "black"),
#' plot_type = c("Norja" = "scatter","Kanada" = "bar",".other" = "scatter"),
#' plot_mode = c("Yhdistynyt kuningaskunta" = "scatter",
#' "Norja" = "scatter+line", ".bar" = "dodge",
#' ".scatter" = "line"
#' ))
#'
#' # If you omit ".other" from the trace colors, roboplot() will give the rest of
#' # of the traces colors from the default colors set in set_roboplot_options()
#' d1 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' trace_color = c("Kanada" = "pink"))
#'
#' # But if you need more control, you're better off just excplicity specifying
#' the colors.
#' d1 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' trace_color =
#' stats::setNames(c("#0052A5", "darkred", "#D52B1E"),
#' unique(d1$Alue))
#' )
#'
#' # With single 'time' observation x-axis tickmarks lose tick labels. There are
#' # several places where this information fits nicely.
#' d3 <- d2 |> dplyr::filter(time == max(time))
#' d3 |>
#' roboplot(Alue,
#' stringr::str_glue("Energian tuonti ja vienti vuonna {lubridate::year(max(d3$time))}"),
#' stringr::str_glue("Milj. \u20AC ({lubridate::year(max(d3$time))})"),
#' pattern = Suunta,
#' plot_type = "bar",
#' caption = set_caption(
#' template = "Tilastokeskus. Tieto vuodelta {lubridate::year(max(d3$time))}",
#' )
#' )
#'
#' # Plot axis can be controlled with roboplotr::set_axes (see
#' # documentation for more examples).
#' d2 |>
#' dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' plot_axes = set_axes(
#' ytitle = "Arvo",
#' xformat = "Vuonna %Y",
#' ylim = c(-100,100))
#' )
#'
#' # Bar plot can be horizontal with plot axis control and 'plot_mode' set to
#' # horizontal but then is better off with only a single 'time' observation. Long
#' # legend items and axis labels can be cut off with 'legend_maxwidth', while
#' # still showing the proper labels on hover. Control the order of the axes
#' # by explicitly setting them as factors.
#' d3 |>
#' dplyr::mutate(Suunta = paste0(Suunta, " m\uE4\uE4r\uE4maittain")) |>
#' dplyr::mutate(Alue = forcats::fct_reorder(Alue, value),
#' Suunta = forcats::fct_reorder(Suunta, value) |>
#' forcats::fct_rev()
#' ) |>
#' roboplot(Suunta,
#' stringr::str_glue("Energian tuonti {lubridate::year(max(d$time))}"),
#' "Milj. \u20AC","Tilastokeskus",
#' plot_type = "bar",
#' legend_maxwidth = 12,
#' plot_mode = "horizontal",
#' plot_axes = set_axes(
#' y = "Alue",
#' yticktype = "character",
#' x = "value",
#' xticktype = "numeric")
#' )
#'
#' # If you want the bars to fill the available space in a horizontal bar chart,
#' # use the plot_mode of "horizontalfill" instead of "horizontal".
#' d3 |>
#' roboplot(Suunta,
#' stringr::str_glue("Energian tuonti {lubridate::year(max(d$time))}"),
#' "Milj. \u20AC","Tilastokeskus",
#' plot_type = "bar",
#' plot_mode = "horizontalfill",
#' plot_axes = set_axes(
#' y = "Alue",
#' yticktype = "character",
#' x = "value",
#' xticktype = "numeric")
#' )
#'
#'
#' # Or stack the bars horizontally by using "horizontalstack"
#' d3 |>
#' roboplot(Suunta,
#' stringr::str_glue("Energian tuonti {lubridate::year(max(d$time))}"),
#' "Milj. \u20AC","Tilastokeskus",
#' plot_type = "bar",
#' plot_mode = "horizontalstack",
#' plot_axes = set_axes(
#' y = "Alue",
#' yticktype = "character",
#' x = "value",
#' xticktype = "numeric")
#' )
#'
#' # You can use 'secondary_yaxis' to define which observations from 'color' use
#' # go to a secondary yaxis on the right. Using a secondary yaxis disables any
#' # zeroline specifications.
#' d2 |>
#' dplyr::filter(Suunta == "Tuonti", Alue %in% c("Yhdistynyt kuningaskunta", "Kanada", "Norja")) |>
#' roboplot(Alue,
#' "Energian tuonti",
#' "Milj. \u20AC",
#' "Tilastokeskus",
#' secondary_yaxis = "Yhdistynyt kuningaskunta",
#' zeroline = 1000)
#'
#' # Furthermore, you can use set_axes() in 'plot_axes' for further control, like
#' # titles (defaults are added when using set_axes()). Documentation for
#' # set_axes() has more detailed examples.
#' d2 |>
#' dplyr::filter(Suunta == "Tuonti", Alue %in% c("Yhdistynyt kuningaskunta", "Kanada", "Norja")) |>
#' roboplot(Alue,
#' "Energian tuonti",
#' "Milj. \u20AC",
#' "Tilastokeskus",
#' plot_axes = set_axes(y2 = "Yhdistynyt kuningaskunta")
#'
#' # Pie plots are possible too, but pattern is currently ignored by plotly library.
#' d3 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC","Tilastokeskus",
#' pattern = Suunta,
#' plot_type = "pie")
#'
#' # Aside from patterns, you might want to change markers used on scatter plots
#' # by using set_pattern(). You can also include error bars on any numeric axis
#' # by specifying them with set_errorbars(). See both functions for more details.
#' d2 |>
#' dplyr::filter(Alue == "Venäjä") |>
#' dplyr::group_by(Alue) |>
#' dplyr::mutate(sd = sd(value)) |>
#' dplyr::ungroup() |>
#' roboplot(Alue,
#' plot_type = "scatter",
#' plot_mode = "scatter",
#' markers = set_markers("line", 12),
#' error_bars = set_errorbars(error_y = sd)
#' )
#' # Pie plot can be centered to the first factor level of argument 'color' with
#' # with plot_mode "rotated".
#' d3 |> roboplot(Alue,"Energian tuonti ja vienti","Milj. \u20AC",
#' "Tilastokeskus",
#' plot_type = "pie",
#' plot_mode = "rotated")
#'
#' # You can give a highlight value if you don't have a pattern. Any trace with a
#' # "value" equal or higher than the given value will get colors as normal. Others
#' # get assigned a bacground grid color and no legend entry. Useful mostly with
#' # very large amounts of traces.
#'
#' d2 |>
#' dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' plot_type = "scatter",
#' highlight = 160)
#'
#' # This works best with line plots, but can be included in other plots, too -
#' # with varying results, these are work in progress. Highlight can also be a list
#' # with "value" and ".fun" used to determine which traces are highlighted. The
#' # default usage is essentially list(value = highlight, .fun = sum).
#' d2 |> dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' plot_type = "bar",
#' highlight = list(value = 22, .fun = mean))
#'
#' # Rangeslider can be added as TRUE or FALSE, or as character in date format of
#' # %Y-%m-%d, in which case the given date will control where the rangeslider is
#' # initially set. Zeroline can be controlled in a similar way.
#' d2 |> dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' rangeslider = "2014-01-01",
#' zeroline = 128)
#'
#' # Shadearea can be used to draw attention to specific area of the plot.
#' d2 |> dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' shadearea = "2019-01-01")
#' # Use set_shadearea() for more fine-tuned control.
#' d2 |> dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' shadearea = set_shadearea(
#' xmin = "2010-06-10",
#' xmax = "2016-01-01",
#' color = "green",
#' opacity = 0.5,
#' border = "gray",
#' layer = "below"
#' ))
#' # roboplotr() can't currently validate your xmin and xmax inputs for shade areas,
#' # and wrong input will probably just fail to produce the area.
#' d2 |> dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue, "Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' shadearea = set_shadearea(
#' xmin = "182625",
#' ))
#' # Finally, you may get html or other files from the plots you create either
#' # by using roboplotr::create_widget() or simply using the
#' # parameter 'artefacts' here. The global defaults or artefact creation are
#' # set with roboplotr::set_roboplot_options(), and for this example the
#' # default filepath will be changed to a temporary directory.
#'
#' set_roboplot_options(
#' artefacts = set_artefacts(filepath = tempdir())
#' )
#'
#' d2 |>
#' dplyr::filter(Suunta == "Tuonti") |>
#' roboplot(Alue,"Energian tuonti","Milj. \u20AC","Tilastokeskus",
#' artefacts = TRUE)
#'
#' file.exists(paste0(tempdir(),"/energian_tuonti.html"))
#'
#' # Reset to defaults
#'
#' set_roboplot_options(reset = TRUE)
#'
#' # Further specifications for creating artefacts is defined under
#' # roboplotr::set_roboplot_options() and roboplotr::set_artefacts().
#'
#' # Using "container" is defined under roboplotr::set_roboplot_options() under
#' # as its usage is tied to using the 'shinyapp' parameter therein.
#' }
#' @export
#' @importFrom dplyr coalesce distinct group_split pull
#' @importFrom forcats fct_reorder
#' @importFrom lubridate as_date ceiling_date is.Date
#' @importFrom plotly partial_bundle
#' @importFrom purrr map2
#' @importFrom rlang as_label as_name enquo eval_tidy get_expr quo quo_get_env
#' @importFrom stats median runif setNames
#' @importFrom stringr str_c str_detect str_length str_pad str_replace
roboplot <- function(d,
color = NULL,
title = NULL,
subtitle = "",
caption = NULL,
legend_orientation = NULL,
legend_position = NULL,
trace_color = NULL,
highlight = NULL,
zeroline = FALSE,
rangeslider = FALSE,
pattern = NULL,
line_width = getOption("roboplot.linewidth"),
hovertext = NULL,
plot_type = "scatter",
plot_mode = NULL,
plot_axes = set_axes(),
markers = set_markers(),
height = getOption("roboplot.height"),
error_bars = NULL,
facet_split = NULL,
legend_maxwidth = NULL,
xaxis_ceiling = getOption("roboplot.xaxis.ceiling"),
width = getOption("roboplot.width"),
legend_title = F,
shadearea = NULL,
secondary_yaxis = NULL,
modebar = NULL,
artefacts = getOption("roboplot.artefacts")$auto,
container = getOption("roboplot.shinyapp")$container,
info_text = NULL,
tidy_legend = getOption("roboplot.legend.tidy"),
...) {
margin <- NA # will this be used at all? Probably not.
if (missing(d)) {
stop("Argument 'd' must a data frame!", call. = F)
}
roboplotr_check_param(d, "data.frame", NULL, allow_null = F)
if (is.null(title)) {
title <- attributes(d)[c("title", "robonomist_title")]
if (!is.null(title$robonomist_title)) {
roboplotr_message("Using the attribute \"robonomist_title\" for plot title.")
title <- set_title(title$robonomist_title)
} else if (!is.null(title$title) & length(title$title != 1)) {
roboplotr_alert("Using the attribute \"title\" as plot title.")
title <- set_title(title$title)
} else {
roboplotr_alert("Missing the title, using placeholder.")
title <- set_title("PLACEHOLDER")
}
} else if (is.character(title)) {
title <- set_title(title = title, include = T)
} else {
roboplotr_check_param(title, c("character,","function"), NULL, f.name = list(fun = substitute(title)[1], check = "set_title"))
}
d_names <- names(d)
d <- d |> mutate(across(where(is.numeric), as.numeric))
roboplotr_check_param(plot_axes,
"function",
NULL,
allow_null = F,
f.name = list(fun = substitute(plot_axes)[1], check = "set_axes"))
if(!is.null(secondary_yaxis)) {
# .plot_axes <- substitute(plot_axes)
if(!is.null(plot_axes$y2)) {
roboplotr_alert("roboplot() param 'secondary_yaxis' overrides y2 set with param 'plot_axes'")
} else {
roboplotr_message("Use roboplot() param 'plot_axes' with set_axes() for more control over secondary yaxis. See documentation.")
}
# .plot_axes$y2 <- secondary_yaxis
# plot_axes <- eval(.plot_axes)
plot_axes$y2 <- secondary_yaxis
}
if (!all(plot_axes[c("x", "y")] %in% d_names)) {
stop(str_glue("'d' must be a data frame with columns named \"{plot_axes$x}\"\"{plot_axes$y}\"!"),
call. = F
)
} else if (!all(class(d[[plot_axes$x]]) %in% str_replace(plot_axes$xclass,"log","numeric"),
class(d[[plot_axes$y]]) %in% str_replace(plot_axes$yclass,"log","numeric"))) {
xclasses <-
roboplotr_combine_words(plot_axes$xclass, sep = '", "', and = '", or "')
yclasses <-
roboplotr_combine_words(plot_axes$yclass, sep = '", "', and = '", or "')
stop(
str_glue("The data frame 'd' column {plot_axes$x} must be {xclasses} and column {plot_axes$y} must be {yclasses}"),
call. = F
)
}
color <- enquo(color)
color <- roboplotr_check_valid_var(color, d_names)
if (is.null(color)) {
color <- quo(!!sym("roboplot.topic"))
}
if (as_name(color) == "roboplot.topic") {
roboplotr_alert(
"Without an unquoted arg 'color' the variable named \"roboplot.topic\" is added to data 'd', using the argument 'title' trunctated to 30 characters as value for the variable."
)
d <- mutate(d, roboplot.topic = str_trunc(title$title, 30))
}
unique_groups <- sort(unique(d[[as_name(color)]]))
pattern <- enquo(pattern)
if(quo_is_call(pattern)) {
if(!as.character(get_expr(pattern)[1]) %in% c("roboplotr::set_pattern", "set_pattern")) {
stop("'pattern' must be a column name from 'd', or function call of set_pattern(), or NULL", call. = FALSE)
}
pattern <- eval_tidy(pattern)
pattern_types <- pattern$pattern_types
pattern_along <- pattern$pattern_along
roboplotr_check_valid_var(pattern_along, d_names)
pattern_showlegend <- pattern$show_legend
pattern_sep <- pattern$pattern_sep
pattern <- pattern$pattern
} else {
pattern_types <- NULL
pattern_along <- NULL
pattern_along <- enquo(pattern_along)
pattern_showlegend <- NULL
pattern_sep <- ", "
}
pattern <- roboplotr_check_valid_var(pattern, d_names)
roboplotr_check_param(
markers,
"function",allow_null = F,
f.name = list(fun = substitute(markers)[1], check = "set_markers")
)
roboplotr_check_param(width, "numeric", allow_null = T, allow_na = T)
roboplotr_check_param(height, "numeric", allow_null = T, allow_na = T)
if(!is.null(width)) { if(is.na(width)) { width <- NULL} }
if(!is.null(height)) { if(is.na(height)) { height <- NULL} }
secondary_yaxis <- plot_axes$y2
roboplotr_check_param(secondary_yaxis, "character", size = NULL, allow_null = T, allow_na = F)
roboplotr_valid_strings(secondary_yaxis, unique_groups,.fun = any)
if (!is.null(secondary_yaxis)) {
if("pie" %in% plot_type) {
roboplotr_warning("secondary_yaxis is ignored with plot_mode \"pie\"!")
secondary_yaxis <- NULL
}
if(is.logical(zeroline)) {
if(zeroline == T)
roboplotr_alert("When using set_axes(y2), zeroline specifications are ignored.")
} else {
roboplotr_alert("When using set_axes(y2), zeroline specifications are ignored.")
}
}
roboplotr_check_param(
error_bars,
"function",
f.name = list(fun = substitute(error_bars)[1], check = "set_errorbars")
)
roboplotr_validate_errorbars(error_bars, d)
roboplotr_check_param(modebar, c("function"), NULL, f.name = list(fun = substitute(modebar)[1], check = "set_modebar"))
roboplotr_check_param(hovertext,
"function",
NULL,
f.name = list(fun = substitute(hovertext)[1], check = "set_hovertext"))
if (is.null(hovertext)) {
hovertext <-
set_hovertext(roboplotr_get_dateformat(d), unit = tolower(subtitle))
} else if (is.null(hovertext$dateformat)) {
hovertext$dateformat <-
roboplotr_hovertemplate_freq(roboplotr_get_dateformat(d))
}
roboplotr_check_param(
caption,
c("character", "function"),
size = 1,
f.name = list(fun = substitute(caption)[1], check = "set_caption")
)
if (!is.null(caption)) {
if (!is(substitute(caption)[1], "call")) {
caption <- set_caption(text = caption)
}
} else {
cpt <- attributes(d)$source
if (length(cpt) == 1) {
roboplotr_message("Using the attribute \"source\" for plot caption.")
caption <- set_caption(text = unlist(cpt)[1])
} else if (!is.null(cpt[[getOption("roboplot.locale")$locale]])) {
roboplotr_message("Using the attribute \"source\" as plot caption.")
caption <-
set_caption(text = cpt[[getOption("roboplot.locale")$locale]][1])
} else {
roboplotr_alert("Missing the caption, using placeholder.")
caption <- set_caption(text = "PLACEHOLDER")
}
}
roboplotr_check_param(xaxis_ceiling, c("character","Date"), allow_null = F)
if (!"date" %in% plot_axes$xticktype | !"time" %in% d_names) {
if (!"default" %in% xaxis_ceiling) {
roboplotr_alert(
"'xaxis_ceiling' is ignored if x-axis is not a date or a \"time\" column does not exist."
)
}
xaxis_ceiling <- "default"
} else if (suppressWarnings(is.na(as_date(xaxis_ceiling)))) {
roboplotr_valid_strings(
xaxis_ceiling,
c(
"default",
"days",
"months",
"weeks",
"quarters",
"years",
"guess"
),
.fun = any
)
} else {
xaxis_ceiling <- as.character(xaxis_ceiling)
}
if (xaxis_ceiling != "default" &
all(is.na(plot_axes$xlim)) &
!"bar" %in% plot_type & !"horizontal" %in% plot_mode) {
if (!is.null(xaxis_ceiling)) {
plot_axes$xlim <-
c(min(d$time), roboplotr_guess_xaxis_ceiling(d, hovertext, xaxis_ceiling))
}
} else if (xaxis_ceiling != "default" &
(!any(is.na(plot_axes$xlim)) ||
any(c("bar", "pie") %in% plot_type) ||
!"horizontal" %in% plot_mode)) {
roboplotr_alert(
"'xaxis_ceiling' is ignored when \"bar\" or \"pie\" is in 'plot_type', \"horizontal\" is in 'plot_mode', or 'xlim' is provided in plot_axes."
)
}
if (!is.null(facet_split)) {
stop("Facet split currently unavailable!", call. = F)
facet_split <- roboplotr_check_valid_var(facet_split, d_names)
if (rangeslider == T |
zeroline == T |
any(!is.na(plot_axes$ylim)))
roboplotr_alert("Rangeslider, zeroline and y-axis range are not currently enabled for faceted plots.")
rangeslider <- F
zeroline <- F
ymin <- min(d$value)
ymax <- max(d$value)
axdif <- diff(c(ymin, ymax)) * 0.04
ymin <- ymin - axdif
ymax <- ymax + axdif
plot_axes$ylim <- c(ymin, ymax)
}
if (any(c("horizontal", "horizontalfill","horizontalstack") %in% plot_mode)) {
if (plot_axes$y == "value") {
roboplotr_alert("Did you want \"value\" to be x-axis? Use the parameter 'plot_axes'.")
}
} else if (plot_axes$y != "value" & "bar" %in% plot_mode) {
roboplotr_alert("Did you want a horizontal bar chart? Use the parameter 'plot_mode'.")
}
ticktypes <-
append(plot_axes,
list(
dateformat = hovertext$dateformat,
reverse = any(str_detect(plot_type, "bar")),
pie = any(str_detect(plot_type, "pie"))
))
if ((!plot_axes$yticktype %in% "numeric" |
!plot_axes$xticktype %in% "date") &
(zeroline != F | rangeslider != F)) {
roboplotr_alert(
"Parameters 'zeroline' and 'rangeslider' are currently disabled when parameter 'plot_axis' xticktype is not date or yticktype is not numeric!"
)
zeroline <- F
rangeslider <- F
}
if (!is.factor(d[[as_name(color)]])) {
if(is.numeric(d[[plot_axes$y]])) {
d <-
mutate(d,{{color}} := fct_reorder({{color}}, as.numeric(.data[[plot_axes$y]]), .fun = mean, .na_rm = T) |> fct_rev())
roboplotr_message(str_glue("roboplotr arranged data 'd' column '{as_label(color)}' using mean of '{plot_axes$y}' by group. Relevel the column as factor with levels of your liking to control trace order."))
} else {
d <- mutate(d,{{color}} := fct_inorder({{color}}))
roboplotr_message(str_glue("roboplotr arranged data 'd' column '{as_label(color)}' as factor."))
}
}
d <-
d |> group_by(!!color) |> filter(!all(is.na(.data$value))) |> ungroup() |> droplevels()
if (!all(plot_type %in% c("scatter", "bar", "pie"))) {
stop("Plot type must be \"scatter\", \"bar\", or \"pie\", or a named character vector!",
call. = F)
} else if ("pie" %in% plot_type & length(unique(plot_type)) > 1) {
stop("Roboplotr is unable to combine the plot_type \"pie\" with other plot types!",
call. = F)
} else if (length(plot_type) == 1 & is.null(names(plot_type))) {
d <- d |> mutate(roboplot.plot.type = plot_type)
} else if (!all(unique_groups %in% names(plot_type)) &
!(".other" %in% names(plot_type))) {
stop(
str_c(
"All variables in column \"",
as_name(color),
"\" must have a corresponding 'plot_type', or key \".other\" must be included!"
),
call. = F
)
} else {
missing_groups <-
unique_groups |> subset(!unique_groups %in% names(plot_type))
if (length(missing_groups) > 0) {
detected_widths <-
map2(unname(plot_type), names(plot_type), function(pt, nm) {
miss <-
missing_groups |> subset(str_detect(missing_groups, str_c(nm, collapse = "|")))
rep(pt, length(miss)) |> setNames(miss)
}) |> roboplotr_compact() |> unlist()
plot_type <- c(plot_type, detected_widths)
}
d <-
mutate(d, roboplot.plot.type = plot_type[as.character(!!color)] |> coalesce(plot_type[".other"]))
}
d <- roboplotr_set_plot_mode(d, color, plot_mode)
if (!all(typeof(line_width) == "double")) {
stop("Line width must be a double, or a named double vector!", call. = F)
} else if (length(line_width) == 1 & is.null(names(line_width))) {
d <- d |> mutate(roboplot.linewidth = line_width)
} else {
if (!all(unique_groups %in% names(line_width))) {
line_width <-
c(line_width, c(".other" = getOption("roboplot.linewidth")))
}
missing_groups <-
unique_groups |> subset(!unique_groups %in% names(line_width))
if (length(missing_groups) > 0) {
detected_widths <-
map2(unname(line_width), names(line_width), function(lw, nm) {
miss <-
missing_groups |> subset(str_detect(missing_groups, str_c(nm, collapse = "|")))
rep(lw, length(miss)) |> setNames(miss)
}) |> roboplotr_compact() |> unlist()
line_width <- c(line_width, detected_widths)
}
d <-
mutate(d, roboplot.linewidth = line_width[as.character(!!color)] |> coalesce(line_width[".other"]))
}
color_vector <-
roboplotr_set_colors(trace_color, unique_groups, highlight, d, color)
d <-
d |>
roboplotr_get_pattern(pattern, pattern_types) |>
mutate(roboplot.trace.color = color_vector[as.character(!!color)])
if(!quo_is_null(pattern_along)) {
if(!all(unique(d$roboplot.plot.mode) == "line")) {
roboplotr_warning("'pattern_along' in set_pattern() was ignored, it currently only works with line traces only!")
pattern_showlegend <- NULL
} else {
roboplotr_warning(
str_glue(
"roboplotr attempts to make continous line with different patterns along '{as_name(pattern)}' over '{as_name(pattern_along)}. ",
"Be sure to arrange the data in proper order. For complex data you are better off handling the data manipulation outside of roboplot()."
)
)
d <- roboplotr_continuous_pattern(d, {{pattern_along}}, {{pattern}})
}
}
if (all(is.null(legend_position), length(unique_groups) < 2, is.null(pattern))) {
legend_position <- NA
}
pattern_showlegend <- roboplotr_get_pattern_showlegend(
d, pattern, pattern_showlegend, legend_position
)
roboplotr_check_param(legend_title, c("logical", "character"), allow_null = F)